diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -2,54 +2,62 @@ # The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for. env: -# - GHCVER=6.12.3 -# - GHCVER=7.0.1 -# - GHCVER=7.0.2 -# - GHCVER=7.0.3 -# - GHCVER=7.0.4 -# - GHCVER=7.2.1 -# - GHCVER=7.2.2 -# - GHCVER=7.4.1 - - GHCVER=7.4.2 -# - GHCVER=7.6.1 -# - GHCVER=7.6.2 - - GHCVER=7.6.3 -# - GHCVER=7.8.1 # see note about Alex/Happy -# - GHCVER=7.8.2 # see note about Alex/Happy - - GHCVER=7.8.3 # see note about Alex/Happy -# - GHCVER=head # see section about GHC HEAD snapshots +# - CABALVER=1.16 GHCVER=6.12.3 +# - CABALVER=1.16 GHCVER=7.0.1 +# - CABALVER=1.16 GHCVER=7.0.2 +# - CABALVER=1.16 GHCVER=7.0.3 +# - CABALVER=1.16 GHCVER=7.0.4 +# - CABALVER=1.16 GHCVER=7.2.1 +# - CABALVER=1.16 GHCVER=7.2.2 +# - CABALVER=1.16 GHCVER=7.4.1 + - CABALVER=1.16 GHCVER=7.4.2 +# - CABALVER=1.16 GHCVER=7.6.1 +# - CABALVER=1.16 GHCVER=7.6.2 + - CABALVER=1.18 GHCVER=7.6.3 +# - CABALVER=1.18 GHCVER=7.8.1 # see note about Alex/Happy for GHC >= 7.8 +# - CABALVER=1.18 GHCVER=7.8.2 + - CABALVER=1.18 GHCVER=7.8.3 + - CABALVER=1.22 GHCVER=7.10.1 +# - CABALVER=head GHCVER=head # see section about GHC HEAD snapshots +matrix: + allow_failures: + - env: CABALVER=1.22 GHCVER=7.10.1 + # Note: the distinction between `before_install` and `install` is not important. before_install: - travis_retry sudo add-apt-repository -y ppa:hvr/ghc - travis_retry sudo apt-get update - - travis_retry sudo apt-get install cabal-install-1.18 ghc-$GHCVER # see note about happy/alex - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:$PATH + - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH - | - if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ]; then - travis_retry sudo apt-get install happy-1.19.3 alex-3.1.3 - export PATH=/opt/alex/3.1.3/bin:/opt/happy/1.19.3/bin:$PATH + if [ $GHCVER = "head" ] || [ ${GHCVER%.*} = "7.8" ] || [ ${GHCVER%.*} = "7.10" ]; then + travis_retry 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 else travis_retry sudo apt-get install happy alex fi install: - - cabal update - - cabal install --only-dependencies --enable-tests -v2 # -v2 provides useful information for debugging + - cabal --version + - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" + - travis_retry cabal update + - cabal install --only-dependencies --enable-tests --enable-benchmarks --flag=BuildToyFMF --flag=BuildSamplePrograms --flag=BuildMiscPrograms # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. script: - - cabal configure --enable-tests -v2 # -v2 provides useful information for debugging + - if [ -f configure.ac ]; then autoreconf -i; fi + - cabal configure --enable-tests --enable-benchmarks -v2 --flag=BuildToyFMF --flag=BuildSamplePrograms --flag=BuildMiscPrograms # -v2 provides useful information for debugging - cabal build # this builds all libraries and executables (including tests/benchmarks) - cabal test - cabal check - cabal sdist # tests that a source-distribution can be generated # The following scriptlet checks that the resulting source distribution can be built & installed - - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ; + - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; cd dist/; if [ -f "$SRC_TGZ" ]; then - cabal install "$SRC_TGZ"; + cabal install --force-reinstalls "$SRC_TGZ"; else echo "expected '$SRC_TGZ' not found"; exit 1; diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ toysolver ========= -[![Build Status](https://secure.travis-ci.org/msakai/toysolver.png?branch=master)](http://travis-ci.org/msakai/toysolver) +[![Build Status](https://secure.travis-ci.org/msakai/toysolver.png?branch=master)](http://travis-ci.org/msakai/toysolver) [![Hackage](https://budueba.com/hackage/toysolver)](https://hackage.haskell.org/package/toysolver) Assorted decision procedures for SAT, Max-SAT, PB, MIP, etc. @@ -22,11 +22,28 @@ Arithmetic solver for the following problems: * Mixed Integer Liner Programming (MILP or MIP) +* Boolean SATisfiability problem (SAT) +* PB + * Pseudo Boolean Satisfaction (PBS) + * Pseudo Boolean Optimization (PBO) + * Weighted Boolean Optimization (WBO) +* Max-SAT families + * Max-SAT + * Partial Max-SAT + * Weighted Max-SAT + * Weighted Partial Max-SAT * Real Closed Field * LA(Q), LA(Z) (NOT IMPLEMENTED YET) -Usage: toysolver [OPTION...] file.lp +Usage: + toysolver [OPTION...] [file.lp|file.mps] + toysolver --lp [OPTION...] [file.lp|file.mps] + toysolver --sat [OPTION...] [file.cnf] + toysolver --pb [OPTION...] [file.opb] + toysolver --wbo [OPTION...] [file.wbo] + toysolver --maxsat [OPTION...] [file.cnf|file.wcnf] + -h --help show help -v --version show version number --solver=SOLVER mip (default), omega-test, cooper, cad, old-mip, ct @@ -36,17 +53,24 @@ SAT-based solver for the following problems: * SAT + * Boolean SATisfiability problem (SAT) * Minimally Unsatisfiable Subset (MUS) + * Group-Oriented MUS (GMUS) * PB * Pseudo Boolean Satisfaction (PBS) * Pseudo Boolean Optimization (PBO) * Weighted Boolean Optimization (WBO) -* Max-SAT +* Max-SAT families + * Max-SAT + * Partial Max-SAT + * Weighted Max-SAT + * Weighted Partial Max-SAT * Integer Programming (all variables must be bounded) Usage: toysat [file.cnf|-] + toysat --sat [file.cnf|-] toysat --mus [file.gcnf|file.cnf|-] toysat --pb [file.opb|-] toysat --wbo [file.wbo|-] @@ -65,7 +89,7 @@ Usage: - toyfmf file.tptp size + toyfmf [file.tptp] [size] ### lpconvert @@ -73,12 +97,12 @@ Usage: - lpconvert -o + lpconvert -o [outputfile] [inputfile] Supported formats: * Input formats: lp, mps, cnf, wcnf, opb, wbo -* Output formats: lp, smt2, ys +* Output formats: lp, .mps, smt2, ys ### pbconvert @@ -86,7 +110,7 @@ Usage: - pbconvert -o + pbconvert -o [outputfile] [inputfile] Supported formats: diff --git a/benchmarks/BenchmarkSATLIB.hs b/benchmarks/BenchmarkSATLIB.hs --- a/benchmarks/BenchmarkSATLIB.hs +++ b/benchmarks/BenchmarkSATLIB.hs @@ -5,7 +5,7 @@ import Text.Printf import Criterion.Main import qualified Language.CNF.Parse.ParseDIMACS as DIMACS -import qualified SAT +import qualified ToySolver.SAT as SAT solve :: FilePath -> IO () solve fname = do @@ -25,13 +25,13 @@ main = do Criterion.Main.defaultMain [ bgroup "uf250-1065" - [ bench fname (solve path) + [ bench fname $ whnfIO (solve path) | i <- [(1::Int)..100] , let fname = printf "uf250-0%d.cnf" i , let path = "benchmarks/UF250.1065.100/" ++ fname ] , bgroup "uuf250-1065" - [ bench fname (solve path) + [ bench fname $ whnfIO (solve path) | i <- [(1::Int)..100] , let fname = printf "uuf250-0%d.cnf" i , let path = "benchmarks/UUF250.1065.100/" ++ fname diff --git a/lpconvert/lpconvert.hs b/lpconvert/lpconvert.hs --- a/lpconvert/lpconvert.hs +++ b/lpconvert/lpconvert.hs @@ -26,7 +26,6 @@ import qualified ToySolver.Data.MIP as MIP import qualified ToySolver.Text.LPFile as LPFile import qualified ToySolver.Text.MaxSAT as MaxSAT -import qualified ToySolver.Text.MPSFile as MPSFile import qualified ToySolver.Text.PBFile as PBFile import ToySolver.Converter.ObjType import qualified ToySolver.Converter.MIP2SMT as MIP2SMT @@ -117,12 +116,12 @@ let (mip, _) = PB2IP.convertWBO (IndicatorConstraint `elem` o) formula return mip ".lp" -> do - ret <- LPFile.parseFile fname + ret <- MIP.readLPFile fname case ret of Left err -> hPrint stderr err >> exitFailure Right mip -> return mip ".mps" -> do - ret <- MPSFile.parseFile fname + ret <- MIP.readMPSFile fname case ret of Left err -> hPrint stderr err >> exitFailure Right mip -> return mip @@ -159,20 +158,14 @@ } case head ([Just fname | Output fname <- o] ++ [Nothing]) of - Nothing -> do + Nothing -> case LPFile.render mip of - Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure - Just s -> putStr s + Left err -> hPutStrLn stderr ("conversion failure: " ++ err) >> exitFailure + Right s -> putStr s Just fname -> do case map toLower (takeExtension fname) of - ".lp" -> do - case LPFile.render mip of - Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure - Just s -> writeFile fname s - ".mps" -> do - case MPSFile.render mip of - Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure - Just s -> writeFile fname s + ".lp" -> MIP.writeLPFile fname mip + ".mps" -> MIP.writeMPSFile fname mip ".smt2" -> do writeFile fname (MIP2SMT.convert mip2smtOpt mip "") ".ys" -> do diff --git a/maxsatverify/maxsatverify.hs b/maxsatverify/maxsatverify.hs --- a/maxsatverify/maxsatverify.hs +++ b/maxsatverify/maxsatverify.hs @@ -5,8 +5,8 @@ import Data.IORef import System.Environment import Text.Printf -import qualified Text.MaxSAT as MaxSAT -import SAT.Types +import qualified ToySolver.Text.MaxSAT as MaxSAT +import ToySolver.SAT.Types main :: IO () main = do diff --git a/pbconvert/pbconvert.hs b/pbconvert/pbconvert.hs --- a/pbconvert/pbconvert.hs +++ b/pbconvert/pbconvert.hs @@ -23,8 +23,7 @@ import System.Console.GetOpt import qualified Language.CNF.Parse.ParseDIMACS as DIMACS -import qualified ToySolver.Text.LPFile as LPFile -import qualified ToySolver.Text.MPSFile as MPSFile +import qualified ToySolver.Data.MIP as MIP import qualified ToySolver.Text.MaxSAT as MaxSAT import qualified ToySolver.Text.PBFile as PBFile import ToySolver.Converter.ObjType @@ -142,8 +141,8 @@ case head ([Just fname | Output fname <- o] ++ [Nothing]) of Nothing -> do case pb of - Left opb -> putStr $ PBFile.showOPB opb "" - Right wbo -> putStr $ PBFile.showWBO wbo "" + Left opb -> putStr $ PBFile.renderOPB opb + Right wbo -> putStr $ PBFile.renderWBO wbo Just fname -> do let opb = case pb of Left opb -> opb @@ -158,17 +157,11 @@ Left opb -> PB2LSP.convert opb Right wbo -> PB2LSP.convertWBO wbo case map toLower (takeExtension fname) of - ".opb" -> writeFile fname (PBFile.showOPB opb "") - ".wbo" -> writeFile fname (PBFile.showWBO wbo "") + ".opb" -> writeFile fname $ PBFile.renderOPB opb + ".wbo" -> writeFile fname $ PBFile.renderWBO wbo ".lsp" -> writeFile fname (lsp "") - ".lp" -> do - case LPFile.render lp of - Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure - Just s -> writeFile fname s - ".mps" -> do - case MPSFile.render lp of - Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure - Just s -> writeFile fname s + ".lp" -> MIP.writeLPFile fname lp + ".mps" -> MIP.writeMPSFile fname lp ".smp" -> do writeFile fname (PB2SMP.convert False opb "") ".smt2" -> do diff --git a/pigeonhole/pigeonhole.hs b/pigeonhole/pigeonhole.hs --- a/pigeonhole/pigeonhole.hs +++ b/pigeonhole/pigeonhole.hs @@ -6,7 +6,7 @@ import System.Environment import System.Exit import System.IO -import Text.PBFile as PBFile +import ToySolver.Text.PBFile as PBFile pigeonHole :: Integer -> Integer -> Formula pigeonHole p h = @@ -35,7 +35,7 @@ case xs of [p,h] -> do let opb = pigeonHole (read p) (read h) - putStr $ showOPB opb "" + putStr $ renderOPB opb _ -> do hPutStrLn stderr "Usage: pigeonhole number_of_pigeons number_of_holes" exitFailure diff --git a/samples/gcnf/example.cnf b/samples/gcnf/example.cnf new file mode 100644 --- /dev/null +++ b/samples/gcnf/example.cnf @@ -0,0 +1,8 @@ +p cnf 7 3 +1 2 3 0 +-1 2 0 +-2 3 0 +-3 0 +2 -3 0 +-2 -3 0 +-2 3 0 diff --git a/samples/lp/baroque-tower.lp b/samples/lp/baroque-tower.lp new file mode 100644 --- /dev/null +++ b/samples/lp/baroque-tower.lp @@ -0,0 +1,55 @@ +\ ドラクエ７のバロックの塔 (バロックタワー) の謎解き (ギミック) +\ +\ http://ryocotan.tumblr.com/post/46204757099 +\ http://msakai.jp/d/?date=20130402#p01 +\ +\ 銅像が上下左右に４つあり、それを全て中心に向かせればOK。 +\ 銅像の間 （四隅） にはボタンがあって、それを押すと、 +\ そのボタンから反時計周りに３つの銅像が、右に９０度回転する。 +\ 初期状態では、上下左右の銅像の向きは順に右上上左。 +\ +\ x1, x2, x3, x4 をそれぞれ左上、右上、右下、左下の石を押す回数とすると、 +\ 最短の手順を求める問題は、以下の最適化問題として定式化できる。 +\ +\ Minimize +\ x1 + x2 + x3 + x4 +\ Subject To +\ 3 + x1 + x2 + x3 ≡ 0 mod 4 (左の像の条件) +\ 3 + x2 + x3 + x4 ≡ 0 mod 4 (上の像の条件) +\ x3 + x4 + x1 ≡ 0 mod 4 (右の像の条件) +\ x4 + x1 + x2 ≡ 0 mod 4 (下の像の条件) +\ x1, x2, x3, x4 ≥ 0 +\ x1, x2, x3, x4 ∈ Z +\ +\ 追加的な変数を導入してmodを取り除けば、これは整数線形計画問題になる。 +\ +Minimize + x1 + x2 + x3 + x4 +Subject To + x1 + x2 + x3 - 4 n1 = -3 + x2 + x3 + x4 - 4 n2 = -3 + x3 + x4 + x1 - 4 n3 = 0 + x4 + x1 + x2 - 4 n4 = 0 +Bounds + 0 <= x1 + 0 <= x2 + 0 <= x3 + 0 <= x4 + 0 <= n1 + 0 <= n2 + 0 <= n3 + 0 <= n4 +General + x1 x2 x3 x4 n1 n2 n3 n4 +End + +\ o 6 +\ s OPTIMUM FOUND +\ v n1 = 2 +\ v n2 = 2 +\ v n3 = 1 +\ v n4 = 1 +\ v x1 = 1 +\ v x2 = 2 +\ v x3 = 2 +\ v x4 = 1 diff --git a/samples/lp/hoge.lp b/samples/lp/hoge.lp new file mode 100644 --- /dev/null +++ b/samples/lp/hoge.lp @@ -0,0 +1,7 @@ +Minimize + obj: x1 + x2 +Subject To + c1: x1 + 2 x2 + x3 = 3 +General + x1 x2 x3 +End diff --git a/samples/lp/test-2.lp b/samples/lp/test-2.lp new file mode 100644 --- /dev/null +++ b/samples/lp/test-2.lp @@ -0,0 +1,14 @@ +MAXIMIZE +obj: + x1 + 2 x2 + 3 x3 + x4 +SUBJECT TO +c1: - x1 + x2 + x3 + 10 x4 <= 20 +c2: + x1 - 3 x2 + x3 <= 30 +c3: + x2 - 3.5 x4 = 0 +BOUNDS +2 <= x4 <= 3 +0 <= x1 <= 40 +0 <= x2 <= +inf +0 <= x3 <= +inf +GENERALS +x4 +END diff --git a/samples/lp/test-lazy.lp b/samples/lp/test-lazy.lp new file mode 100644 --- /dev/null +++ b/samples/lp/test-lazy.lp @@ -0,0 +1,16 @@ +\ http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r3/topic/ilog.odms.cplex.help/Content/Optimization/Documentation/Optimization_Studio/_pubskel/ps_usrmancplex2051.html +Maximize + obj: 12 x1 + 5 x2 + 15 x3 + 10 x4 +Subject To + c1: 5 x1 + x2 + 9 x3 + 12 x4 <= 15 +Lazy Constraints + l1: 2 x1 + 3 x2 + 4 x3 + x4 <= 10 + l2: 3 x1 + 2 x2 + 4 x3 + 10 x4 <= 8 +Bounds + 0 <= x1 <= 5 + 0 <= x2 <= 5 + 0 <= x3 <= 5 + 0 <= x4 <= 5 +Generals + x1 x2 x3 x4 +End diff --git a/samples/lp/test-semiint-2.lp b/samples/lp/test-semiint-2.lp new file mode 100644 --- /dev/null +++ b/samples/lp/test-semiint-2.lp @@ -0,0 +1,14 @@ +MINIMIZE +obj: - 2 x3 +SUBJECT TO +c1: + x2 - x1 <= 10 +c2: + x3 + x2 + x1 <= 20 +BOUNDS +2.1 <= x1 <= 30 +0 <= x2 <= +inf +2 <= x3 <= 3 +GENERALS +x1 x3 +SEMI-CONTINUOUS +x1 x3 +END diff --git a/samples/lp/test2.lp b/samples/lp/test2.lp new file mode 100644 --- /dev/null +++ b/samples/lp/test2.lp @@ -0,0 +1,21 @@ +\... +Maximize + obj: x1 + 2 x2 + 3 x3 + x4 +Subject To + c1: - x1 + x2 + x3 + 10 x4 <= 20 + c2: x1 - 3 x2 + x3 <= 30 + c3: x2 - 3.5 x4 = 0 + c4: x6 + x7 + x8 + x9 >= 0 +Bounds + 0 <= x1 <= 40 + -2 <= x4 <= 3 + -inf <= x5 <= +inf + 0 <= x6 <= +inf + -1 <= x7 <= +inf + -inf <= x8 <= +1 + 1 <= x9 <= +inf +General + x4 x5 x6 x7 x8 +SEMI-CONTINUOUS + x9 +End diff --git a/samples/maxsat/FM06.cnf b/samples/maxsat/FM06.cnf new file mode 100644 --- /dev/null +++ b/samples/maxsat/FM06.cnf @@ -0,0 +1,8 @@ +p cnf 4 7 +-1 -2 0 +-1 3 0 +-1 -3 0 +-2 4 0 +-2 -4 0 +1 0 +2 0 diff --git a/samples/mps/enlight13-2.mps b/samples/mps/enlight13-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/enlight13-2.mps @@ -0,0 +1,1819 @@ +NAME +OBJSENSE + MIN +ROWS + N moves + E inner_area_1 + E inner_area_2 + E inner_area_3 + E inner_area_4 + E inner_area_5 + E inner_area_6 + E inner_area_7 + E inner_area_8 + E inner_area_9 + E inner_area_10 + E inner_area_11 + E inner_area_12 + E inner_area_13 + E inner_area_14 + E inner_area_15 + E inner_area_16 + E inner_area_17 + E inner_area_18 + E inner_area_19 + E inner_area_20 + E inner_area_21 + E inner_area_22 + E inner_area_23 + E inner_area_24 + E inner_area_25 + E inner_area_26 + E inner_area_27 + E inner_area_28 + E inner_area_29 + E inner_area_30 + E inner_area_31 + E inner_area_32 + E inner_area_33 + E inner_area_34 + E inner_area_35 + E inner_area_36 + E inner_area_37 + E inner_area_38 + E inner_area_39 + E inner_area_40 + E inner_area_41 + E inner_area_42 + E inner_area_43 + E inner_area_44 + E inner_area_45 + E inner_area_46 + E inner_area_47 + E inner_area_48 + E inner_area_49 + E inner_area_50 + E inner_area_51 + E inner_area_52 + E inner_area_53 + E inner_area_54 + E inner_area_55 + E inner_area_56 + E inner_area_57 + E inner_area_58 + E inner_area_59 + E inner_area_60 + E inner_area_61 + E inner_area_62 + E inner_area_63 + E inner_area_64 + E inner_area_65 + E inner_area_66 + E inner_area_67 + E inner_area_68 + E inner_area_69 + E inner_area_70 + E inner_area_71 + E inner_area_72 + E inner_area_73 + E inner_area_74 + E inner_area_75 + E inner_area_76 + E inner_area_77 + E inner_area_78 + E inner_area_79 + E inner_area_80 + E inner_area_81 + E inner_area_82 + E inner_area_83 + E inner_area_84 + E inner_area_85 + E inner_area_86 + E inner_area_87 + E inner_area_88 + E inner_area_89 + E inner_area_90 + E inner_area_91 + E inner_area_92 + E inner_area_93 + E inner_area_94 + E inner_area_95 + E inner_area_96 + E inner_area_97 + E inner_area_98 + E inner_area_99 + E inner_area_100 + E inner_area_101 + E inner_area_102 + E inner_area_103 + E inner_area_104 + E inner_area_105 + E inner_area_106 + E inner_area_107 + E inner_area_108 + E inner_area_109 + E inner_area_110 + E inner_area_111 + E inner_area_112 + E inner_area_113 + E inner_area_114 + E inner_area_115 + E inner_area_116 + E inner_area_117 + E inner_area_118 + E inner_area_119 + E inner_area_120 + E inner_area_121 + E upper_border_1 + E upper_border_2 + E upper_border_3 + E upper_border_4 + E upper_border_5 + E upper_border_6 + E upper_border_7 + E upper_border_8 + E upper_border_9 + E upper_border_10 + E upper_border_11 + E lower_border_1 + E lower_border_2 + E lower_border_3 + E lower_border_4 + E lower_border_5 + E lower_border_6 + E lower_border_7 + E lower_border_8 + E lower_border_9 + E lower_border_10 + E lower_border_11 + E left_border_1 + E left_border_2 + E left_border_3 + E left_border_4 + E left_border_5 + E left_border_6 + E left_border_7 + E left_border_8 + E left_border_9 + E left_border_10 + E left_border_11 + E right_border_1 + E right_border_2 + E right_border_3 + E right_border_4 + E right_border_5 + E right_border_6 + E right_border_7 + E right_border_8 + E right_border_9 + E right_border_10 + E right_border_11 + E left_upper_co@a5 + E left_lower_co@a6 + E right_upper_c@a7 + E right_lower_c@a8 +COLUMNS + MARK0000 'MARKER' 'INTORG' + x#11#4 inner_area_101 1 + x#11#4 inner_area_102 1 + x#11#4 inner_area_103 1 + x#11#4 inner_area_113 1 + x#11#4 inner_area_91 1 + x#11#4 moves 1 + x#11#5 inner_area_102 1 + x#11#5 inner_area_103 1 + x#11#5 inner_area_104 1 + x#11#5 inner_area_114 1 + x#11#5 inner_area_92 1 + x#11#5 moves 1 + x#11#6 inner_area_103 1 + x#11#6 inner_area_104 1 + x#11#6 inner_area_105 1 + x#11#6 inner_area_115 1 + x#11#6 inner_area_93 1 + x#11#6 moves 1 + x#11#7 inner_area_104 1 + x#11#7 inner_area_105 1 + x#11#7 inner_area_106 1 + x#11#7 inner_area_116 1 + x#11#7 inner_area_94 1 + x#11#7 moves 1 + x#11#1 inner_area_100 1 + x#11#1 left_border_10 1 + x#11#1 left_border_11 1 + x#11#1 left_border_9 1 + x#11#1 moves 1 + x#11#2 inner_area_100 1 + x#11#2 inner_area_101 1 + x#11#2 inner_area_111 1 + x#11#2 inner_area_89 1 + x#11#2 left_border_10 1 + x#11#2 moves 1 + x#11#3 inner_area_100 1 + x#11#3 inner_area_101 1 + x#11#3 inner_area_102 1 + x#11#3 inner_area_112 1 + x#11#3 inner_area_90 1 + x#11#3 moves 1 + x#11#8 inner_area_105 1 + x#11#8 inner_area_106 1 + x#11#8 inner_area_107 1 + x#11#8 inner_area_117 1 + x#11#8 inner_area_95 1 + x#11#8 moves 1 + x#11#9 inner_area_106 1 + x#11#9 inner_area_107 1 + x#11#9 inner_area_108 1 + x#11#9 inner_area_118 1 + x#11#9 inner_area_96 1 + x#11#9 moves 1 + x#2#11 inner_area_10 1 + x#2#11 inner_area_11 1 + x#2#11 inner_area_21 1 + x#2#11 inner_area_9 1 + x#2#11 moves 1 + x#2#11 upper_border_10 1 + x#2#10 inner_area_10 1 + x#2#10 inner_area_20 1 + x#2#10 inner_area_8 1 + x#2#10 inner_area_9 1 + x#2#10 moves 1 + x#2#10 upper_border_9 1 + x#2#13 inner_area_11 1 + x#2#13 moves 1 + x#2#13 right_border_1 1 + x#2#13 right_border_2 1 + x#2#13 right_upper_c@a7 1 + x#2#12 inner_area_10 1 + x#2#12 inner_area_11 1 + x#2#12 inner_area_22 1 + x#2#12 moves 1 + x#2#12 right_border_1 1 + x#2#12 upper_border_11 1 + y#8#10 inner_area_75 -2 + y#8#11 inner_area_76 -2 + y#8#12 inner_area_77 -2 + y#1#10 upper_border_9 -2 + x#5#10 inner_area_31 1 + x#5#10 inner_area_41 1 + x#5#10 inner_area_42 1 + x#5#10 inner_area_43 1 + x#5#10 inner_area_53 1 + x#5#10 moves 1 + x#5#11 inner_area_32 1 + x#5#11 inner_area_42 1 + x#5#11 inner_area_43 1 + x#5#11 inner_area_44 1 + x#5#11 inner_area_54 1 + x#5#11 moves 1 + x#5#12 inner_area_33 1 + x#5#12 inner_area_43 1 + x#5#12 inner_area_44 1 + x#5#12 inner_area_55 1 + x#5#12 moves 1 + x#5#12 right_border_4 1 + x#5#13 inner_area_44 1 + x#5#13 moves 1 + x#5#13 right_border_3 1 + x#5#13 right_border_4 1 + x#5#13 right_border_5 1 + y#13#10 lower_border_9 -2 + y#13#11 lower_border_10 -2 + y#13#12 lower_border_11 -2 + y#13#13 right_lower_c@a8 -2 + y#9#13 right_border_8 -2 + y#9#12 inner_area_88 -2 + y#9#11 inner_area_87 -2 + y#9#10 inner_area_86 -2 + y#6#12 inner_area_55 -2 + y#6#13 right_border_5 -2 + y#6#10 inner_area_53 -2 + y#6#11 inner_area_54 -2 + y#12#13 right_border_11 -2 + y#12#12 inner_area_121 -2 + y#12#11 inner_area_120 -2 + y#12#10 inner_area_119 -2 + y#2#12 inner_area_11 -2 + y#2#13 right_border_1 -2 + y#2#10 inner_area_9 -2 + y#2#11 inner_area_10 -2 + x#13#11 inner_area_120 1 + x#13#11 lower_border_10 1 + x#13#11 lower_border_11 1 + x#13#11 lower_border_9 1 + x#13#11 moves 1 + x#13#10 inner_area_119 1 + x#13#10 lower_border_10 1 + x#13#10 lower_border_8 1 + x#13#10 lower_border_9 1 + x#13#10 moves 1 + x#13#13 lower_border_11 1 + x#13#13 moves 1 + x#13#13 right_border_11 1 + x#13#13 right_lower_c@a8 1 + x#13#12 inner_area_121 1 + x#13#12 lower_border_10 1 + x#13#12 lower_border_11 1 + x#13#12 moves 1 + x#13#12 right_lower_c@a8 1 + x#1#10 inner_area_9 1 + x#1#10 moves 1 + x#1#10 upper_border_10 1 + x#1#10 upper_border_8 1 + x#1#10 upper_border_9 1 + x#1#11 inner_area_10 1 + x#1#11 moves 1 + x#1#11 upper_border_10 1 + x#1#11 upper_border_11 1 + x#1#11 upper_border_9 1 + x#1#12 inner_area_11 1 + x#1#12 moves 1 + x#1#12 right_upper_c@a7 1 + x#1#12 upper_border_10 1 + x#1#12 upper_border_11 1 + x#1#13 moves 1 + x#1#13 right_border_1 1 + x#1#13 right_upper_c@a7 1 + x#1#13 upper_border_11 1 + y#1#4 upper_border_3 -2 + y#1#5 upper_border_4 -2 + y#1#6 upper_border_5 -2 + y#1#7 upper_border_6 -2 + x#9#9 inner_area_74 1 + x#9#9 inner_area_84 1 + x#9#9 inner_area_85 1 + x#9#9 inner_area_86 1 + x#9#9 inner_area_96 1 + x#9#9 moves 1 + x#9#8 inner_area_73 1 + x#9#8 inner_area_83 1 + x#9#8 inner_area_84 1 + x#9#8 inner_area_85 1 + x#9#8 inner_area_95 1 + x#9#8 moves 1 + y#1#2 upper_border_1 -2 + y#1#3 upper_border_2 -2 + x#9#5 inner_area_70 1 + x#9#5 inner_area_80 1 + x#9#5 inner_area_81 1 + x#9#5 inner_area_82 1 + x#9#5 inner_area_92 1 + x#9#5 moves 1 + x#9#4 inner_area_69 1 + x#9#4 inner_area_79 1 + x#9#4 inner_area_80 1 + x#9#4 inner_area_81 1 + x#9#4 inner_area_91 1 + x#9#4 moves 1 + x#9#7 inner_area_72 1 + x#9#7 inner_area_82 1 + x#9#7 inner_area_83 1 + x#9#7 inner_area_84 1 + x#9#7 inner_area_94 1 + x#9#7 moves 1 + x#9#6 inner_area_71 1 + x#9#6 inner_area_81 1 + x#9#6 inner_area_82 1 + x#9#6 inner_area_83 1 + x#9#6 inner_area_93 1 + x#9#6 moves 1 + x#9#1 inner_area_78 1 + x#9#1 left_border_7 1 + x#9#1 left_border_8 1 + x#9#1 left_border_9 1 + x#9#1 moves 1 + y#1#9 upper_border_8 -2 + x#9#3 inner_area_68 1 + x#9#3 inner_area_78 1 + x#9#3 inner_area_79 1 + x#9#3 inner_area_80 1 + x#9#3 inner_area_90 1 + x#9#3 moves 1 + x#9#2 inner_area_67 1 + x#9#2 inner_area_78 1 + x#9#2 inner_area_79 1 + x#9#2 inner_area_89 1 + x#9#2 left_border_8 1 + x#9#2 moves 1 + x#12#3 inner_area_101 1 + x#12#3 inner_area_111 1 + x#12#3 inner_area_112 1 + x#12#3 inner_area_113 1 + x#12#3 lower_border_2 1 + x#12#3 moves 1 + x#12#2 inner_area_100 1 + x#12#2 inner_area_111 1 + x#12#2 inner_area_112 1 + x#12#2 left_border_11 1 + x#12#2 lower_border_1 1 + x#12#2 moves 1 + x#12#1 inner_area_111 1 + x#12#1 left_border_10 1 + x#12#1 left_border_11 1 + x#12#1 left_lower_co@a6 1 + x#12#1 moves 1 + y#3#1 left_border_2 -2 + x#12#7 inner_area_105 1 + x#12#7 inner_area_115 1 + x#12#7 inner_area_116 1 + x#12#7 inner_area_117 1 + x#12#7 lower_border_6 1 + x#12#7 moves 1 + x#12#6 inner_area_104 1 + x#12#6 inner_area_114 1 + x#12#6 inner_area_115 1 + x#12#6 inner_area_116 1 + x#12#6 lower_border_5 1 + x#12#6 moves 1 + x#12#5 inner_area_103 1 + x#12#5 inner_area_113 1 + x#12#5 inner_area_114 1 + x#12#5 inner_area_115 1 + x#12#5 lower_border_4 1 + x#12#5 moves 1 + x#12#4 inner_area_102 1 + x#12#4 inner_area_112 1 + x#12#4 inner_area_113 1 + x#12#4 inner_area_114 1 + x#12#4 lower_border_3 1 + x#12#4 moves 1 + y#6#7 inner_area_50 -2 + y#6#6 inner_area_49 -2 + x#12#9 inner_area_107 1 + x#12#9 inner_area_117 1 + x#12#9 inner_area_118 1 + x#12#9 inner_area_119 1 + x#12#9 lower_border_8 1 + x#12#9 moves 1 + x#12#8 inner_area_106 1 + x#12#8 inner_area_116 1 + x#12#8 inner_area_117 1 + x#12#8 inner_area_118 1 + x#12#8 lower_border_7 1 + x#12#8 moves 1 + y#6#3 inner_area_46 -2 + y#6#2 inner_area_45 -2 + y#6#1 left_border_5 -2 + x#8#4 inner_area_58 1 + x#8#4 inner_area_68 1 + x#8#4 inner_area_69 1 + x#8#4 inner_area_70 1 + x#8#4 inner_area_80 1 + x#8#4 moves 1 + x#8#5 inner_area_59 1 + x#8#5 inner_area_69 1 + x#8#5 inner_area_70 1 + x#8#5 inner_area_71 1 + x#8#5 inner_area_81 1 + x#8#5 moves 1 + x#8#6 inner_area_60 1 + x#8#6 inner_area_70 1 + x#8#6 inner_area_71 1 + x#8#6 inner_area_72 1 + x#8#6 inner_area_82 1 + x#8#6 moves 1 + x#8#7 inner_area_61 1 + x#8#7 inner_area_71 1 + x#8#7 inner_area_72 1 + x#8#7 inner_area_73 1 + x#8#7 inner_area_83 1 + x#8#7 moves 1 + x#8#1 inner_area_67 1 + x#8#1 left_border_6 1 + x#8#1 left_border_7 1 + x#8#1 left_border_8 1 + x#8#1 moves 1 + x#8#2 inner_area_56 1 + x#8#2 inner_area_67 1 + x#8#2 inner_area_68 1 + x#8#2 inner_area_78 1 + x#8#2 left_border_7 1 + x#8#2 moves 1 + x#8#3 inner_area_57 1 + x#8#3 inner_area_67 1 + x#8#3 inner_area_68 1 + x#8#3 inner_area_69 1 + x#8#3 inner_area_79 1 + x#8#3 moves 1 + y#10#2 inner_area_89 -2 + y#10#3 inner_area_90 -2 + y#10#1 left_border_9 -2 + x#8#8 inner_area_62 1 + x#8#8 inner_area_72 1 + x#8#8 inner_area_73 1 + x#8#8 inner_area_74 1 + x#8#8 inner_area_84 1 + x#8#8 moves 1 + x#8#9 inner_area_63 1 + x#8#9 inner_area_73 1 + x#8#9 inner_area_74 1 + x#8#9 inner_area_75 1 + x#8#9 inner_area_85 1 + x#8#9 moves 1 + y#10#4 inner_area_91 -2 + y#10#5 inner_area_92 -2 + x#7#7 inner_area_50 1 + x#7#7 inner_area_60 1 + x#7#7 inner_area_61 1 + x#7#7 inner_area_62 1 + x#7#7 inner_area_72 1 + x#7#7 moves 1 + x#7#6 inner_area_49 1 + x#7#6 inner_area_59 1 + x#7#6 inner_area_60 1 + x#7#6 inner_area_61 1 + x#7#6 inner_area_71 1 + x#7#6 moves 1 + x#7#5 inner_area_48 1 + x#7#5 inner_area_58 1 + x#7#5 inner_area_59 1 + x#7#5 inner_area_60 1 + x#7#5 inner_area_70 1 + x#7#5 moves 1 + x#7#4 inner_area_47 1 + x#7#4 inner_area_57 1 + x#7#4 inner_area_58 1 + x#7#4 inner_area_59 1 + x#7#4 inner_area_69 1 + x#7#4 moves 1 + x#7#3 inner_area_46 1 + x#7#3 inner_area_56 1 + x#7#3 inner_area_57 1 + x#7#3 inner_area_58 1 + x#7#3 inner_area_68 1 + x#7#3 moves 1 + x#7#2 inner_area_45 1 + x#7#2 inner_area_56 1 + x#7#2 inner_area_57 1 + x#7#2 inner_area_67 1 + x#7#2 left_border_6 1 + x#7#2 moves 1 + x#7#1 inner_area_56 1 + x#7#1 left_border_5 1 + x#7#1 left_border_6 1 + x#7#1 left_border_7 1 + x#7#1 moves 1 + y#13#2 lower_border_1 -2 + y#13#9 lower_border_8 -2 + y#13#8 lower_border_7 -2 + x#7#9 inner_area_52 1 + x#7#9 inner_area_62 1 + x#7#9 inner_area_63 1 + x#7#9 inner_area_64 1 + x#7#9 inner_area_74 1 + x#7#9 moves 1 + x#7#8 inner_area_51 1 + x#7#8 inner_area_61 1 + x#7#8 inner_area_62 1 + x#7#8 inner_area_63 1 + x#7#8 inner_area_73 1 + x#7#8 moves 1 + x#12#12 inner_area_110 1 + x#12#12 inner_area_120 1 + x#12#12 inner_area_121 1 + x#12#12 lower_border_11 1 + x#12#12 moves 1 + x#12#12 right_border_11 1 + x#12#13 inner_area_121 1 + x#12#13 moves 1 + x#12#13 right_border_10 1 + x#12#13 right_border_11 1 + x#12#13 right_lower_c@a8 1 + x#12#10 inner_area_108 1 + x#12#10 inner_area_118 1 + x#12#10 inner_area_119 1 + x#12#10 inner_area_120 1 + x#12#10 lower_border_9 1 + x#12#10 moves 1 + x#12#11 inner_area_109 1 + x#12#11 inner_area_119 1 + x#12#11 inner_area_120 1 + x#12#11 inner_area_121 1 + x#12#11 lower_border_10 1 + x#12#11 moves 1 + y#12#8 inner_area_117 -2 + y#12#9 inner_area_118 -2 + y#12#4 inner_area_113 -2 + y#12#5 inner_area_114 -2 + y#12#6 inner_area_115 -2 + y#12#7 inner_area_116 -2 + y#12#1 left_border_11 -2 + y#12#2 inner_area_111 -2 + y#12#3 inner_area_112 -2 + y#4#10 inner_area_31 -2 + y#4#11 inner_area_32 -2 + y#4#12 inner_area_33 -2 + y#4#13 right_border_3 -2 + x#6#11 inner_area_43 1 + x#6#11 inner_area_53 1 + x#6#11 inner_area_54 1 + x#6#11 inner_area_55 1 + x#6#11 inner_area_65 1 + x#6#11 moves 1 + x#6#10 inner_area_42 1 + x#6#10 inner_area_52 1 + x#6#10 inner_area_53 1 + x#6#10 inner_area_54 1 + x#6#10 inner_area_64 1 + x#6#10 moves 1 + x#6#13 inner_area_55 1 + x#6#13 moves 1 + x#6#13 right_border_4 1 + x#6#13 right_border_5 1 + x#6#13 right_border_6 1 + x#6#12 inner_area_44 1 + x#6#12 inner_area_54 1 + x#6#12 inner_area_55 1 + x#6#12 inner_area_66 1 + x#6#12 moves 1 + x#6#12 right_border_5 1 + x#6#6 inner_area_38 1 + x#6#6 inner_area_48 1 + x#6#6 inner_area_49 1 + x#6#6 inner_area_50 1 + x#6#6 inner_area_60 1 + x#6#6 moves 1 + x#6#7 inner_area_39 1 + x#6#7 inner_area_49 1 + x#6#7 inner_area_50 1 + x#6#7 inner_area_51 1 + x#6#7 inner_area_61 1 + x#6#7 moves 1 + x#6#4 inner_area_36 1 + x#6#4 inner_area_46 1 + x#6#4 inner_area_47 1 + x#6#4 inner_area_48 1 + x#6#4 inner_area_58 1 + x#6#4 moves 1 + x#6#5 inner_area_37 1 + x#6#5 inner_area_47 1 + x#6#5 inner_area_48 1 + x#6#5 inner_area_49 1 + x#6#5 inner_area_59 1 + x#6#5 moves 1 + x#6#2 inner_area_34 1 + x#6#2 inner_area_45 1 + x#6#2 inner_area_46 1 + x#6#2 inner_area_56 1 + x#6#2 left_border_5 1 + x#6#2 moves 1 + x#6#3 inner_area_35 1 + x#6#3 inner_area_45 1 + x#6#3 inner_area_46 1 + x#6#3 inner_area_47 1 + x#6#3 inner_area_57 1 + x#6#3 moves 1 + x#6#1 inner_area_45 1 + x#6#1 left_border_4 1 + x#6#1 left_border_5 1 + x#6#1 left_border_6 1 + x#6#1 moves 1 + x#6#8 inner_area_40 1 + x#6#8 inner_area_50 1 + x#6#8 inner_area_51 1 + x#6#8 inner_area_52 1 + x#6#8 inner_area_62 1 + x#6#8 moves 1 + x#6#9 inner_area_41 1 + x#6#9 inner_area_51 1 + x#6#9 inner_area_52 1 + x#6#9 inner_area_53 1 + x#6#9 inner_area_63 1 + x#6#9 moves 1 + x#5#1 inner_area_34 1 + x#5#1 left_border_3 1 + x#5#1 left_border_4 1 + x#5#1 left_border_5 1 + x#5#1 moves 1 + x#5#3 inner_area_24 1 + x#5#3 inner_area_34 1 + x#5#3 inner_area_35 1 + x#5#3 inner_area_36 1 + x#5#3 inner_area_46 1 + x#5#3 moves 1 + x#5#2 inner_area_23 1 + x#5#2 inner_area_34 1 + x#5#2 inner_area_35 1 + x#5#2 inner_area_45 1 + x#5#2 left_border_4 1 + x#5#2 moves 1 + x#5#5 inner_area_26 1 + x#5#5 inner_area_36 1 + x#5#5 inner_area_37 1 + x#5#5 inner_area_38 1 + x#5#5 inner_area_48 1 + x#5#5 moves 1 + x#5#4 inner_area_25 1 + x#5#4 inner_area_35 1 + x#5#4 inner_area_36 1 + x#5#4 inner_area_37 1 + x#5#4 inner_area_47 1 + x#5#4 moves 1 + x#5#7 inner_area_28 1 + x#5#7 inner_area_38 1 + x#5#7 inner_area_39 1 + x#5#7 inner_area_40 1 + x#5#7 inner_area_50 1 + x#5#7 moves 1 + x#5#6 inner_area_27 1 + x#5#6 inner_area_37 1 + x#5#6 inner_area_38 1 + x#5#6 inner_area_39 1 + x#5#6 inner_area_49 1 + x#5#6 moves 1 + x#5#9 inner_area_30 1 + x#5#9 inner_area_40 1 + x#5#9 inner_area_41 1 + x#5#9 inner_area_42 1 + x#5#9 inner_area_52 1 + x#5#9 moves 1 + x#5#8 inner_area_29 1 + x#5#8 inner_area_39 1 + x#5#8 inner_area_40 1 + x#5#8 inner_area_41 1 + x#5#8 inner_area_51 1 + x#5#8 moves 1 + y#10#11 inner_area_98 -2 + y#10#10 inner_area_97 -2 + y#10#13 right_border_9 -2 + y#10#12 inner_area_99 -2 + x#4#13 inner_area_33 1 + x#4#13 moves 1 + x#4#13 right_border_2 1 + x#4#13 right_border_3 1 + x#4#13 right_border_4 1 + x#4#12 inner_area_22 1 + x#4#12 inner_area_32 1 + x#4#12 inner_area_33 1 + x#4#12 inner_area_44 1 + x#4#12 moves 1 + x#4#12 right_border_3 1 + x#4#11 inner_area_21 1 + x#4#11 inner_area_31 1 + x#4#11 inner_area_32 1 + x#4#11 inner_area_33 1 + x#4#11 inner_area_43 1 + x#4#11 moves 1 + x#4#10 inner_area_20 1 + x#4#10 inner_area_30 1 + x#4#10 inner_area_31 1 + x#4#10 inner_area_32 1 + x#4#10 inner_area_42 1 + x#4#10 moves 1 + x#3#9 inner_area_18 1 + x#3#9 inner_area_19 1 + x#3#9 inner_area_20 1 + x#3#9 inner_area_30 1 + x#3#9 inner_area_8 1 + x#3#9 moves 1 + x#3#8 inner_area_17 1 + x#3#8 inner_area_18 1 + x#3#8 inner_area_19 1 + x#3#8 inner_area_29 1 + x#3#8 inner_area_7 1 + x#3#8 moves 1 + x#3#3 inner_area_12 1 + x#3#3 inner_area_13 1 + x#3#3 inner_area_14 1 + x#3#3 inner_area_2 1 + x#3#3 inner_area_24 1 + x#3#3 moves 1 + x#3#2 inner_area_1 1 + x#3#2 inner_area_12 1 + x#3#2 inner_area_13 1 + x#3#2 inner_area_23 1 + x#3#2 left_border_2 1 + x#3#2 moves 1 + x#3#1 inner_area_12 1 + x#3#1 left_border_1 1 + x#3#1 left_border_2 1 + x#3#1 left_border_3 1 + x#3#1 moves 1 + x#3#7 inner_area_16 1 + x#3#7 inner_area_17 1 + x#3#7 inner_area_18 1 + x#3#7 inner_area_28 1 + x#3#7 inner_area_6 1 + x#3#7 moves 1 + x#3#6 inner_area_15 1 + x#3#6 inner_area_16 1 + x#3#6 inner_area_17 1 + x#3#6 inner_area_27 1 + x#3#6 inner_area_5 1 + x#3#6 moves 1 + x#3#5 inner_area_14 1 + x#3#5 inner_area_15 1 + x#3#5 inner_area_16 1 + x#3#5 inner_area_26 1 + x#3#5 inner_area_4 1 + x#3#5 moves 1 + x#3#4 inner_area_13 1 + x#3#4 inner_area_14 1 + x#3#4 inner_area_15 1 + x#3#4 inner_area_25 1 + x#3#4 inner_area_3 1 + x#3#4 moves 1 + x#10#9 inner_area_107 1 + x#10#9 inner_area_85 1 + x#10#9 inner_area_95 1 + x#10#9 inner_area_96 1 + x#10#9 inner_area_97 1 + x#10#9 moves 1 + x#10#8 inner_area_106 1 + x#10#8 inner_area_84 1 + x#10#8 inner_area_94 1 + x#10#8 inner_area_95 1 + x#10#8 inner_area_96 1 + x#10#8 moves 1 + x#10#5 inner_area_103 1 + x#10#5 inner_area_81 1 + x#10#5 inner_area_91 1 + x#10#5 inner_area_92 1 + x#10#5 inner_area_93 1 + x#10#5 moves 1 + x#10#4 inner_area_102 1 + x#10#4 inner_area_80 1 + x#10#4 inner_area_90 1 + x#10#4 inner_area_91 1 + x#10#4 inner_area_92 1 + x#10#4 moves 1 + x#10#7 inner_area_105 1 + x#10#7 inner_area_83 1 + x#10#7 inner_area_93 1 + x#10#7 inner_area_94 1 + x#10#7 inner_area_95 1 + x#10#7 moves 1 + x#10#6 inner_area_104 1 + x#10#6 inner_area_82 1 + x#10#6 inner_area_92 1 + x#10#6 inner_area_93 1 + x#10#6 inner_area_94 1 + x#10#6 moves 1 + x#10#1 inner_area_89 1 + x#10#1 left_border_10 1 + x#10#1 left_border_8 1 + x#10#1 left_border_9 1 + x#10#1 moves 1 + x#10#3 inner_area_101 1 + x#10#3 inner_area_79 1 + x#10#3 inner_area_89 1 + x#10#3 inner_area_90 1 + x#10#3 inner_area_91 1 + x#10#3 moves 1 + x#10#2 inner_area_100 1 + x#10#2 inner_area_78 1 + x#10#2 inner_area_89 1 + x#10#2 inner_area_90 1 + x#10#2 left_border_9 1 + x#10#2 moves 1 + y#11#9 inner_area_107 -2 + y#11#8 inner_area_106 -2 + x#9#10 inner_area_75 1 + x#9#10 inner_area_85 1 + x#9#10 inner_area_86 1 + x#9#10 inner_area_87 1 + x#9#10 inner_area_97 1 + x#9#10 moves 1 + x#9#11 inner_area_76 1 + x#9#11 inner_area_86 1 + x#9#11 inner_area_87 1 + x#9#11 inner_area_88 1 + x#9#11 inner_area_98 1 + x#9#11 moves 1 + x#9#12 inner_area_77 1 + x#9#12 inner_area_87 1 + x#9#12 inner_area_88 1 + x#9#12 inner_area_99 1 + x#9#12 moves 1 + x#9#12 right_border_8 1 + x#9#13 inner_area_88 1 + x#9#13 moves 1 + x#9#13 right_border_7 1 + x#9#13 right_border_8 1 + x#9#13 right_border_9 1 + y#11#3 inner_area_101 -2 + y#11#2 inner_area_100 -2 + y#11#1 left_border_10 -2 + y#11#7 inner_area_105 -2 + y#11#6 inner_area_104 -2 + y#11#5 inner_area_103 -2 + y#11#4 inner_area_102 -2 + x#4#8 inner_area_18 1 + x#4#8 inner_area_28 1 + x#4#8 inner_area_29 1 + x#4#8 inner_area_30 1 + x#4#8 inner_area_40 1 + x#4#8 moves 1 + x#4#9 inner_area_19 1 + x#4#9 inner_area_29 1 + x#4#9 inner_area_30 1 + x#4#9 inner_area_31 1 + x#4#9 inner_area_41 1 + x#4#9 moves 1 + x#4#1 inner_area_23 1 + x#4#1 left_border_2 1 + x#4#1 left_border_3 1 + x#4#1 left_border_4 1 + x#4#1 moves 1 + x#4#2 inner_area_12 1 + x#4#2 inner_area_23 1 + x#4#2 inner_area_24 1 + x#4#2 inner_area_34 1 + x#4#2 left_border_3 1 + x#4#2 moves 1 + x#4#3 inner_area_13 1 + x#4#3 inner_area_23 1 + x#4#3 inner_area_24 1 + x#4#3 inner_area_25 1 + x#4#3 inner_area_35 1 + x#4#3 moves 1 + x#4#4 inner_area_14 1 + x#4#4 inner_area_24 1 + x#4#4 inner_area_25 1 + x#4#4 inner_area_26 1 + x#4#4 inner_area_36 1 + x#4#4 moves 1 + x#4#5 inner_area_15 1 + x#4#5 inner_area_25 1 + x#4#5 inner_area_26 1 + x#4#5 inner_area_27 1 + x#4#5 inner_area_37 1 + x#4#5 moves 1 + x#4#6 inner_area_16 1 + x#4#6 inner_area_26 1 + x#4#6 inner_area_27 1 + x#4#6 inner_area_28 1 + x#4#6 inner_area_38 1 + x#4#6 moves 1 + x#4#7 inner_area_17 1 + x#4#7 inner_area_27 1 + x#4#7 inner_area_28 1 + x#4#7 inner_area_29 1 + x#4#7 inner_area_39 1 + x#4#7 moves 1 + y#2#3 inner_area_2 -2 + y#2#2 inner_area_1 -2 + y#8#7 inner_area_72 -2 + y#8#6 inner_area_71 -2 + y#2#7 inner_area_6 -2 + y#2#6 inner_area_5 -2 + y#2#5 inner_area_4 -2 + y#2#4 inner_area_3 -2 + y#2#9 inner_area_8 -2 + y#2#8 inner_area_7 -2 + y#8#9 inner_area_74 -2 + y#8#8 inner_area_73 -2 + x#13#2 inner_area_111 1 + x#13#2 left_lower_co@a6 1 + x#13#2 lower_border_1 1 + x#13#2 lower_border_2 1 + x#13#2 moves 1 + x#13#3 inner_area_112 1 + x#13#3 lower_border_1 1 + x#13#3 lower_border_2 1 + x#13#3 lower_border_3 1 + x#13#3 moves 1 + x#13#1 left_border_11 1 + x#13#1 left_lower_co@a6 1 + x#13#1 lower_border_1 1 + x#13#1 moves 1 + x#13#6 inner_area_115 1 + x#13#6 lower_border_4 1 + x#13#6 lower_border_5 1 + x#13#6 lower_border_6 1 + x#13#6 moves 1 + x#13#7 inner_area_116 1 + x#13#7 lower_border_5 1 + x#13#7 lower_border_6 1 + x#13#7 lower_border_7 1 + x#13#7 moves 1 + x#13#4 inner_area_113 1 + x#13#4 lower_border_2 1 + x#13#4 lower_border_3 1 + x#13#4 lower_border_4 1 + x#13#4 moves 1 + x#13#5 inner_area_114 1 + x#13#5 lower_border_3 1 + x#13#5 lower_border_4 1 + x#13#5 lower_border_5 1 + x#13#5 moves 1 + y#7#6 inner_area_60 -2 + y#7#7 inner_area_61 -2 + x#13#8 inner_area_117 1 + x#13#8 lower_border_6 1 + x#13#8 lower_border_7 1 + x#13#8 lower_border_8 1 + x#13#8 moves 1 + x#13#9 inner_area_118 1 + x#13#9 lower_border_7 1 + x#13#9 lower_border_8 1 + x#13#9 lower_border_9 1 + x#13#9 moves 1 + y#7#2 inner_area_56 -2 + y#7#3 inner_area_57 -2 + y#7#1 left_border_6 -2 + y#4#9 inner_area_30 -2 + y#4#8 inner_area_29 -2 + y#3#11 inner_area_21 -2 + y#3#10 inner_area_20 -2 + y#4#3 inner_area_24 -2 + y#3#12 inner_area_22 -2 + y#4#5 inner_area_26 -2 + y#4#4 inner_area_25 -2 + y#4#7 inner_area_28 -2 + y#4#6 inner_area_27 -2 + x#1#5 inner_area_4 1 + x#1#5 moves 1 + x#1#5 upper_border_3 1 + x#1#5 upper_border_4 1 + x#1#5 upper_border_5 1 + x#1#4 inner_area_3 1 + x#1#4 moves 1 + x#1#4 upper_border_2 1 + x#1#4 upper_border_3 1 + x#1#4 upper_border_4 1 + x#1#7 inner_area_6 1 + x#1#7 moves 1 + x#1#7 upper_border_5 1 + x#1#7 upper_border_6 1 + x#1#7 upper_border_7 1 + x#1#6 inner_area_5 1 + x#1#6 moves 1 + x#1#6 upper_border_4 1 + x#1#6 upper_border_5 1 + x#1#6 upper_border_6 1 + x#1#1 left_border_1 1 + x#1#1 left_upper_co@a5 1 + x#1#1 moves 1 + x#1#1 upper_border_1 1 + x#1#3 inner_area_2 1 + x#1#3 moves 1 + x#1#3 upper_border_1 1 + x#1#3 upper_border_2 1 + x#1#3 upper_border_3 1 + x#1#2 inner_area_1 1 + x#1#2 left_upper_co@a5 1 + x#1#2 moves 1 + x#1#2 upper_border_1 1 + x#1#2 upper_border_2 1 + x#1#9 inner_area_8 1 + x#1#9 moves 1 + x#1#9 upper_border_7 1 + x#1#9 upper_border_8 1 + x#1#9 upper_border_9 1 + x#1#8 inner_area_7 1 + x#1#8 moves 1 + x#1#8 upper_border_6 1 + x#1#8 upper_border_7 1 + x#1#8 upper_border_8 1 + y#7#13 right_border_6 -2 + y#7#12 inner_area_66 -2 + y#5#13 right_border_4 -2 + y#5#12 inner_area_44 -2 + y#5#11 inner_area_43 -2 + y#5#10 inner_area_42 -2 + x#7#12 inner_area_55 1 + x#7#12 inner_area_65 1 + x#7#12 inner_area_66 1 + x#7#12 inner_area_77 1 + x#7#12 moves 1 + x#7#12 right_border_6 1 + x#7#13 inner_area_66 1 + x#7#13 moves 1 + x#7#13 right_border_5 1 + x#7#13 right_border_6 1 + x#7#13 right_border_7 1 + x#7#10 inner_area_53 1 + x#7#10 inner_area_63 1 + x#7#10 inner_area_64 1 + x#7#10 inner_area_65 1 + x#7#10 inner_area_75 1 + x#7#10 moves 1 + x#7#11 inner_area_54 1 + x#7#11 inner_area_64 1 + x#7#11 inner_area_65 1 + x#7#11 inner_area_66 1 + x#7#11 inner_area_76 1 + x#7#11 moves 1 + y#5#1 left_border_4 -2 + y#5#2 inner_area_34 -2 + y#5#3 inner_area_35 -2 + y#5#4 inner_area_36 -2 + y#5#5 inner_area_37 -2 + y#5#6 inner_area_38 -2 + y#5#7 inner_area_39 -2 + y#5#8 inner_area_40 -2 + y#5#9 inner_area_41 -2 + x#3#12 inner_area_11 1 + x#3#12 inner_area_21 1 + x#3#12 inner_area_22 1 + x#3#12 inner_area_33 1 + x#3#12 moves 1 + x#3#12 right_border_2 1 + x#3#13 inner_area_22 1 + x#3#13 moves 1 + x#3#13 right_border_1 1 + x#3#13 right_border_2 1 + x#3#13 right_border_3 1 + x#3#10 inner_area_19 1 + x#3#10 inner_area_20 1 + x#3#10 inner_area_21 1 + x#3#10 inner_area_31 1 + x#3#10 inner_area_9 1 + x#3#10 moves 1 + x#3#11 inner_area_10 1 + x#3#11 inner_area_20 1 + x#3#11 inner_area_21 1 + x#3#11 inner_area_22 1 + x#3#11 inner_area_32 1 + x#3#11 moves 1 + x#10#10 inner_area_108 1 + x#10#10 inner_area_86 1 + x#10#10 inner_area_96 1 + x#10#10 inner_area_97 1 + x#10#10 inner_area_98 1 + x#10#10 moves 1 + x#10#11 inner_area_109 1 + x#10#11 inner_area_87 1 + x#10#11 inner_area_97 1 + x#10#11 inner_area_98 1 + x#10#11 inner_area_99 1 + x#10#11 moves 1 + x#10#12 inner_area_110 1 + x#10#12 inner_area_88 1 + x#10#12 inner_area_98 1 + x#10#12 inner_area_99 1 + x#10#12 moves 1 + x#10#12 right_border_9 1 + x#10#13 inner_area_99 1 + x#10#13 moves 1 + x#10#13 right_border_10 1 + x#10#13 right_border_8 1 + x#10#13 right_border_9 1 + x#11#13 inner_area_110 1 + x#11#13 moves 1 + x#11#13 right_border_10 1 + x#11#13 right_border_11 1 + x#11#13 right_border_9 1 + x#11#12 inner_area_109 1 + x#11#12 inner_area_110 1 + x#11#12 inner_area_121 1 + x#11#12 inner_area_99 1 + x#11#12 moves 1 + x#11#12 right_border_10 1 + x#11#11 inner_area_108 1 + x#11#11 inner_area_109 1 + x#11#11 inner_area_110 1 + x#11#11 inner_area_120 1 + x#11#11 inner_area_98 1 + x#11#11 moves 1 + x#11#10 inner_area_107 1 + x#11#10 inner_area_108 1 + x#11#10 inner_area_109 1 + x#11#10 inner_area_119 1 + x#11#10 inner_area_97 1 + x#11#10 moves 1 + x#2#8 inner_area_18 1 + x#2#8 inner_area_6 1 + x#2#8 inner_area_7 1 + x#2#8 inner_area_8 1 + x#2#8 moves 1 + x#2#8 upper_border_7 1 + x#2#9 inner_area_19 1 + x#2#9 inner_area_7 1 + x#2#9 inner_area_8 1 + x#2#9 inner_area_9 1 + x#2#9 moves 1 + x#2#9 upper_border_8 1 + x#2#2 inner_area_1 1 + x#2#2 inner_area_12 1 + x#2#2 inner_area_2 1 + x#2#2 left_border_1 1 + x#2#2 moves 1 + x#2#2 upper_border_1 1 + x#2#3 inner_area_1 1 + x#2#3 inner_area_13 1 + x#2#3 inner_area_2 1 + x#2#3 inner_area_3 1 + x#2#3 moves 1 + x#2#3 upper_border_2 1 + x#2#1 inner_area_1 1 + x#2#1 left_border_1 1 + x#2#1 left_border_2 1 + x#2#1 left_upper_co@a5 1 + x#2#1 moves 1 + x#2#6 inner_area_16 1 + x#2#6 inner_area_4 1 + x#2#6 inner_area_5 1 + x#2#6 inner_area_6 1 + x#2#6 moves 1 + x#2#6 upper_border_5 1 + x#2#7 inner_area_17 1 + x#2#7 inner_area_5 1 + x#2#7 inner_area_6 1 + x#2#7 inner_area_7 1 + x#2#7 moves 1 + x#2#7 upper_border_6 1 + x#2#4 inner_area_14 1 + x#2#4 inner_area_2 1 + x#2#4 inner_area_3 1 + x#2#4 inner_area_4 1 + x#2#4 moves 1 + x#2#4 upper_border_3 1 + x#2#5 inner_area_15 1 + x#2#5 inner_area_3 1 + x#2#5 inner_area_4 1 + x#2#5 inner_area_5 1 + x#2#5 moves 1 + x#2#5 upper_border_4 1 + y#1#13 right_upper_c@a7 -2 + y#1#12 upper_border_11 -2 + y#1#11 upper_border_10 -2 + y#8#13 right_border_7 -2 + x#8#13 inner_area_77 1 + x#8#13 moves 1 + x#8#13 right_border_6 1 + x#8#13 right_border_7 1 + x#8#13 right_border_8 1 + x#8#12 inner_area_66 1 + x#8#12 inner_area_76 1 + x#8#12 inner_area_77 1 + x#8#12 inner_area_88 1 + x#8#12 moves 1 + x#8#12 right_border_7 1 + x#8#11 inner_area_65 1 + x#8#11 inner_area_75 1 + x#8#11 inner_area_76 1 + x#8#11 inner_area_77 1 + x#8#11 inner_area_87 1 + x#8#11 moves 1 + x#8#10 inner_area_64 1 + x#8#10 inner_area_74 1 + x#8#10 inner_area_75 1 + x#8#10 inner_area_76 1 + x#8#10 inner_area_86 1 + x#8#10 moves 1 + y#9#8 inner_area_84 -2 + y#9#9 inner_area_85 -2 + y#9#4 inner_area_80 -2 + y#9#5 inner_area_81 -2 + y#9#6 inner_area_82 -2 + y#9#7 inner_area_83 -2 + y#1#8 upper_border_7 -2 + y#9#1 left_border_8 -2 + y#9#2 inner_area_78 -2 + y#9#3 inner_area_79 -2 + y#3#2 inner_area_12 -2 + y#3#3 inner_area_13 -2 + y#3#6 inner_area_16 -2 + y#3#7 inner_area_17 -2 + y#3#4 inner_area_14 -2 + y#3#5 inner_area_15 -2 + y#3#8 inner_area_18 -2 + y#3#9 inner_area_19 -2 + y#10#8 inner_area_95 -2 + y#10#9 inner_area_96 -2 + y#10#6 inner_area_93 -2 + y#10#7 inner_area_94 -2 + y#13#5 lower_border_4 -2 + y#13#4 lower_border_3 -2 + y#13#7 lower_border_6 -2 + y#13#6 lower_border_5 -2 + y#13#1 left_lower_co@a6 -2 + y#13#3 lower_border_2 -2 + y#11#12 inner_area_110 -2 + y#11#13 right_border_10 -2 + y#11#10 inner_area_108 -2 + y#11#11 inner_area_109 -2 + y#8#5 inner_area_70 -2 + y#8#4 inner_area_69 -2 + y#2#1 left_border_1 -2 + y#8#1 left_border_7 -2 + y#8#3 inner_area_68 -2 + y#8#2 inner_area_67 -2 + y#7#8 inner_area_62 -2 + y#7#9 inner_area_63 -2 + y#7#4 inner_area_58 -2 + y#7#5 inner_area_59 -2 + y#4#1 left_border_3 -2 + y#3#13 right_border_2 -2 + y#4#2 inner_area_23 -2 + y#7#11 inner_area_65 -2 + y#7#10 inner_area_64 -2 + y#1#1 left_upper_co@a5 -2 + y#6#9 inner_area_52 -2 + y#6#8 inner_area_51 -2 + y#6#5 inner_area_48 -2 + y#6#4 inner_area_47 -2 + MARK0001 'MARKER' 'INTEND' +RHS + rhs left_upper_co@a5 -1 +BOUNDS + BV bound x#11#4 + BV bound x#11#5 + BV bound x#11#6 + BV bound x#11#7 + BV bound x#11#1 + BV bound x#11#2 + BV bound x#11#3 + BV bound x#11#8 + BV bound x#11#9 + BV bound x#2#11 + BV bound x#2#10 + BV bound x#2#13 + BV bound x#2#12 + LI bound y#8#10 0 + PL bound y#8#10 + LI bound y#8#11 0 + PL bound y#8#11 + LI bound y#8#12 0 + PL bound y#8#12 + LI bound y#1#10 0 + PL bound y#1#10 + BV bound x#5#10 + BV bound x#5#11 + BV bound x#5#12 + BV bound x#5#13 + LI bound y#13#10 0 + PL bound y#13#10 + LI bound y#13#11 0 + PL bound y#13#11 + LI bound y#13#12 0 + PL bound y#13#12 + LI bound y#13#13 0 + PL bound y#13#13 + LI bound y#9#13 0 + PL bound y#9#13 + LI bound y#9#12 0 + PL bound y#9#12 + LI bound y#9#11 0 + PL bound y#9#11 + LI bound y#9#10 0 + PL bound y#9#10 + LI bound y#6#12 0 + PL bound y#6#12 + LI bound y#6#13 0 + PL bound y#6#13 + LI bound y#6#10 0 + PL bound y#6#10 + LI bound y#6#11 0 + PL bound y#6#11 + LI bound y#12#13 0 + PL bound y#12#13 + LI bound y#12#12 0 + PL bound y#12#12 + LI bound y#12#11 0 + PL bound y#12#11 + LI bound y#12#10 0 + PL bound y#12#10 + LI bound y#2#12 0 + PL bound y#2#12 + LI bound y#2#13 0 + PL bound y#2#13 + LI bound y#2#10 0 + PL bound y#2#10 + LI bound y#2#11 0 + PL bound y#2#11 + BV bound x#13#11 + BV bound x#13#10 + BV bound x#13#13 + BV bound x#13#12 + BV bound x#1#10 + BV bound x#1#11 + BV bound x#1#12 + BV bound x#1#13 + LI bound y#1#4 0 + PL bound y#1#4 + LI bound y#1#5 0 + PL bound y#1#5 + LI bound y#1#6 0 + PL bound y#1#6 + LI bound y#1#7 0 + PL bound y#1#7 + BV bound x#9#9 + BV bound x#9#8 + LI bound y#1#2 0 + PL bound y#1#2 + LI bound y#1#3 0 + PL bound y#1#3 + BV bound x#9#5 + BV bound x#9#4 + BV bound x#9#7 + BV bound x#9#6 + BV bound x#9#1 + LI bound y#1#9 0 + PL bound y#1#9 + BV bound x#9#3 + BV bound x#9#2 + BV bound x#12#3 + BV bound x#12#2 + BV bound x#12#1 + LI bound y#3#1 0 + PL bound y#3#1 + BV bound x#12#7 + BV bound x#12#6 + BV bound x#12#5 + BV bound x#12#4 + LI bound y#6#7 0 + PL bound y#6#7 + LI bound y#6#6 0 + PL bound y#6#6 + BV bound x#12#9 + BV bound x#12#8 + LI bound y#6#3 0 + PL bound y#6#3 + LI bound y#6#2 0 + PL bound y#6#2 + LI bound y#6#1 0 + PL bound y#6#1 + BV bound x#8#4 + BV bound x#8#5 + BV bound x#8#6 + BV bound x#8#7 + BV bound x#8#1 + BV bound x#8#2 + BV bound x#8#3 + LI bound y#10#2 0 + PL bound y#10#2 + LI bound y#10#3 0 + PL bound y#10#3 + LI bound y#10#1 0 + PL bound y#10#1 + BV bound x#8#8 + BV bound x#8#9 + LI bound y#10#4 0 + PL bound y#10#4 + LI bound y#10#5 0 + PL bound y#10#5 + BV bound x#7#7 + BV bound x#7#6 + BV bound x#7#5 + BV bound x#7#4 + BV bound x#7#3 + BV bound x#7#2 + BV bound x#7#1 + LI bound y#13#2 0 + PL bound y#13#2 + LI bound y#13#9 0 + PL bound y#13#9 + LI bound y#13#8 0 + PL bound y#13#8 + BV bound x#7#9 + BV bound x#7#8 + BV bound x#12#12 + BV bound x#12#13 + BV bound x#12#10 + BV bound x#12#11 + LI bound y#12#8 0 + PL bound y#12#8 + LI bound y#12#9 0 + PL bound y#12#9 + LI bound y#12#4 0 + PL bound y#12#4 + LI bound y#12#5 0 + PL bound y#12#5 + LI bound y#12#6 0 + PL bound y#12#6 + LI bound y#12#7 0 + PL bound y#12#7 + LI bound y#12#1 0 + PL bound y#12#1 + LI bound y#12#2 0 + PL bound y#12#2 + LI bound y#12#3 0 + PL bound y#12#3 + LI bound y#4#10 0 + PL bound y#4#10 + LI bound y#4#11 0 + PL bound y#4#11 + LI bound y#4#12 0 + PL bound y#4#12 + LI bound y#4#13 0 + PL bound y#4#13 + BV bound x#6#11 + BV bound x#6#10 + BV bound x#6#13 + BV bound x#6#12 + BV bound x#6#6 + BV bound x#6#7 + BV bound x#6#4 + BV bound x#6#5 + BV bound x#6#2 + BV bound x#6#3 + BV bound x#6#1 + BV bound x#6#8 + BV bound x#6#9 + BV bound x#5#1 + BV bound x#5#3 + BV bound x#5#2 + BV bound x#5#5 + BV bound x#5#4 + BV bound x#5#7 + BV bound x#5#6 + BV bound x#5#9 + BV bound x#5#8 + LI bound y#10#11 0 + PL bound y#10#11 + LI bound y#10#10 0 + PL bound y#10#10 + LI bound y#10#13 0 + PL bound y#10#13 + LI bound y#10#12 0 + PL bound y#10#12 + BV bound x#4#13 + BV bound x#4#12 + BV bound x#4#11 + BV bound x#4#10 + BV bound x#3#9 + BV bound x#3#8 + BV bound x#3#3 + BV bound x#3#2 + BV bound x#3#1 + BV bound x#3#7 + BV bound x#3#6 + BV bound x#3#5 + BV bound x#3#4 + BV bound x#10#9 + BV bound x#10#8 + BV bound x#10#5 + BV bound x#10#4 + BV bound x#10#7 + BV bound x#10#6 + BV bound x#10#1 + BV bound x#10#3 + BV bound x#10#2 + LI bound y#11#9 0 + PL bound y#11#9 + LI bound y#11#8 0 + PL bound y#11#8 + BV bound x#9#10 + BV bound x#9#11 + BV bound x#9#12 + BV bound x#9#13 + LI bound y#11#3 0 + PL bound y#11#3 + LI bound y#11#2 0 + PL bound y#11#2 + LI bound y#11#1 0 + PL bound y#11#1 + LI bound y#11#7 0 + PL bound y#11#7 + LI bound y#11#6 0 + PL bound y#11#6 + LI bound y#11#5 0 + PL bound y#11#5 + LI bound y#11#4 0 + PL bound y#11#4 + BV bound x#4#8 + BV bound x#4#9 + BV bound x#4#1 + BV bound x#4#2 + BV bound x#4#3 + BV bound x#4#4 + BV bound x#4#5 + BV bound x#4#6 + BV bound x#4#7 + LI bound y#2#3 0 + PL bound y#2#3 + LI bound y#2#2 0 + PL bound y#2#2 + LI bound y#8#7 0 + PL bound y#8#7 + LI bound y#8#6 0 + PL bound y#8#6 + LI bound y#2#7 0 + PL bound y#2#7 + LI bound y#2#6 0 + PL bound y#2#6 + LI bound y#2#5 0 + PL bound y#2#5 + LI bound y#2#4 0 + PL bound y#2#4 + LI bound y#2#9 0 + PL bound y#2#9 + LI bound y#2#8 0 + PL bound y#2#8 + LI bound y#8#9 0 + PL bound y#8#9 + LI bound y#8#8 0 + PL bound y#8#8 + BV bound x#13#2 + BV bound x#13#3 + BV bound x#13#1 + BV bound x#13#6 + BV bound x#13#7 + BV bound x#13#4 + BV bound x#13#5 + LI bound y#7#6 0 + PL bound y#7#6 + LI bound y#7#7 0 + PL bound y#7#7 + BV bound x#13#8 + BV bound x#13#9 + LI bound y#7#2 0 + PL bound y#7#2 + LI bound y#7#3 0 + PL bound y#7#3 + LI bound y#7#1 0 + PL bound y#7#1 + LI bound y#4#9 0 + PL bound y#4#9 + LI bound y#4#8 0 + PL bound y#4#8 + LI bound y#3#11 0 + PL bound y#3#11 + LI bound y#3#10 0 + PL bound y#3#10 + LI bound y#4#3 0 + PL bound y#4#3 + LI bound y#3#12 0 + PL bound y#3#12 + LI bound y#4#5 0 + PL bound y#4#5 + LI bound y#4#4 0 + PL bound y#4#4 + LI bound y#4#7 0 + PL bound y#4#7 + LI bound y#4#6 0 + PL bound y#4#6 + BV bound x#1#5 + BV bound x#1#4 + BV bound x#1#7 + BV bound x#1#6 + BV bound x#1#1 + BV bound x#1#3 + BV bound x#1#2 + BV bound x#1#9 + BV bound x#1#8 + LI bound y#7#13 0 + PL bound y#7#13 + LI bound y#7#12 0 + PL bound y#7#12 + LI bound y#5#13 0 + PL bound y#5#13 + LI bound y#5#12 0 + PL bound y#5#12 + LI bound y#5#11 0 + PL bound y#5#11 + LI bound y#5#10 0 + PL bound y#5#10 + BV bound x#7#12 + BV bound x#7#13 + BV bound x#7#10 + BV bound x#7#11 + LI bound y#5#1 0 + PL bound y#5#1 + LI bound y#5#2 0 + PL bound y#5#2 + LI bound y#5#3 0 + PL bound y#5#3 + LI bound y#5#4 0 + PL bound y#5#4 + LI bound y#5#5 0 + PL bound y#5#5 + LI bound y#5#6 0 + PL bound y#5#6 + LI bound y#5#7 0 + PL bound y#5#7 + LI bound y#5#8 0 + PL bound y#5#8 + LI bound y#5#9 0 + PL bound y#5#9 + BV bound x#3#12 + BV bound x#3#13 + BV bound x#3#10 + BV bound x#3#11 + BV bound x#10#10 + BV bound x#10#11 + BV bound x#10#12 + BV bound x#10#13 + BV bound x#11#13 + BV bound x#11#12 + BV bound x#11#11 + BV bound x#11#10 + BV bound x#2#8 + BV bound x#2#9 + BV bound x#2#2 + BV bound x#2#3 + BV bound x#2#1 + BV bound x#2#6 + BV bound x#2#7 + BV bound x#2#4 + BV bound x#2#5 + LI bound y#1#13 0 + PL bound y#1#13 + LI bound y#1#12 0 + PL bound y#1#12 + LI bound y#1#11 0 + PL bound y#1#11 + LI bound y#8#13 0 + PL bound y#8#13 + BV bound x#8#13 + BV bound x#8#12 + BV bound x#8#11 + BV bound x#8#10 + LI bound y#9#8 0 + PL bound y#9#8 + LI bound y#9#9 0 + PL bound y#9#9 + LI bound y#9#4 0 + PL bound y#9#4 + LI bound y#9#5 0 + PL bound y#9#5 + LI bound y#9#6 0 + PL bound y#9#6 + LI bound y#9#7 0 + PL bound y#9#7 + LI bound y#1#8 0 + PL bound y#1#8 + LI bound y#9#1 0 + PL bound y#9#1 + LI bound y#9#2 0 + PL bound y#9#2 + LI bound y#9#3 0 + PL bound y#9#3 + LI bound y#3#2 0 + PL bound y#3#2 + LI bound y#3#3 0 + PL bound y#3#3 + LI bound y#3#6 0 + PL bound y#3#6 + LI bound y#3#7 0 + PL bound y#3#7 + LI bound y#3#4 0 + PL bound y#3#4 + LI bound y#3#5 0 + PL bound y#3#5 + LI bound y#3#8 0 + PL bound y#3#8 + LI bound y#3#9 0 + PL bound y#3#9 + LI bound y#10#8 0 + PL bound y#10#8 + LI bound y#10#9 0 + PL bound y#10#9 + LI bound y#10#6 0 + PL bound y#10#6 + LI bound y#10#7 0 + PL bound y#10#7 + LI bound y#13#5 0 + PL bound y#13#5 + LI bound y#13#4 0 + PL bound y#13#4 + LI bound y#13#7 0 + PL bound y#13#7 + LI bound y#13#6 0 + PL bound y#13#6 + LI bound y#13#1 0 + PL bound y#13#1 + LI bound y#13#3 0 + PL bound y#13#3 + LI bound y#11#12 0 + PL bound y#11#12 + LI bound y#11#13 0 + PL bound y#11#13 + LI bound y#11#10 0 + PL bound y#11#10 + LI bound y#11#11 0 + PL bound y#11#11 + LI bound y#8#5 0 + PL bound y#8#5 + LI bound y#8#4 0 + PL bound y#8#4 + LI bound y#2#1 0 + PL bound y#2#1 + LI bound y#8#1 0 + PL bound y#8#1 + LI bound y#8#3 0 + PL bound y#8#3 + LI bound y#8#2 0 + PL bound y#8#2 + LI bound y#7#8 0 + PL bound y#7#8 + LI bound y#7#9 0 + PL bound y#7#9 + LI bound y#7#4 0 + PL bound y#7#4 + LI bound y#7#5 0 + PL bound y#7#5 + LI bound y#4#1 0 + PL bound y#4#1 + LI bound y#3#13 0 + PL bound y#3#13 + LI bound y#4#2 0 + PL bound y#4#2 + LI bound y#7#11 0 + PL bound y#7#11 + LI bound y#7#10 0 + PL bound y#7#10 + LI bound y#1#1 0 + PL bound y#1#1 + LI bound y#6#9 0 + PL bound y#6#9 + LI bound y#6#8 0 + PL bound y#6#8 + LI bound y#6#5 0 + PL bound y#6#5 + LI bound y#6#4 0 + PL bound y#6#4 +ENDATA diff --git a/samples/mps/example2-2.mps b/samples/mps/example2-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/example2-2.mps @@ -0,0 +1,23 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + L c1 + L c2 +COLUMNS + x1 c1 -1 + x1 c2 1 + x1 obj -1 + x2 c1 1 + x2 c2 -3 + x2 obj -2 + x3 c1 1 + x3 c2 1 + x3 obj -3 +RHS + rhs c1 20 + rhs c2 30 +BOUNDS + UP bound x1 40 +ENDATA diff --git a/samples/mps/factor35.mps b/samples/mps/factor35.mps new file mode 100644 --- /dev/null +++ b/samples/mps/factor35.mps @@ -0,0 +1,19 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + E row1 +COLUMNS + MARK0000 'MARKER' 'INTORG' + P obj 1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs row1 35 +BOUNDS + LI bound P 2 + UI bound P 7 +QCMATRIX row1 + P Q 0.5 + Q P 0.5 +ENDATA diff --git a/samples/mps/ind1-2.mps b/samples/mps/ind1-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/ind1-2.mps @@ -0,0 +1,28 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + L row2 + L row4 + E row1 + E row3 +COLUMNS + x obj -1 + x row1 1 + x row2 1 + x row4 1 + z row3 1 + z row4 1 + MARK0000 'MARKER' 'INTORG' + y row4 1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs row2 10 + rhs row4 15 +BOUNDS + BV bound y +INDICATORS + IF row1 y 1 + IF row3 y 0 +ENDATA diff --git a/samples/mps/intvar1-2.mps b/samples/mps/intvar1-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/intvar1-2.mps @@ -0,0 +1,32 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + L c1 + L c2 + E c3 +COLUMNS + x1 c1 -1 + x1 c2 1 + x1 obj -1 + x2 c1 1 + x2 c2 -3 + x2 c3 1 + x2 obj -2 + x3 c1 1 + x3 c2 1 + x3 obj -3 + MARK0000 'MARKER' 'INTORG' + x4 c1 10 + x4 c3 -3.5 + x4 obj -1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c1 20 + rhs c2 30 +BOUNDS + LI bound x4 2 + UI bound x4 3 + UP bound x1 40 +ENDATA diff --git a/samples/mps/intvar2-2.mps b/samples/mps/intvar2-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/intvar2-2.mps @@ -0,0 +1,32 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + L c1 + L c2 + E c3 +COLUMNS + x1 c1 -1 + x1 c2 1 + x1 obj -1 + x2 c1 1 + x2 c2 -3 + x2 c3 1 + x2 obj -2 + x3 c1 1 + x3 c2 1 + x3 obj -3 + MARK0000 'MARKER' 'INTORG' + x4 c1 10 + x4 c3 -3.5 + x4 obj -1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c1 20 + rhs c2 30 +BOUNDS + LI bound x4 2 + UI bound x4 3 + UP bound x1 40 +ENDATA diff --git a/samples/mps/quadobj1-2.mps b/samples/mps/quadobj1-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/quadobj1-2.mps @@ -0,0 +1,20 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + G c1 +COLUMNS + a c1 1 + a obj 1 + b c1 1 + b obj 1 +RHS + rhs c1 10 +BOUNDS +QMATRIX + a a 1 + a b 2 + b a 2 + b b 7 +ENDATA diff --git a/samples/mps/quadobj2-2.mps b/samples/mps/quadobj2-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/quadobj2-2.mps @@ -0,0 +1,19 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + G c1 +COLUMNS + a c1 1 + a obj 1 + b c1 1 + b obj 1 +RHS + rhs c1 10 +BOUNDS +QMATRIX + a a 1 + a b 4 + b b 7 +ENDATA diff --git a/samples/mps/ranges-2.mps b/samples/mps/ranges-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/ranges-2.mps @@ -0,0 +1,19 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + G c1 + L c1 +COLUMNS + x1 c1 1 + x1 obj -1 + x2 c1 -3 + x2 obj -2 + x3 c1 1 + x3 obj -3 +RHS + rhs c1 15 + rhs c1 30 +BOUNDS +ENDATA diff --git a/samples/mps/sc-2.mps b/samples/mps/sc-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/sc-2.mps @@ -0,0 +1,15 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + E c1 +COLUMNS + x1 c1 1 + x1 obj -1 +RHS + rhs c1 0.5 +BOUNDS + LO bound x1 0 + SC bound x1 40 +ENDATA diff --git a/samples/mps/sos-2.mps b/samples/mps/sos-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/sos-2.mps @@ -0,0 +1,37 @@ +NAME +OBJSENSE + MIN +ROWS + N obj + L c1 + L c2 + E c3 +COLUMNS + x1 c1 -1 + x1 c2 1 + x1 obj -1 + x2 c1 1 + x2 c2 -3 + x2 c3 1 + x2 obj -2 + x3 c1 1 + x3 c2 1 + x3 obj -3 + MARK0000 'MARKER' 'INTORG' + x4 c1 10 + x4 c3 -3.5 + x4 obj -1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c1 20 + rhs c2 30 +BOUNDS + LI bound x4 2 + UI bound x4 3 + UP bound x1 40 +SOS + S1 set1 + x1 10000 + x2 20000 + x4 40000 +ENDATA diff --git a/samples/mps/test-qcp-2.mps b/samples/mps/test-qcp-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/test-qcp-2.mps @@ -0,0 +1,38 @@ +NAME +OBJSENSE + MAX +ROWS + N obj1 + E c0 + L c1 + L qc0 +COLUMNS + MARK0000 'MARKER' 'INTORG' + x c0 1 + x c1 1 + x obj1 1 + x qc0 1 + y c0 1 + y c1 5 + y obj1 1 + y qc0 1 + z c1 2 + z obj1 1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c0 1 + rhs c1 10 + rhs qc0 5 +BOUNDS + LI bound x 0 + UI bound x 5 + LI bound y 0 + PL bound y + LI bound z 2 + PL bound z +QCMATRIX qc0 + x x 1 + x y -1 + y x -1 + y y 3 +ENDATA diff --git a/samples/mps/test-semiint-gurobi-2.mps b/samples/mps/test-semiint-gurobi-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/test-semiint-gurobi-2.mps @@ -0,0 +1,25 @@ +NAME +OBJSENSE + MIN +ROWS + N OBJ + L c1 + L c2 +COLUMNS + x2 c1 1 + x2 c2 1 + MARK0000 'MARKER' 'INTORG' + x1 c1 -1 + x1 c2 1 + x3 OBJ -2 + x3 c2 1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c1 10 + rhs c2 20 +BOUNDS + LO bound x1 2.1 + SC bound x1 30 + LO bound x3 2 + SC bound x3 3 +ENDATA diff --git a/samples/mps/test-semiint-lpsolve-2.mps b/samples/mps/test-semiint-lpsolve-2.mps new file mode 100644 --- /dev/null +++ b/samples/mps/test-semiint-lpsolve-2.mps @@ -0,0 +1,25 @@ +NAME +OBJSENSE + MIN +ROWS + N OBJ + L c1 + L c2 +COLUMNS + x2 c1 1 + x2 c2 1 + MARK0000 'MARKER' 'INTORG' + x1 c1 -1 + x1 c2 1 + x3 OBJ -2 + x3 c2 1 + MARK0001 'MARKER' 'INTEND' +RHS + rhs c1 10 + rhs c2 20 +BOUNDS + LO bound x1 2.1 + SC bound x1 30 + LO bound x3 2 + SC bound x3 3 +ENDATA diff --git a/samples/programs/htc/htc.hs b/samples/programs/htc/htc.hs new file mode 100644 --- /dev/null +++ b/samples/programs/htc/htc.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Main where + +import Control.Monad +import Data.List +import qualified Data.IntSet as IntSet +import System.Environment +import qualified ToySolver.Combinatorial.HittingSet.Simple as HittingSet + +main :: IO () +main = do + args <- getArgs + case args of + [fname] -> do + s <- readFile fname + let xss = filter (not . IntSet.null) . fmap (IntSet.fromList . fmap read . words) . lines $ s + forM_ (HittingSet.minimalHittingSets xss) $ \ys -> do + putStrLn $ intercalate " " $ map show $ IntSet.toList ys diff --git a/samples/programs/htc/test1.dat b/samples/programs/htc/test1.dat new file mode 100644 --- /dev/null +++ b/samples/programs/htc/test1.dat @@ -0,0 +1,5 @@ +1 +2 3 5 +2 3 6 +2 4 5 +2 4 6 diff --git a/samples/programs/htc/test2.dat b/samples/programs/htc/test2.dat new file mode 100644 --- /dev/null +++ b/samples/programs/htc/test2.dat @@ -0,0 +1,4 @@ +2 4 7 +7 8 +9 +9 10 diff --git a/samples/programs/knapsack/README.md b/samples/programs/knapsack/README.md new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/README.md @@ -0,0 +1,16 @@ + +LICENSE +------- + +The following files are converted from files available on + +and are distributed under the GNU LGPL license. + +* p01.txt +* p02.txt +* p03.txt +* p04.txt +* p05.txt +* p06.txt +* p07.txt +* p08.txt diff --git a/samples/programs/knapsack/knapsack.hs b/samples/programs/knapsack/knapsack.hs new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/knapsack.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Main where + +import Control.Monad +import Data.List +import System.Environment +import System.IO +import Text.Printf +import qualified ToySolver.Combinatorial.Knapsack.BB as Knapsack + +type Value = Integer +type Weight = Integer + +main :: IO () +main = do + args <- getArgs + case args of + [fname] -> do + (items, capa) <- load fname + let (val,_w,sol) = Knapsack.solve [(fromInteger val, fromInteger weight) | (val, weight) <- items] (fromInteger capa) + printf "%d %d\n" (round val :: Integer) (1::Int) + putStrLn $ intersperse ' ' [if b then '1' else '0' | b <- sol] + +load :: FilePath -> IO ([(Value, Weight)], Weight) +load fname = + withFile fname ReadMode $ \h -> do + [nitems, capa] <- liftM (map read . words) $ hGetLine h + items <- replicateM (fromInteger nitems) $ do + [value,weight] <- liftM (map read . words) $ hGetLine h + return (value, weight) + return (items, capa) diff --git a/samples/programs/knapsack/p01.txt b/samples/programs/knapsack/p01.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p01.txt @@ -0,0 +1,11 @@ +10 165 +92 23 +57 31 +49 29 +68 44 +60 53 +43 38 +67 63 +84 85 +87 89 +72 82 diff --git a/samples/programs/knapsack/p02.txt b/samples/programs/knapsack/p02.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p02.txt @@ -0,0 +1,6 @@ +5 26 +24 12 +13 7 +23 11 +15 8 +16 9 diff --git a/samples/programs/knapsack/p03.txt b/samples/programs/knapsack/p03.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p03.txt @@ -0,0 +1,7 @@ +6 190 +50 56 +50 59 +64 80 +46 64 +50 75 + 5 17 diff --git a/samples/programs/knapsack/p04.txt b/samples/programs/knapsack/p04.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p04.txt @@ -0,0 +1,8 @@ +7 50 +70 31 +20 10 +39 20 +37 19 + 7 4 + 5 3 +10 6 diff --git a/samples/programs/knapsack/p05.txt b/samples/programs/knapsack/p05.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p05.txt @@ -0,0 +1,9 @@ +8 104 +350 25 +400 35 +450 45 + 20 5 + 70 25 + 8 3 + 5 2 + 5 2 diff --git a/samples/programs/knapsack/p06.txt b/samples/programs/knapsack/p06.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p06.txt @@ -0,0 +1,8 @@ +7 170 +442 41 +525 50 +511 49 +593 59 +546 55 +564 57 +617 60 diff --git a/samples/programs/knapsack/p07.txt b/samples/programs/knapsack/p07.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p07.txt @@ -0,0 +1,16 @@ +15 750 +135 70 +139 73 +149 77 +150 80 +156 82 +163 87 +173 90 +184 94 +192 98 +201 106 +210 110 +214 113 +221 115 +229 118 +240 120 diff --git a/samples/programs/knapsack/p08.txt b/samples/programs/knapsack/p08.txt new file mode 100644 --- /dev/null +++ b/samples/programs/knapsack/p08.txt @@ -0,0 +1,26 @@ +24 6404180 + 825594 382745 +1677009 799601 +1676628 909247 +1523970 729069 + 943972 467902 + 97426 44328 + 69666 34610 +1296457 698150 +1679693 823460 +1902996 903959 +1844992 853665 +1049289 551830 +1252836 610856 +1319836 670702 + 953277 488960 +2067538 951111 + 675367 323046 + 853655 446298 +1826027 931161 + 65731 31385 + 901489 496951 + 577243 264724 + 466257 224916 + 369261 169684 + diff --git a/samples/programs/nqueens/nqueens.hs b/samples/programs/nqueens/nqueens.hs new file mode 100644 --- /dev/null +++ b/samples/programs/nqueens/nqueens.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Main where + +import Control.Monad +import Data.Array.IArray +import System.Environment +import qualified ToySolver.SAT as SAT +import qualified ToySolver.SAT.Types as SAT + +main :: IO () +main = do + [s] <- getArgs + let n = read s + ans <- solve n + case ans of + Nothing -> putStrLn "NO SOLUTION" + Just m -> do + forM_ [1..n] $ \i -> do + putStrLn [if m ! (i,j) then 'Q' else '.' | j <- [1..n]] + +solve :: Int -> IO (Maybe (Array (Int,Int) Bool)) +solve n = do + solver <- SAT.newSolver + (a :: Array (Int,Int) SAT.Var) <- liftM (array ((1,1),(n,n))) $ forM [(i,j) | i <- [1..n], j <- [1..n]] $ \(i,j) -> do + x <- SAT.newVar solver + return ((i,j),x) + + forM_ [1..n] $ \i -> do + SAT.addExactly solver [a ! (i,j) | j <- [1..n]] 1 + forM_ [1..n] $ \j -> do + SAT.addExactly solver [a ! (i,j) | i <- [1..n]] 1 + + forM_ [1..n] $ \k -> do + SAT.addAtMost solver [a ! (k+o,1+o) | o <- [0..(n-k)]] 1 + forM_ [2..n] $ \k -> do + SAT.addAtMost solver [a ! (1+o,k+o) | o <- [0..(n-k)]] 1 + + forM_ [1..n] $ \k -> do + SAT.addAtMost solver [a ! (k-o,1+o) | o <- [0 .. k-1]] 1 + forM_ [2..n] $ \k -> do + SAT.addAtMost solver [a ! (k+o,n-o) | o <- [0..(n-k)]] 1 + + ret <- SAT.solve solver + if ret then do + m <- SAT.getModel solver + return $ Just $ fmap (SAT.evalLit m) a + else + return Nothing diff --git a/samples/programs/sudoku/sample1.sdk b/samples/programs/sudoku/sample1.sdk new file mode 100644 --- /dev/null +++ b/samples/programs/sudoku/sample1.sdk @@ -0,0 +1,10 @@ +#U http://commons.wikimedia.org/wiki/File:Sudoku-by-L2G-20050714.svg +53..7.... +6..195... +.98....6. +8...6...3 +4..8.3..1 +7...2...6 +.6....28. +...419..5 +....8..79 diff --git a/samples/programs/sudoku/sample2.sdk b/samples/programs/sudoku/sample2.sdk new file mode 100644 --- /dev/null +++ b/samples/programs/sudoku/sample2.sdk @@ -0,0 +1,10 @@ +#U http://gigazine.net/news/20100822_hardest_sudoku/ +..53..... +8......2. +.7..1.5.. +4....53.. +.1..7...6 +..32...8. +.6.5....9 +..4....3. +.....97.. diff --git a/samples/programs/sudoku/sudoku.hs b/samples/programs/sudoku/sudoku.hs new file mode 100644 --- /dev/null +++ b/samples/programs/sudoku/sudoku.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +module Main where + +import Control.Monad +import Data.Array.IArray +import Data.Char +import System.Environment +import System.Exit +import System.IO +import qualified ToySolver.SAT as SAT + +main :: IO () +main = do + args <- getArgs + case args of + [fname] -> do + s <- readFile fname + let b = readBoard $ filter (not . isSpace) $ removeComments s + ans <- solve b + case ans of + Nothing -> hPutStrLn stderr "NO SOLUTION" + Just b2 -> do + hPutStrLn stderr "SOLUTION FOUND" + printAnswer b2 + _ -> do + hPutStrLn stderr "Usage: sudoku input.sdk" + exitFailure + +removeComments :: String -> String +removeComments = unlines . filter p . lines + where + p ('#':_) = False + p _ = True + +readBoard :: String -> Array (Int,Int) (Maybe Int) +readBoard s = array ((1,1),(9,9)) $ + [ (idx, if isDigit c then Just (read [c]) else Nothing) + | (idx, c) <- zip [(i,j) | i <- [1..9], j <- [1..9]] s + ] + +solve :: Array (Int,Int) (Maybe Int) -> IO (Maybe (Array (Int,Int) Int)) +solve board = do + solver <- SAT.newSolver + SAT.setLogger solver (hPutStrLn stderr) + + (vs :: Array (Int,Int,Int) SAT.Var) <- + liftM (array ((1,1,1), (9,9,9))) $ + forM [(i,j,k) | i<-[1..9], j<-[1..9], k<-[1..9]] $ \idx -> do + v <- SAT.newVar solver + return (idx,v) + + forM_ (assocs board) $ \((i,j), m) -> do + case m of + Nothing -> return () + Just k -> SAT.addClause solver [vs ! (i,j,k)] + + -- Every cell contains exactly one digit. + forM_ [1..9] $ \i -> do + forM_ [1..9] $ \j -> do + SAT.addExactly solver [vs ! (i,j,k) | k <- [1..9]] 1 + + forM_ [1..9] $ \k -> do + -- Every row contains exactly one occurence of the digit. + forM_ [1..9] $ \i -> do + SAT.addExactly solver [vs ! (i,j,k) | j <- [1..9]] 1 + -- Every column contains exactly one occurence of the digit. + forM_ [1..9] $ \j -> do + SAT.addExactly solver [vs ! (i,j,k) | i <- [1..9]] 1 + -- Every block contains exactly one occurence of the digit. + forM_ [0..2] $ \bi -> + forM_ [0..2] $ \bj -> + SAT.addExactly solver [vs ! (bi*3 + i', bj*3 + j', k) | i' <- [1..3], j' <- [1..3]] 1 + + ret <- SAT.solve solver + if ret then do + m <- SAT.getModel solver + return $ Just $ array ((1,1),(9,9)) [((i,j),k) | ((i,j,k),v) <- assocs vs, m ! v] + else + return Nothing + +printAnswer :: Array (Int,Int) Int -> IO () +printAnswer b = + forM_ [1..9] $ \i -> + putStrLn $ concat [show (b ! (i,j)) | j <- [1..9]] diff --git a/src/ToySolver/Arith/BoundsInference.hs b/src/ToySolver/Arith/BoundsInference.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/BoundsInference.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.BoundsInference +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- +-- Tightening variable bounds by constraint propagation. +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.BoundsInference + ( BoundsEnv + , inferBounds + , LA.computeInterval + ) where + +import Control.Monad +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.VectorSpace +import Data.Interval + +import ToySolver.Data.ArithRel +import ToySolver.Data.LA (BoundsEnv) +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import ToySolver.Internal.Util (isInteger) + +type C r = (RelOp, LA.Expr r) + +-- | tightening variable bounds by constraint propagation. +inferBounds :: forall r. (RealFrac r) + => LA.BoundsEnv r -- ^ initial bounds + -> [LA.Atom r] -- ^ constraints + -> VarSet -- ^ integral variables + -> Int -- ^ limit of iterations + -> LA.BoundsEnv r +inferBounds bounds constraints ivs limit = loop 0 bounds + where + cs :: VarMap [C r] + cs = IM.fromListWith (++) $ do + ArithRel lhs op rhs <- constraints + let m = LA.coeffMap (lhs ^-^ rhs) + (v,c) <- IM.toList m + guard $ v /= LA.unitVar + let op' = if c < 0 then flipOp op else op + rhs' = (-1/c) *^ LA.fromCoeffMap (IM.delete v m) + return (v, [(op', rhs')]) + + loop :: Int -> LA.BoundsEnv r -> LA.BoundsEnv r + loop !i b = if (limit>=0 && i>=limit) || b==b' then b else loop (i+1) b' + where + b' = refine b + + refine :: LA.BoundsEnv r -> LA.BoundsEnv r + refine b = IM.mapWithKey (\v i -> tighten v $ f b (IM.findWithDefault [] v cs) i) b + + -- tighten bounds of integer variables + tighten :: Var -> Interval r -> Interval r + tighten v x = + if v `IS.notMember` ivs + then x + else tightenToInteger x + +f :: (Real r, Fractional r) => LA.BoundsEnv r -> [C r] -> Interval r -> Interval r +f b cs i = foldr intersection i $ do + (op, rhs) <- cs + let i' = LA.computeInterval b rhs + lb = lowerBound' i' + ub = upperBound' i' + case op of + Eql -> return i' + Le -> return $ interval (NegInf, False) ub + Ge -> return $ interval lb (PosInf, False) + Lt -> return $ interval (NegInf, False) (strict ub) + Gt -> return $ interval (strict ub) (PosInf, False) + NEq -> [] + +strict :: (Extended r, Bool) -> (Extended r, Bool) +strict (x, _) = (x, False) + +-- | tightening intervals by ceiling lower bounds and flooring upper bounds. +tightenToInteger :: forall r. (RealFrac r) => Interval r -> Interval r +tightenToInteger ival = interval lb2 ub2 + where + lb@(x1, in1) = lowerBound' ival + ub@(x2, in2) = upperBound' ival + lb2 = + case x1 of + Finite x -> + ( if isInteger x && not in1 + then Finite (x + 1) + else Finite (fromInteger (ceiling x)) + , True + ) + _ -> lb + ub2 = + case x2 of + Finite x -> + ( if isInteger x && not in2 + then Finite (x - 1) + else Finite (fromInteger (floor x)) + , True + ) + _ -> ub diff --git a/src/ToySolver/Arith/CAD.hs b/src/ToySolver/Arith/CAD.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/CAD.hs @@ -0,0 +1,716 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.CAD +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- +-- References: +-- +-- * Christian Michaux and Adem Ozturk. +-- Quantifier Elimination following Muchnik +-- +-- +-- * Arnab Bhattacharyya. +-- Something you should know about: Quantifier Elimination (Part I) +-- +-- +-- * Arnab Bhattacharyya. +-- Something you should know about: Quantifier Elimination (Part II) +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.CAD + ( + -- * Basic data structures + Point (..) + , Cell (..) + + -- * Projection + , project + , project' + , projectN + , projectN' + + -- * Solving + , solve + , solve' + + -- * Model + , Model + , findSample + , evalCell + , evalPoint + ) where + +import Control.Exception +import Control.Monad.State +import Data.List +import Data.Maybe +import Data.Ord +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Text.Printf +import Text.PrettyPrint.HughesPJClass + +import qualified Data.Interval as I +import Data.Sign (Sign (..)) +import qualified Data.Sign as Sign + +import ToySolver.Data.ArithRel +import ToySolver.Data.AlgebraicNumber.Real (AReal) +import qualified ToySolver.Data.AlgebraicNumber.Real as AReal +import ToySolver.Data.DNF +import ToySolver.Data.Polynomial (Polynomial, UPolynomial, X (..), PrettyVar, PrettyCoeff) +import qualified ToySolver.Data.Polynomial as P +import qualified ToySolver.Data.Polynomial.GroebnerBasis as GB + +import Debug.Trace + +-- --------------------------------------------------------------------------- + +data Point c = NegInf | RootOf (UPolynomial c) Int | PosInf + deriving (Eq, Ord, Show) + +data Cell c + = Point (Point c) + | Interval (Point c) (Point c) + deriving (Eq, Ord, Show) + +showCell :: (Num c, Ord c, PrettyCoeff c) => Cell c -> String +showCell (Point pt) = showPoint pt +showCell (Interval lb ub) = printf "(%s, %s)" (showPoint lb) (showPoint ub) + +showPoint :: (Num c, Ord c, PrettyCoeff c) => Point c -> String +showPoint NegInf = "-inf" +showPoint PosInf = "+inf" +showPoint (RootOf p n) = "rootOf(" ++ prettyShow p ++ ", " ++ show n ++ ")" + +-- --------------------------------------------------------------------------- + +type SignConf c = [(Cell c, Map (UPolynomial c) Sign)] + +emptySignConf :: SignConf c +emptySignConf = + [ (Point NegInf, Map.empty) + , (Interval NegInf PosInf, Map.empty) + , (Point PosInf, Map.empty) + ] + +showSignConf :: forall c. (Num c, Ord c, PrettyCoeff c) => SignConf c -> [String] +showSignConf = f + where + f :: SignConf c -> [String] + f = concatMap $ \(cell, m) -> showCell cell : g m + + g :: Map (UPolynomial c) Sign -> [String] + g m = + [printf " %s: %s" (prettyShow p) (Sign.symbol s) | (p, s) <- Map.toList m] + +normalizeSignConfKey :: Ord v => UPolynomial (Polynomial Rational v) -> UPolynomial (Polynomial Rational v) +normalizeSignConfKey p + | p == 0 = 0 + | otherwise = q + where + c = P.lc P.grevlex $ P.lc P.nat p + q = P.mapCoeff (P.mapCoeff (/ c)) p + +lookupSignConf :: Ord v => UPolynomial (Polynomial Rational v) -> Map (UPolynomial (Polynomial Rational v)) Sign -> Sign +lookupSignConf p m + | p == 0 = Zero + | otherwise = Sign.signOf c `Sign.mult` (m Map.! q) + where + c = P.lc P.grevlex $ P.lc P.nat p + q = P.mapCoeff (P.mapCoeff (/ c)) p + +-- --------------------------------------------------------------------------- + +-- modified reminder +mr + :: forall k. (Ord k, Show k, Num k, PrettyCoeff k) + => UPolynomial k + -> UPolynomial k + -> (k, Integer, UPolynomial k) +mr p q + | n >= m = assert (P.constant (bm^(n-m+1)) * p == q * l + r && m > P.deg r) $ (bm, n-m+1, r) + | otherwise = error "mr p q: not (deg p >= deg q)" + where + x = P.var X + n = P.deg p + m = P.deg q + bm = P.lc P.nat q + (l,r) = f p n + + f :: UPolynomial k -> Integer -> (UPolynomial k, UPolynomial k) + f p n + | n==m = + let l = P.constant an + r = P.constant bm * p - P.constant an * q + in assert (P.constant (bm^(n-m+1)) * p == q*l + r && m > P.deg r) $ (l, r) + | otherwise = + let p' = (P.constant bm * p - P.constant an * x^(n-m) * q) + (l',r) = f p' (n-1) + l = l' + P.constant (an*bm^(n-m)) * x^(n-m) + in assert (n > P.deg p') $ + assert (P.constant (bm^(n-m+1)) * p == q*l + r && m > P.deg r) $ (l, r) + where + an = P.coeff (P.var X `P.mpow` n) p + +test_mr_1 :: (Coeff Int, Integer, UPolynomial (Coeff Int)) +test_mr_1 = mr (P.toUPolynomialOf p 3) (P.toUPolynomialOf q 3) + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + x = P.var 3 + p = a*x^(2::Int) + b*x + c + q = 2*a*x + b + +test_mr_2 :: (Coeff Int, Integer, UPolynomial (Coeff Int)) +test_mr_2 = mr (P.toUPolynomialOf p 3) (P.toUPolynomialOf p 3) + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + x = P.var 3 + p = a*x^(2::Int) + b*x + c + +-- --------------------------------------------------------------------------- + +type Coeff v = Polynomial Rational v + +type M v = StateT (Assumption v) [] + +runM :: M v a -> [(a, Assumption v)] +runM m = runStateT m emptyAssumption + +assume :: (Ord v, Show v, PrettyVar v) => Polynomial Rational v -> [Sign] -> M v () +assume p ss = do + (m,gb) <- get + p <- return $ P.reduce P.grevlex p gb + ss <- return $ Set.fromList ss + ss <- return $ ss `Set.intersection` computeSignSet m p + guard $ not $ Set.null ss + when (P.deg p > 0) $ do + let c = P.lc P.grlex p + (p,ss) <- return $ (P.mapCoeff (/c) p, Set.map (\s -> s `Sign.div` Sign.signOf c) ss) + let ss_orig = Map.findWithDefault (Set.fromList [Neg,Zero,Pos]) p m + ss <- return $ Set.intersection ss ss_orig + guard $ not $ Set.null ss + case propagate (Map.insertWith Set.intersection p ss m, gb) of + Nothing -> mzero + Just a -> put a + +project' + :: forall v. (Ord v, Show v, PrettyVar v) + => [(UPolynomial (Polynomial Rational v), [Sign])] + -> [([(Polynomial Rational v, [Sign])], [Cell (Polynomial Rational v)])] +project' cs = [ (assumption2cond gs, cells) | (cells, gs) <- result ] + where + result :: [([Cell (Polynomial Rational v)], Assumption v)] + result = runM $ do + forM_ cs $ \(p,ss) -> do + when (1 > P.deg p) $ assume (P.coeff P.mone p) ss + conf <- buildSignConf (map fst cs) + -- normalizePoly前に次数が1以上で、normalizePoly結果の次数が0以下の時のための処理が必要なので注意 + cs' <- liftM catMaybes $ forM cs $ \(p,ss) -> do + p' <- normalizePoly p + if (1 > P.deg p') + then assume (P.coeff P.mone p') ss >> return Nothing + else return $ Just (p',ss) + let satCells = [cell | (cell, m) <- conf, cell /= Point NegInf, cell /= Point PosInf, ok cs' m] + guard $ not $ null satCells + return satCells + + ok :: [(UPolynomial (Polynomial Rational v), [Sign])] -> Map (UPolynomial (Polynomial Rational v)) Sign -> Bool + ok cs m = and [checkSign m p ss | (p,ss) <- cs] + where + checkSign m p ss = lookupSignConf p m `elem` ss + +buildSignConf + :: (Ord v, Show v, PrettyVar v) + => [UPolynomial (Polynomial Rational v)] + -> M v (SignConf (Polynomial Rational v)) +buildSignConf ps = do + ps2 <- collectPolynomials ps + -- normalizePoly後の多項式の次数でソートしておく必要があるので注意 + let ts = sortBy (comparing P.deg) ps2 + --trace ("collected polynomials: " ++ prettyShow ts) $ return () + foldM (flip refineSignConf) emptySignConf ts + +collectPolynomials + :: (Ord v, Show v, PrettyVar v) + => [UPolynomial (Polynomial Rational v)] + -> M v [UPolynomial (Polynomial Rational v)] +collectPolynomials ps = go Set.empty =<< f ps + where + f ps = do + ps' <- mapM normalizePoly $ Set.toList $ Set.fromList $ [p | p <- ps, P.deg p > 0] + return $ Set.fromList $ map normalizeSignConfKey $ filter (\p -> P.deg p > 0) ps' + + go result ps | Set.null ps = return $ Set.toList result + go result ps = do + rs <- f [P.deriv p X | p <- Set.toList ps] + rss <- + forM [(p1,p2) | p1 <- Set.toList ps, p2 <- Set.toList ps ++ Set.toList result, p1 /= p2] $ \(p1,p2) -> do + let d = P.deg p1 + e = P.deg p2 + f [r | (_,_,r) <- [mr p1 p2 | d >= e] ++ [mr p2 p1 | e >= d]] + let ps' = Set.unions (rs:rss) + go (result `Set.union` ps) (ps' `Set.difference` result) + +-- ゼロであるような高次の項を消した多項式を返す +normalizePoly + :: forall v. (Ord v, Show v, PrettyVar v) + => UPolynomial (Polynomial Rational v) + -> M v (UPolynomial (Polynomial Rational v)) +normalizePoly p = liftM P.fromTerms $ go $ sortBy (flip (comparing (P.deg . snd))) $ P.terms p + where + go [] = return [] + go xxs@((c,d):xs) = + mplus + (assume c [Pos, Neg] >> return xxs) + (assume c [Zero] >> go xs) + +refineSignConf + :: forall v. (Show v, Ord v, PrettyVar v) + => UPolynomial (Polynomial Rational v) + -> SignConf (Polynomial Rational v) + -> M v (SignConf (Polynomial Rational v)) +refineSignConf p conf = liftM (extendIntervals 0) $ mapM extendPoint conf + where + extendPoint + :: (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) + -> M v (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) + extendPoint (Point pt, m) = do + s <- signAt pt m + return (Point pt, Map.insert p s m) + extendPoint x = return x + + extendIntervals + :: Int + -> [(Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign)] + -> [(Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign)] + extendIntervals !n (pt1@(Point _, m1) : (Interval lb ub, m) : pt2@(Point _, m2) : xs) = + pt1 : ys ++ extendIntervals n2 (pt2 : xs) + where + s1 = lookupSignConf p m1 + s2 = lookupSignConf p m2 + n1 = if s1 == Zero then n+1 else n + root = RootOf p n1 + (ys, n2) + | s1 == s2 = ( [ (Interval lb ub, Map.insert p s1 m) ], n1 ) + | s1 == Zero = ( [ (Interval lb ub, Map.insert p s2 m) ], n1 ) + | s2 == Zero = ( [ (Interval lb ub, Map.insert p s1 m) ], n1 ) + | otherwise = ( [ (Interval lb root, Map.insert p s1 m) + , (Point root, Map.insert p Zero m) + , (Interval root ub, Map.insert p s2 m) + ] + , n1 + 1 + ) + extendIntervals _ xs = xs + + signAt :: Point (Polynomial Rational v) -> Map (UPolynomial (Polynomial Rational v)) Sign -> M v Sign + signAt PosInf _ = signCoeff (P.lc P.nat p) + signAt NegInf _ = do + let (c,mm) = P.lt P.nat p + if even (P.deg mm) + then signCoeff c + else liftM Sign.negate $ signCoeff c + signAt (RootOf q _) m = do + let (bm,k,r) = mr p q + r <- normalizePoly r + s1 <- if P.deg r > 0 + then return $ lookupSignConf r m + else signCoeff $ P.coeff P.mone r + -- 場合分けを出来るだけ避ける + if even k + then return s1 + else do + s2 <- signCoeff bm + return $ s1 `Sign.div` Sign.pow s2 k + + signCoeff :: Polynomial Rational v -> M v Sign + signCoeff c = + msum [ assume c [s] >> return s + | s <- [Neg, Zero, Pos] + ] + +-- --------------------------------------------------------------------------- + +type Assumption v = (Map (Polynomial Rational v) (Set Sign), [Polynomial Rational v]) + +emptyAssumption :: Assumption v +emptyAssumption = (Map.empty, []) + +propagate :: Ord v => Assumption v -> Maybe (Assumption v) +propagate = go + where + go a = do + a' <- f a + if a == a' + then return a + else go a' + f a = liftM dropConstants $ propagateSign =<< propagateEq a + +propagateEq :: forall v. Ord v => Assumption v -> Maybe (Assumption v) +propagateEq (m, gb) + | any (\(p,ss) -> Set.singleton Zero == ss) (Map.toList m) = do + (m', gb') <- f (m, gb) + propagateEq (m', gb') + | otherwise = + return (m, gb) + where + f :: Assumption v -> Maybe (Assumption v) + f (m, gb) = + case Map.partition (Set.singleton Zero ==) m of + (m0, m) -> do + let gb' = GB.basis P.grevlex (Map.keys m0 ++ gb) + m' = Map.fromListWith Set.intersection $ do + (p,ss) <- Map.toList m + let p' = P.reduce P.grevlex p gb' + c = P.lc P.grlex p' + (p'',ss') + | c == 0 = (p', ss) + | otherwise = (P.mapCoeff (/c) p', Set.map (\s -> s `Sign.div` Sign.signOf c) ss) + return (p'', ss') + return $ (m', gb') + +propagateSign :: Ord v => Assumption v -> Maybe (Assumption v) +propagateSign (m, gb) = go (m, gb) + where + go a@(m, gb) + | not (isOkay a) = Nothing + | m == m' = Just (m, gb) + | otherwise = go (m', gb) + where + m' = Map.mapWithKey (\p ss -> Set.intersection ss (computeSignSet m p)) m + +isOkay :: Ord v => Assumption v -> Bool +isOkay (m, gb) = + and [not (Set.null ss) | (_,ss) <- Map.toList m] && + and [Set.member Zero (computeSignSet m p) | p <- gb] + +dropConstants :: Ord v => Assumption v -> Assumption v +dropConstants (m, gb) = (Map.filterWithKey (\p _ -> P.deg p > 0) m, gb) + +assumption2cond :: Ord v => Assumption v -> [(Polynomial Rational v, [Sign])] +assumption2cond (m, gb) = [(p, Set.toList ss) | (p, ss) <- Map.toList m] ++ [(p, [Zero]) | p <- gb] + +-- --------------------------------------------------------------------------- + +computeSignSet :: Ord v => Map (Polynomial Rational v) (Set Sign) -> Polynomial Rational v -> Set Sign +computeSignSet m p = P.eval env (P.mapCoeff fromRational p) + where + env v = + case Map.lookup (P.var v) m of + Just ss -> ss + Nothing -> Set.fromList [Neg,Zero,Pos] + +-- --------------------------------------------------------------------------- + +type Model v = Map v AReal + +findSample :: Ord v => Model v -> Cell (Polynomial Rational v) -> Maybe AReal +findSample m cell = + case evalCell m cell of + Point (RootOf p n) -> + Just $ AReal.realRoots p !! n + Interval lb ub -> + case I.simplestRationalWithin (f lb I.<..< f ub) of + Nothing -> error $ "ToySolver.CAD.findSample: should not happen" + Just r -> Just $ fromRational r + where + f :: Point Rational -> I.Extended AReal + f NegInf = I.NegInf + f PosInf = I.PosInf + f (RootOf p n) = I.Finite (AReal.realRoots p !! n) + +evalCell :: Ord v => Model v -> Cell (Polynomial Rational v) -> Cell Rational +evalCell m (Point pt) = Point $ evalPoint m pt +evalCell m (Interval pt1 pt2) = Interval (evalPoint m pt1) (evalPoint m pt2) + +evalPoint :: Ord v => Model v -> Point (Polynomial Rational v) -> Point Rational +evalPoint _ NegInf = NegInf +evalPoint _ PosInf = PosInf +evalPoint m (RootOf p n) = RootOf (AReal.minimalPolynomial a) (AReal.rootIndex a) + where + a = AReal.realRootsEx (P.mapCoeff (P.eval (m Map.!) . P.mapCoeff fromRational) p) !! n + +-- --------------------------------------------------------------------------- + +project + :: (Ord v, Show v, PrettyVar v) + => v + -> [ArithRel (Polynomial Rational v)] + -> [([ArithRel (Polynomial Rational v)], Model v -> Model v)] +project v cs = projectN (Set.singleton v) cs + +projectN + :: (Ord v, Show v, PrettyVar v) + => Set v + -> [ArithRel (Polynomial Rational v)] + -> [([ArithRel (Polynomial Rational v)], Model v -> Model v)] +projectN vs cs = do + (cs', mt) <- projectN' vs (map f cs) + return (map g cs', mt) + where + f (ArithRel lhs op rhs) = (lhs - rhs, h op) + where + h Le = [Zero, Neg] + h Ge = [Zero, Pos] + h Lt = [Neg] + h Gt = [Pos] + h Eql = [Zero] + h NEq = [Pos,Neg] + g (p,ss) = (ArithRel p op 0) + where + ss' = Set.fromList ss + op + | ss' == Set.fromList [Zero, Neg] = Le + | ss' == Set.fromList [Zero, Pos] = Ge + | ss' == Set.fromList [Neg] = Lt + | ss' == Set.fromList [Pos] = Gt + | ss' == Set.fromList [Zero] = Eql + | ss' == Set.fromList [Pos,Neg] = NEq + | otherwise = error "should not happen" + +projectN' + :: (Ord v, Show v, PrettyVar v) + => Set v + -> [(Polynomial Rational v, [Sign])] + -> [([(Polynomial Rational v, [Sign])], Model v -> Model v)] +projectN' vs = loop (Set.toList vs) + where + loop [] cs = return (cs, id) + loop (v:vs) cs = do + (cs2, cell:_) <- project' [(P.toUPolynomialOf p v, ss) | (p, ss) <- cs] + let mt1 m = + let Just val = findSample m cell + in seq val $ Map.insert v val m + (cs3, mt2) <- loop vs cs2 + return (cs3, mt1 . mt2) + +-- --------------------------------------------------------------------------- + +solve + :: forall v. (Ord v, Show v, PrettyVar v) + => Set v + -> [(ArithRel (Polynomial Rational v))] + -> Maybe (Model v) +solve vs cs0 = solve' vs (map f cs0) + where + f (ArithRel lhs op rhs) = (lhs - rhs, g op) + g Le = [Zero, Neg] + g Ge = [Zero, Pos] + g Lt = [Neg] + g Gt = [Pos] + g Eql = [Zero] + g NEq = [Pos,Neg] + +solve' + :: forall v. (Ord v, Show v, PrettyVar v) + => Set v + -> [(Polynomial Rational v, [Sign])] + -> Maybe (Model v) +solve' vs cs0 = listToMaybe $ do + (cs,mt) <- projectN' vs cs0 + let m = Map.empty + guard $ and [Sign.signOf v `elem` ss | (p,ss) <- cs, let v = P.eval (m Map.!) p] + return $ mt m + +-- --------------------------------------------------------------------------- + +showDNF :: (Ord v, Show v, PrettyVar v) => DNF (Polynomial Rational v, [Sign]) -> String +showDNF (DNF xss) = intercalate " | " [showConj xs | xs <- xss] + where + showConj xs = "(" ++ intercalate " & " [f p ss | (p,ss) <- xs] ++ ")" + f p ss = prettyShow p ++ g ss + g [Zero] = " = 0" + g [Pos] = " > 0" + g [Neg] = " < 0" + g xs + | Set.fromList xs == Set.fromList [Pos,Neg] = "/= 0" + | Set.fromList xs == Set.fromList [Zero,Pos] = ">= 0" + | Set.fromList xs == Set.fromList [Zero,Neg] = "<= 0" + | otherwise = error "showDNF: should not happen" + +dumpProjection + :: (Ord v, Show v, PrettyVar v) + => [([(Polynomial Rational v, [Sign])], [Cell (Polynomial Rational v)])] + -> IO () +dumpProjection xs = + forM_ xs $ \(gs, cells) -> do + putStrLn "============" + forM_ gs $ \(p, ss) -> do + putStrLn $ f p ss + putStrLn " =>" + forM_ cells $ \cell -> do + putStrLn $ showCell cell + where + f p ss = prettyShow p ++ g ss + g [Zero] = " = 0" + g [Pos] = " > 0" + g [Neg] = " < 0" + g xs + | Set.fromList xs == Set.fromList [Pos,Neg] = "/= 0" + | Set.fromList xs == Set.fromList [Zero,Pos] = ">= 0" + | Set.fromList xs == Set.fromList [Zero,Neg] = "<= 0" + | otherwise = error "showDNF: should not happen" + +dumpSignConf + :: forall v. + (Ord v, PrettyVar v, Show v) + => [(SignConf (Polynomial Rational v), Assumption v)] + -> IO () +dumpSignConf x = + forM_ x $ \(conf, as) -> do + putStrLn "============" + mapM_ putStrLn $ showSignConf conf + forM_ (assumption2cond as) $ \(p, ss) -> + printf "%s %s\n" (prettyShow p) (show ss) + +-- --------------------------------------------------------------------------- + +test1a :: IO () +test1a = mapM_ putStrLn $ showSignConf conf + where + x = P.var X + ps :: [UPolynomial (Polynomial Rational Int)] + ps = [x + 1, -2*x + 3, x] + [(conf, _)] = runM $ buildSignConf ps + +test1b :: Bool +test1b = isJust $ solve vs cs + where + x = P.var X + vs = Set.singleton X + cs = [x + 1 .>. 0, -2*x + 3 .>. 0, x .>. 0] + +test1c :: Bool +test1c = isJust $ do + m <- solve' (Set.singleton X) cs + guard $ and $ do + (p, ss) <- cs + let val = P.eval (m Map.!) (P.mapCoeff fromRational p) + return $ Sign.signOf val `elem` ss + where + x = P.var X + cs = [(x + 1, [Pos]), (-2*x + 3, [Pos]), (x, [Pos])] + +test2a :: IO () +test2a = mapM_ putStrLn $ showSignConf conf + where + x = P.var X + ps :: [UPolynomial (Polynomial Rational Int)] + ps = [x^(2::Int)] + [(conf, _)] = runM $ buildSignConf ps + +test2b :: Bool +test2b = isNothing $ solve vs cs + where + x = P.var X + vs = Set.singleton X + cs = [x^(2::Int) .<. 0] + +test = and [test1b, test1c, test2b] + +test_project :: DNF (Polynomial Rational Int, [Sign]) +test_project = DNF $ map fst $ project' [(p', [Zero])] + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + x = P.var 3 + p :: Polynomial Rational Int + p = a*x^(2::Int) + b*x + c + p' = P.toUPolynomialOf p 3 + +test_project_print :: IO () +test_project_print = putStrLn $ showDNF $ test_project + +test_project_2 = project' [(p, [Zero]), (x, [Pos])] + where + x = P.var X + p :: UPolynomial (Polynomial Rational Int) + p = x^(2::Int) + 4*x - 10 + +test_project_3_print = dumpProjection $ project' [(P.toUPolynomialOf p 0, [Neg])] + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + p :: Polynomial Rational Int + p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1 + +test_solve = solve vs [p .<. 0] + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + vs = Set.fromList [0,1,2] + p :: Polynomial Rational Int + p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1 + +test_collectPolynomials + :: [( [UPolynomial (Polynomial Rational Int)] + , Assumption Int + )] +test_collectPolynomials = runM $ collectPolynomials [p'] + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + x = P.var 3 + p :: Polynomial Rational Int + p = a*x^(2::Int) + b*x + c + p' = P.toUPolynomialOf p 3 + +test_collectPolynomials_print :: IO () +test_collectPolynomials_print = do + forM_ test_collectPolynomials $ \(ps,g) -> do + putStrLn "============" + mapM_ (putStrLn . prettyShow) ps + forM_ (assumption2cond g) $ \(p, ss) -> + printf "%s %s\n" (prettyShow p) (show ss) + +test_buildSignConf :: [(SignConf (Polynomial Rational Int), Assumption Int)] +test_buildSignConf = runM $ buildSignConf [P.toUPolynomialOf p 3] + where + a = P.var 0 + b = P.var 1 + c = P.var 2 + x = P.var 3 + p :: Polynomial Rational Int + p = a*x^(2::Int) + b*x + c + +test_buildSignConf_print :: IO () +test_buildSignConf_print = dumpSignConf test_buildSignConf + +test_buildSignConf_2 :: [(SignConf (Polynomial Rational Int), Assumption Int)] +test_buildSignConf_2 = runM $ buildSignConf [P.toUPolynomialOf p 0 | p <- ps] + where + x = P.var 0 + ps :: [Polynomial Rational Int] + ps = [x + 1, -2*x + 3, x] + +test_buildSignConf_2_print :: IO () +test_buildSignConf_2_print = dumpSignConf test_buildSignConf_2 + +test_buildSignConf_3 :: [(SignConf (Polynomial Rational Int), Assumption Int)] +test_buildSignConf_3 = runM $ buildSignConf [P.toUPolynomialOf p 0 | p <- ps] + where + x = P.var 0 + ps :: [Polynomial Rational Int] + ps = [x, 2*x] + +test_buildSignConf_3_print :: IO () +test_buildSignConf_3_print = dumpSignConf test_buildSignConf_3 + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/ContiTraverso.hs b/src/ToySolver/Arith/ContiTraverso.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/ContiTraverso.hs @@ -0,0 +1,125 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.ContiTraverso +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- References: +-- +-- * P. Conti and C. Traverso, "Buchberger algorithm and integer programming," +-- Applied Algebra, Algebraic Algorithms and Error-Correcting Codes, +-- Lecture Notes in Computer Science Volume 539, 1991, pp 130-139 +-- +-- +-- +-- * IKEGAMI Daisuke, "数列と多項式の愛しい関係," 2011, +-- +-- +-- * 伊藤雅史, , 平林 隆一, "整数計画問題のための b-Gröbner 基底変換アルゴリズム," +-- +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.ContiTraverso + ( solve + , solve' + ) where + +import Data.Default.Class +import Data.Function +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import Data.List +import Data.Monoid +import Data.Ratio +import Data.VectorSpace + +import Data.OptDir + +import ToySolver.Data.ArithRel +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Polynomial (Polynomial, UPolynomial, Monomial, MonomialOrder) +import qualified ToySolver.Data.Polynomial as P +import ToySolver.Data.Polynomial.GroebnerBasis as GB +import ToySolver.Data.Var +import qualified ToySolver.Arith.LPUtil as LPUtil + +solve :: MonomialOrder Var -> VarSet -> OptDir -> LA.Expr Rational -> [LA.Atom Rational] -> Maybe (Model Integer) +solve cmp vs dir obj cs = do + m <- solve' cmp vs obj3 cs3 + return . IM.map round . mt . IM.map fromInteger $ m + where + ((obj2,cs2), mt) = LPUtil.toStandardForm (if dir == OptMin then obj else negateV obj, cs) + obj3 = LA.mapCoeff g obj2 + where + g = round . (c*) + c = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms obj] + cs3 = map f cs2 + f (lhs,rhs) = (LA.mapCoeff g lhs, g rhs) + where + g = round . (c*) + c = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms lhs] + +solve' :: MonomialOrder Var -> VarSet -> LA.Expr Integer -> [(LA.Expr Integer, Integer)] -> Maybe (Model Integer) +solve' cmp vs' obj cs + | or [c < 0 | (c,x) <- LA.terms obj, x /= LA.unitVar] = error "all coefficient of cost function should be non-negative" + | otherwise = + if IM.keysSet (IM.filter (/= 0) m) `IS.isSubsetOf` vs' + then Just $ IM.filterWithKey (\y _ -> y `IS.member` vs') m + else Nothing + + where + vs :: [Var] + vs = IS.toList vs' + + v2 :: Var + v2 = if IS.null vs' then 0 else IS.findMax vs' + 1 + + vs2 :: [Var] + vs2 = [v2 .. v2 + length cs - 1] + + vs2' :: IS.IntSet + vs2' = IS.fromList vs2 + + t :: Var + t = v2 + length cs + + cmp2 :: MonomialOrder Var + cmp2 = elimOrdering (IS.fromList vs2) `mappend` elimOrdering (IS.singleton t) `mappend` costOrdering obj `mappend` cmp + + gb :: [Polynomial Rational Var] + gb = GB.basis' def cmp2 (product (map P.var (t:vs2)) - 1 : phi) + where + phi = do + xj <- vs + let aj = [(yi, aij) | (yi,(ai,_)) <- zip vs2 cs, let aij = LA.coeff xj ai] + return $ product [P.var yi ^ aij | (yi, aij) <- aj, aij > 0] + - product [P.var yi ^ (-aij) | (yi, aij) <- aj, aij < 0] * P.var xj + + yb = product [P.var yi ^ bi | ((_,bi),yi) <- zip cs vs2] + + [(_,z)] = P.terms (P.reduce cmp2 yb gb) + + m = mkModel (vs++vs2++[t]) z + +mkModel :: [Var] -> Monomial Var -> Model Integer +mkModel vs xs = IM.fromDistinctAscList (Map.toAscList (P.mindicesMap xs)) `IM.union` IM.fromList [(x, 0) | x <- vs] +-- IM.union is left-biased + +costOrdering :: LA.Expr Integer -> MonomialOrder Var +costOrdering obj = compare `on` f + where + vs = vars obj + f xs = LA.evalExpr (mkModel (IS.toList vs) xs) obj + +elimOrdering :: IS.IntSet -> MonomialOrder Var +elimOrdering xs = compare `on` f + where + f ys = not $ IS.null $ xs `IS.intersection` ys' + where + ys' = IS.fromDistinctAscList [y | (y,_) <- Map.toAscList $ P.mindicesMap ys] diff --git a/src/ToySolver/Arith/Cooper.hs b/src/ToySolver/Arith/Cooper.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/Cooper.hs @@ -0,0 +1,53 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.Cooper +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (FlexibleInstances) +-- +-- Naive implementation of Cooper's algorithm +-- +-- Reference: +-- +-- * +-- +-- * +-- +-- See also: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.Cooper + ( + -- * Language of presburger arithmetics + ExprZ + , Lit (..) + , QFFormula + , fromLAAtom + , (.|.) + , evalQFFormula + , Model + + -- * Projection + , project + , projectN + , projectCases + , projectCasesN + + -- * Quantifier elimination + , eliminateQuantifiers + + -- * Constraint solving + , solve + , solveQFFormula + , solveFormula + , solveQFLIRAConj + ) where + +import ToySolver.Arith.Cooper.Base +import ToySolver.Arith.Cooper.FOL diff --git a/src/ToySolver/Arith/Cooper/Base.hs b/src/ToySolver/Arith/Cooper/Base.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/Cooper/Base.hs @@ -0,0 +1,441 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.Cooper.Base +-- Copyright : (c) Masahiro Sakai 2011-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances) +-- +-- Naive implementation of Cooper's algorithm +-- +-- Reference: +-- +-- * +-- +-- * +-- +-- See also: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.Cooper.Base + ( + -- * Language of presburger arithmetics + ExprZ + , Lit (..) + , evalLit + , QFFormula + , fromLAAtom + , (.|.) + , evalQFFormula + , Model + + -- * Projection + , project + , projectN + , projectCases + , projectCasesN + + -- * Constraint solving + , solve + , solveQFFormula + , solveQFLIRAConj + ) where + +import Control.Monad +import qualified Data.Foldable as Foldable +import Data.List +import Data.Maybe +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Monoid +import Data.Ratio +import Data.Set (Set) +import qualified Data.Set as Set +import Data.VectorSpace hiding (project) + +import ToySolver.Data.ArithRel +import ToySolver.Data.Boolean +import ToySolver.Data.BoolExpr (BoolExpr (..)) +import qualified ToySolver.Data.BoolExpr as BoolExpr +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import qualified ToySolver.Arith.FourierMotzkin as FM + +-- --------------------------------------------------------------------------- + +-- | Linear arithmetic expression over integers. +type ExprZ = LA.Expr Integer + +fromLAAtom :: LA.Atom Rational -> QFFormula +fromLAAtom (ArithRel a op b) = arithRel op a' b' + where + (e1,c1) = toRat a + (e2,c2) = toRat b + a' = c2 *^ e1 + b' = c1 *^ e2 + +-- | (t,c) represents t/c, and c must be >0. +type Rat = (ExprZ, Integer) + +toRat :: LA.Expr Rational -> Rat +toRat e = seq m $ (LA.mapCoeff f e, m) + where + f x = numerator (fromInteger m * x) + m = foldl' lcm 1 [denominator c | (c,_) <- LA.terms e] + +leZ, ltZ, geZ, gtZ :: ExprZ -> ExprZ -> Lit +leZ e1 e2 = e1 `ltZ` (e2 ^+^ LA.constant 1) +ltZ e1 e2 = IsPos $ (e2 ^-^ e1) +geZ = flip leZ +gtZ = flip ltZ + +eqZ :: ExprZ -> ExprZ -> QFFormula +eqZ e1 e2 = Atom (e1 `leZ` e2) .&&. Atom (e1 `geZ` e2) + +-- | Literals of Presburger arithmetic. +data Lit + = IsPos ExprZ + -- ^ @IsPos e@ means @e > 0@ + | Divisible Bool Integer ExprZ + -- ^ + -- * @Divisible True d e@ means @e@ can be divided by @d@ (i.e. @d | e@) + -- * @Divisible False d e@ means @e@ can not be divided by @d@ (i.e. @¬(d | e)@) + deriving (Show, Eq, Ord) + +instance Variables Lit where + vars (IsPos t) = vars t + vars (Divisible _ _ t) = vars t + +instance Complement Lit where + notB (IsPos e) = e `leZ` LA.constant 0 + notB (Divisible b c e) = Divisible (not b) c e + +-- | Quantifier-free formula of Presburger arithmetic. +type QFFormula = BoolExpr Lit + +instance IsArithRel (LA.Expr Integer) QFFormula where + arithRel op lhs rhs = + case op of + Le -> Atom $ leZ lhs rhs + Ge -> Atom $ geZ lhs rhs + Lt -> Atom $ ltZ lhs rhs + Gt -> Atom $ gtZ lhs rhs + Eql -> eqZ lhs rhs + NEq -> notB $ arithRel Eql lhs rhs + +-- | @d | e@ means @e@ can be divided by @d@. +(.|.) :: Integer -> ExprZ -> QFFormula +n .|. e = Atom $ Divisible True n e + +subst1 :: Var -> ExprZ -> QFFormula -> QFFormula +subst1 x e = fmap f + where + f (Divisible b c e1) = Divisible b c $ LA.applySubst1 x e e1 + f (IsPos e1) = IsPos $ LA.applySubst1 x e e1 + +simplify :: QFFormula -> QFFormula +simplify = BoolExpr.simplify . BoolExpr.fold simplifyLit + +simplifyLit :: Lit -> QFFormula +simplifyLit (IsPos e) = + case LA.asConst e of + Just c -> if c > 0 then true else false + Nothing -> + -- e > 0 <=> e - 1 >= 0 + -- <=> LA.mapCoeff (`div` d) (e - 1) >= 0 + -- <=> LA.mapCoeff (`div` d) (e - 1) + 1 > 0 + Atom $ IsPos $ LA.mapCoeff (`div` d) e1 ^+^ LA.constant 1 + where + e1 = e ^-^ LA.constant 1 + d = if null cs then 1 else abs $ foldl1' gcd cs + cs = [c | (c,x) <- LA.terms e1, x /= LA.unitVar] +simplifyLit lit@(Divisible b c e) + | LA.coeff LA.unitVar e2 `mod` d /= 0 = if b then false else true + | c' == 1 = if b then true else false + | d == 1 = Atom lit + | otherwise = Atom $ Divisible b c' e' + where + e2 = LA.mapCoeff (`mod` c) e + d = abs $ foldl' gcd c [c2 | (c2,x) <- LA.terms e2, x /= LA.unitVar] + c' = c `checkedDiv` d + e' = LA.mapCoeff (`checkedDiv` d) e2 + +-- | @'evalQFFormula' M φ@ returns whether @M ⊧_LIA φ@ or not. +evalQFFormula :: Model Integer -> QFFormula -> Bool +evalQFFormula m = BoolExpr.fold (evalLit m) + +evalLit :: Model Integer -> Lit -> Bool +evalLit m (IsPos e) = LA.evalExpr m e > 0 +evalLit m (Divisible True n e) = LA.evalExpr m e `mod` n == 0 +evalLit m (Divisible False n e) = LA.evalExpr m e `mod` n /= 0 + +-- --------------------------------------------------------------------------- + +data Witness = WCase1 Integer ExprZ | WCase2 Integer Integer Integer (Set ExprZ) + deriving (Show) + +evalWitness :: Model Integer -> Witness -> Integer +evalWitness model (WCase1 c e) = LA.evalExpr model e `checkedDiv` c +evalWitness model (WCase2 c j delta us) + | Set.null us' = j `checkedDiv` c + | otherwise = (j + (((u - delta - 1) `div` delta) * delta)) `checkedDiv` c + where + us' = Set.map (LA.evalExpr model) us + u = Set.findMin us' + +-- --------------------------------------------------------------------------- + +{-| @'project' x φ@ returns @(ψ, lift)@ such that: + +* @⊢_LIA ∀y1, …, yn. (∃x. φ) ↔ ψ@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LIA ψ@ then @lift M ⊧_LIA φ@. +-} +project :: Var -> QFFormula -> (QFFormula, Model Integer -> Model Integer) +project x formula = (formula', mt) + where + xs = projectCases x formula + formula' = orB' [phi | (phi,_) <- xs] + mt m = head $ do + (phi, mt') <- xs + guard $ evalQFFormula m phi + return $ mt' m + orB' = orB . concatMap f + where + f (Or xs) = concatMap f xs + f x = [x] + +{-| @'projectN' {x1,…,xm} φ@ returns @(ψ, lift)@ such that: + +* @⊢_LIA ∀y1, …, yn. (∃x1, …, xm. φ) ↔ ψ@ where @{y1, …, yn} = FV(φ) \\ {x1,…,xm}@, and + +* if @M ⊧_LIA ψ@ then @lift M ⊧_LIA φ@. +-} +projectN :: VarSet -> QFFormula -> (QFFormula, Model Integer -> Model Integer) +projectN vs2 = f (IS.toList vs2) + where + f :: [Var] -> QFFormula -> (QFFormula, Model Integer -> Model Integer) + f [] formula = (formula, id) + f (v:vs) formula = (formula3, mt1 . mt2) + where + (formula2, mt1) = project v formula + (formula3, mt2) = f vs formula2 + +{-| @'projectCases' x φ@ returns @[(ψ_1, lift_1), …, (ψ_m, lift_m)]@ such that: + +* @⊢_LIA ∀y1, …, yn. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_m)@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LIA ψ_i@ then @lift_i M ⊧_LIA φ@. +-} +projectCases :: Var -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] +projectCases x formula = do + (phi, wit) <- projectCases' x formula + return (phi, \m -> IM.insert x (evalWitness m wit) m) + +projectCases' :: Var -> QFFormula -> [(QFFormula, Witness)] +projectCases' x formula = [(phi', w) | (phi,w) <- case1 ++ case2, let phi' = simplify phi, phi' /= false] + where + -- eliminate Not, Imply and Equiv. + formula0 :: QFFormula + formula0 = pos formula + where + pos (Atom a) = Atom a + pos (And xs) = And (map pos xs) + pos (Or xs) = Or (map pos xs) + pos (Not x) = neg x + pos (Imply x y) = neg x .||. pos y + pos (Equiv x y) = pos ((x .=>. y) .&&. (y .=>. x)) + + neg (Atom a) = Atom (notB a) + neg (And xs) = Or (map neg xs) + neg (Or xs) = And (map neg xs) + neg (Not x) = pos x + neg (Imply x y) = pos x .&&. neg y + neg (Equiv x y) = neg ((x .=>. y) .&&. (y .=>. x)) + + -- xの係数の最小公倍数 + c :: Integer + c = getLCM $ Foldable.foldMap f formula0 + where + f (IsPos e) = LCM $ fromMaybe 1 (LA.lookupCoeff x e) + f (Divisible _ _ e) = LCM $ fromMaybe 1 (LA.lookupCoeff x e) + + -- 式をスケールしてxの係数の絶対値をcへと変換し、その後cxをxで置き換え、 + -- xがcで割り切れるという制約を追加した論理式 + formula1 :: QFFormula + formula1 = simplify $ fmap f formula0 .&&. (c .|. LA.var x) + where + f lit@(IsPos e) = + case LA.lookupCoeff x e of + Nothing -> lit + Just a -> + let s = abs (c `checkedDiv` a) + in IsPos $ g s e + f lit@(Divisible b d e) = + case LA.lookupCoeff x e of + Nothing -> lit + Just a -> + let s = abs (c `checkedDiv` a) + in Divisible b (s*d) $ g s e + + g :: Integer -> ExprZ -> ExprZ + g s = LA.mapCoeffWithVar (\c' x' -> if x==x' then signum c' else s*c') + + -- d|x+t という形の論理式の d の最小公倍数 + delta :: Integer + delta = getLCM $ Foldable.foldMap f formula1 + where + f (Divisible _ d _) = LCM d + f (IsPos _) = LCM 1 + + -- ts = {t | t < x は formula1 に現れる原子論理式} + ts :: Set ExprZ + ts = Foldable.foldMap f formula1 + where + f (Divisible _ _ _) = Set.empty + f (IsPos e) = + case LA.extractMaybe x e of + Nothing -> Set.empty + Just (1, e') -> Set.singleton (negateV e') -- IsPos e <=> (x + e' > 0) <=> (-e' < x) + Just (-1, _) -> Set.empty -- IsPos e <=> (-x + e' > 0) <=> (x < e') + _ -> error "should not happen" + + -- formula1を真にする最小のxが存在する場合 + case1 :: [(QFFormula, Witness)] + case1 = [ (subst1 x e formula1, WCase1 c e) + | j <- [1..delta], t <- Set.toList ts, let e = t ^+^ LA.constant j ] + + -- formula1のなかの x < t を真に t < x を偽に置き換えた論理式 + formula2 :: QFFormula + formula2 = simplify $ BoolExpr.fold f formula1 + where + f lit@(IsPos e) = + case LA.lookupCoeff x e of + Nothing -> Atom lit + Just 1 -> false -- IsPos e <=> ( x + e' > 0) <=> -e' < x + Just (-1) -> true -- IsPos e <=> (-x + e' > 0) <=> x < e' + _ -> error "should not happen" + f lit@(Divisible _ _ _) = Atom lit + + -- us = {u | x < u は formula1 に現れる原子論理式} + us :: Set ExprZ + us = Foldable.foldMap f formula1 + where + f (IsPos e) = + case LA.extractMaybe x e of + Nothing -> Set.empty + Just (1, _) -> Set.empty -- IsPos e <=> (x + e' > 0) <=> -e' < x + Just (-1, e') -> Set.singleton e' -- IsPos e <=> (-x + e' > 0) <=> x < e' + _ -> error "should not happen" + f (Divisible _ _ _) = Set.empty + + -- formula1を真にする最小のxが存在しない場合 + case2 :: [(QFFormula, Witness)] + case2 = [(subst1 x (LA.constant j) formula2, WCase2 c j delta us) | j <- [1..delta]] + +{-| @'projectCasesN' {x1,…,xm} φ@ returns @[(ψ_1, lift_1), …, (ψ_n, lift_n)]@ such that: + +* @⊢_LIA ∀y1, …, yp. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_n)@ where @{y1, …, yp} = FV(φ) \\ {x1,…,xm}@, and + +* if @M ⊧_LIA ψ_i@ then @lift_i M ⊧_LIA φ@. +-} +projectCasesN :: VarSet -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] +projectCasesN vs2 = f (IS.toList vs2) + where + f :: [Var] -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] + f [] formula = return (formula, id) + f (v:vs) formula = do + (formula2, mt1) <- projectCases v formula + (formula3, mt2) <- f vs formula2 + return (formula3, mt1 . mt2) + +-- --------------------------------------------------------------------------- + +newtype LCM a = LCM{ getLCM :: a } + +instance Integral a => Monoid (LCM a) where + mempty = LCM 1 + LCM a `mappend` LCM b = LCM $ lcm a b + +checkedDiv :: Integer -> Integer -> Integer +checkedDiv a b = + case a `divMod` b of + (q,0) -> q + _ -> error "ToySolver.Cooper.checkedDiv: should not happen" + +-- --------------------------------------------------------------------------- + +-- | @'solveQFFormula' {x1,…,xn} φ@ returns @Just M@ that @M ⊧_LIA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solveQFFormula :: VarSet -> QFFormula -> Maybe (Model Integer) +solveQFFormula vs formula = listToMaybe $ do + (formula2, mt) <- projectCasesN vs formula + let m = IM.empty + guard $ evalQFFormula m formula2 + return $ mt m + +-- | @'solve' {x1,…,xn} φ@ returns @Just M@ that @M ⊧_LIA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) +solve vs cs = solveQFFormula vs $ andB $ map fromLAAtom cs + +-- | @'solveQFLIRAConj' {x1,…,xn} φ I@ returns @Just M@ that @M ⊧_LIRA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- * @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +-- * @I@ is a set of integer variables and must be a subset of @{x1,…,xn}@. +-- +solveQFLIRAConj :: VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) +solveQFLIRAConj vs cs ivs = listToMaybe $ do + (cs2, mt) <- FM.projectN rvs cs + m <- maybeToList $ solve ivs cs2 + return $ mt $ IM.map fromInteger m + where + rvs = vs `IS.difference` ivs + +-- --------------------------------------------------------------------------- + +testHagiya :: QFFormula +testHagiya = fst $ project 1 $ andB [c1, c2, c3] + where + [x,y,z] = map LA.var [1..3] + c1 = x .<. (y ^+^ y) + c2 = z .<. x + c3 = 3 .|. x + +{- +∃ x. x < y+y ∧ zz+1 ∧ 3|z+1) ∨ (2y>z+2 ∧ 3|z+2) ∨ (2y>z+3 ∧ 3|z+3) +-} + +test3 :: QFFormula +test3 = fst $ project 1 $ andB [p1,p2,p3,p4] + where + x = LA.var 0 + y = LA.var 1 + p1 = LA.constant 0 .<. y + p2 = 2 *^ x .<. y + p3 = y .<. x ^+^ LA.constant 2 + p4 = 2 .|. y + +{- +∃ y. 0 < y ∧ 2x Maybe QFFormula +eliminateQuantifiers = f + where + f FOL.T = return true + f FOL.F = return false + f (FOL.Atom (ArithRel a op b)) = do + a' <- LAFOL.fromFOLExpr a + b' <- LAFOL.fromFOLExpr b + return $ fromLAAtom (ArithRel a' op b') + f (FOL.And a b) = liftM2 (.&&.) (f a) (f b) + f (FOL.Or a b) = liftM2 (.||.) (f a) (f b) + f (FOL.Not a) = liftM notB (f a) + f (FOL.Imply a b) = liftM2 (.=>.) (f a) (f b) + f (FOL.Equiv a b) = liftM2 (.<=>.) (f a) (f b) + f (FOL.Forall x body) = liftM notB $ f $ FOL.Exists x $ FOL.Not body + f (FOL.Exists x body) = liftM (fst . project x) (f body) + +-- | @'solveFormula' {x1,…,xm} φ@ +-- +-- * returns @'Sat' M@ such that @M ⊧_LIA φ@ when such @M@ exists, +-- +-- * returns @'Unsat'@ when such @M@ does not exists, and +-- +-- * returns @'Unknown'@ when @φ@ is beyond LIA. +-- +solveFormula :: VarSet -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Integer +solveFormula vs formula = + case eliminateQuantifiers formula of + Nothing -> FOL.Unknown + Just formula' -> + case solveQFFormula vs formula' of + Nothing -> FOL.Unsat + Just m -> FOL.Sat m diff --git a/src/ToySolver/Arith/FourierMotzkin.hs b/src/ToySolver/Arith/FourierMotzkin.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/FourierMotzkin.hs @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.FourierMotzkin +-- Copyright : (c) Masahiro Sakai 2011-2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Naïve implementation of Fourier-Motzkin Variable Elimination +-- +-- Reference: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.FourierMotzkin + ( + -- * Primitive constraints + Constr (..) + -- * Projection + , project + , projectN + -- * Quantifier elimination + , eliminateQuantifiers + -- * Constraint solving + , solveFormula + , solve + ) where + +import ToySolver.Arith.FourierMotzkin.Base +import ToySolver.Arith.FourierMotzkin.FOL diff --git a/src/ToySolver/Arith/FourierMotzkin/Base.hs b/src/ToySolver/Arith/FourierMotzkin/Base.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/FourierMotzkin/Base.hs @@ -0,0 +1,312 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.FourierMotzkin.Base +-- Copyright : (c) Masahiro Sakai 2011-2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Naïve implementation of Fourier-Motzkin Variable Elimination +-- +-- Reference: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.FourierMotzkin.Base + ( + -- * Primitive constraints + Constr (..) + , eqR + , ExprZ + , fromLAAtom + , toLAAtom + , constraintsToDNF + , simplify + + -- * Bounds + , Bounds + , evalBounds + , boundsToConstrs + , collectBounds + + -- * Projection + , project + , project' + , projectN + , projectN' + + -- * Solving + , solve + , solve' + + -- * Utilities used by other modules + , Rat + , toRat + ) where + +import Control.Monad +import Data.List +import Data.Maybe +import Data.Ratio +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.VectorSpace hiding (project) +import qualified Data.Interval as Interval +import Data.Interval (Interval, Extended (..), (<=..<), (<..<=), (<..<)) + +import ToySolver.Data.ArithRel +import ToySolver.Data.Boolean +import ToySolver.Data.DNF +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var + +-- --------------------------------------------------------------------------- + +type ExprZ = LA.Expr Integer + +-- | (t,c) represents t/c, and c must be >0. +type Rat = (ExprZ, Integer) + +toRat :: LA.Expr Rational -> Rat +toRat e = seq m $ (LA.mapCoeff f e, m) + where + f x = numerator (fromInteger m * x) + m = foldl' lcm 1 [denominator c | (c,_) <- LA.terms e] + +fromRat :: Rat -> LA.Expr Rational +fromRat (e,c) = LA.mapCoeff (% c) e + +evalRat :: Model Rational -> Rat -> Rational +evalRat model (e, d) = LA.lift1 1 (model IM.!) (LA.mapCoeff fromIntegral e) / (fromIntegral d) + +-- --------------------------------------------------------------------------- + +-- | Atomic constraint +data Constr + = IsNonneg ExprZ + -- ^ e ≥ 0 + | IsPos ExprZ + -- ^ e > 0 + | IsZero ExprZ + -- ^ e = 0 + deriving (Show, Eq, Ord) + +instance Variables Constr where + vars (IsPos t) = vars t + vars (IsNonneg t) = vars t + vars (IsZero t) = vars t + +leR, ltR, geR, gtR, eqR :: Rat -> Rat -> Constr +leR (e1,c) (e2,d) = IsNonneg $ normalizeExpr $ c *^ e2 ^-^ d *^ e1 +ltR (e1,c) (e2,d) = IsPos $ normalizeExpr $ c *^ e2 ^-^ d *^ e1 +geR = flip leR +gtR = flip ltR +eqR (e1,c) (e2,d) = IsZero $ normalizeExpr $ c *^ e2 ^-^ d *^ e1 + +normalizeExpr :: ExprZ -> ExprZ +normalizeExpr e = LA.mapCoeff (`div` d) e + where d = abs $ gcd' $ map fst $ LA.terms e + +-- "subst1Constr x t c" computes c[t/x] +subst1Constr :: Var -> LA.Expr Rational -> Constr -> Constr +subst1Constr x t c = + case c of + IsPos e -> IsPos (f e) + IsNonneg e -> IsNonneg (f e) + IsZero e -> IsZero (f e) + where + f :: ExprZ -> ExprZ + f = normalizeExpr . fst . toRat . LA.applySubst1 x t . LA.mapCoeff fromInteger + +-- | Simplify conjunction of 'Constr's. +-- It returns 'Nothing' when a inconsistency is detected. +simplify :: [Constr] -> Maybe [Constr] +simplify = fmap concat . mapM f + where + f :: Constr -> Maybe [Constr] + f c@(IsPos e) = + case LA.asConst e of + Just x -> guard (x > 0) >> return [] + Nothing -> return [c] + f c@(IsNonneg e) = + case LA.asConst e of + Just x -> guard (x >= 0) >> return [] + Nothing -> return [c] + f c@(IsZero e) = + case LA.asConst e of + Just x -> guard (x == 0) >> return [] + Nothing -> return [c] + +evalConstr :: Model Rational -> Constr -> Bool +evalConstr m (IsPos t) = LA.evalExpr m (LA.mapCoeff fromInteger t) > 0 +evalConstr m (IsNonneg t) = LA.evalExpr m (LA.mapCoeff fromInteger t) >= 0 +evalConstr m (IsZero t) = LA.evalExpr m (LA.mapCoeff fromInteger t) == 0 + +-- --------------------------------------------------------------------------- + +fromLAAtom :: LA.Atom Rational -> DNF Constr +fromLAAtom (ArithRel a op b) = atomR' op (toRat a) (toRat b) + where + atomR' :: RelOp -> Rat -> Rat -> DNF Constr + atomR' op a b = + case op of + Le -> DNF [[a `leR` b]] + Lt -> DNF [[a `ltR` b]] + Ge -> DNF [[a `geR` b]] + Gt -> DNF [[a `gtR` b]] + Eql -> DNF [[a `eqR` b]] + NEq -> DNF [[a `ltR` b], [a `gtR` b]] + +toLAAtom :: Constr -> LA.Atom Rational +toLAAtom (IsNonneg e) = LA.mapCoeff fromInteger e .>=. LA.constant 0 +toLAAtom (IsPos e) = LA.mapCoeff fromInteger e .>. LA.constant 0 +toLAAtom (IsZero e) = LA.mapCoeff fromInteger e .==. LA.constant 0 + +constraintsToDNF :: [LA.Atom Rational] -> DNF Constr +constraintsToDNF = andB . map fromLAAtom + +-- --------------------------------------------------------------------------- + +{- +(ls1,ls2,us1,us2) represents +{ x | ∀(M,c)∈ls1. M/c≤x, ∀(M,c)∈ls2. M/c Bounds -> Interval Rational +evalBounds model (ls1,ls2,us1,us2) = + Interval.intersections $ + [ Finite (evalRat model x) <=..< PosInf | x <- ls1 ] ++ + [ Finite (evalRat model x) <..< PosInf | x <- ls2 ] ++ + [ NegInf <..<= Finite (evalRat model x) | x <- us1 ] ++ + [ NegInf <..< Finite (evalRat model x) | x <- us2 ] + +boundsToConstrs :: Bounds -> Maybe [Constr] +boundsToConstrs (ls1, ls2, us1, us2) = simplify $ + [ x `leR` y | x <- ls1, y <- us1 ] ++ + [ x `ltR` y | x <- ls1, y <- us2 ] ++ + [ x `ltR` y | x <- ls2, y <- us1 ] ++ + [ x `ltR` y | x <- ls2, y <- us2 ] + +collectBounds :: Var -> [Constr] -> (Bounds, [Constr]) +collectBounds v = foldr phi (([],[],[],[]),[]) + where + phi :: Constr -> (Bounds, [Constr]) -> (Bounds, [Constr]) + phi constr@(IsNonneg t) x = f False constr t x + phi constr@(IsPos t) x = f True constr t x + phi constr@(IsZero t) (bnd@(ls1,ls2,us1,us2), xs) = + case LA.extractMaybe v t of + Nothing -> (bnd, constr : xs) + Just (c,t') -> ((t'' : ls1, ls2, t'' : us1, us2), xs) + where + t'' = (signum c *^ negateV t', abs c) + + f :: Bool -> Constr -> ExprZ -> (Bounds, [Constr]) -> (Bounds, [Constr]) + f strict constr t (bnd@(ls1,ls2,us1,us2), xs) = + case LA.extract v t of + (c,t') -> + case c `compare` 0 of + EQ -> (bnd, constr : xs) + GT -> + if strict + then ((ls1, (negateV t', c) : ls2, us1, us2), xs) -- 0 < cx + M ⇔ -M/c < x + else (((negateV t', c) : ls1, ls2, us1, us2), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x + LT -> + if strict + then ((ls1, ls2, us1, (t', negate c) : us2), xs) -- 0 < cx + M ⇔ x < M/-c + else ((ls1, ls2, (t', negate c) : us1, us2), xs) -- 0 ≤ cx + M ⇔ x ≤ M/-c + +-- --------------------------------------------------------------------------- + +{-| @'project' x φ@ returns @[(ψ_1, lift_1), …, (ψ_m, lift_m)]@ such that: + +* @⊢_LRA ∀y1, …, yn. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_m)@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. +-} +project :: Var -> [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)] +project v xs = do + ys <- unDNF $ constraintsToDNF xs + (zs, mt) <- maybeToList $ project' v ys + return (map toLAAtom zs, mt) + +project' :: Var -> [Constr] -> Maybe ([Constr], Model Rational -> Model Rational) +project' v cs = projectN' (IS.singleton v) cs + +{-| @'projectN' {x1,…,xm} φ@ returns @[(ψ_1, lift_1), …, (ψ_n, lift_n)]@ such that: + +* @⊢_LRA ∀y1, …, yp. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_n)@ where @{y1, …, yp} = FV(φ) \\ {x1,…,xm}@, and + +* if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. +-} +projectN :: VarSet -> [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)] +projectN vs xs = do + ys <- unDNF $ constraintsToDNF xs + (zs, mt) <- maybeToList $ projectN' vs ys + return (map toLAAtom zs, mt) + +projectN' :: VarSet -> [Constr] -> Maybe ([Constr], Model Rational -> Model Rational) +projectN' = f + where + f vs xs + | IS.null vs = return (xs, id) + | Just (v,vdef,ys) <- findEq vs xs = do + let mt1 m = IM.insert v (evalRat m vdef) m + (zs, mt2) <- f (IS.delete v vs) [subst1Constr v (fromRat vdef) c | c <- ys] + return (zs, mt1 . mt2) + | otherwise = + case IS.minView vs of + Nothing -> return (xs, id) -- should not happen + Just (v,vs') -> + case collectBounds v xs of + (bnd, rest) -> do + cond <- boundsToConstrs bnd + let mt1 m = + case Interval.simplestRationalWithin (evalBounds m bnd) of + Nothing -> error "ToySolver.FourierMotzkin.project': should not happen" + Just val -> IM.insert v val m + (ys, mt2) <- f vs' (rest ++ cond) + return (ys, mt1 . mt2) + +findEq :: VarSet -> [Constr] -> Maybe (Var, Rat, [Constr]) +findEq vs = msum . map f . pickup + where + pickup :: [a] -> [(a,[a])] + pickup [] = [] + pickup (x:xs) = (x,xs) : [(y,x:ys) | (y,ys) <- pickup xs] + + f :: (Constr, [Constr]) -> Maybe (Var, Rat, [Constr]) + f (IsZero e, cs) = do + let vs2 = IS.intersection vs (vars e) + guard $ not $ IS.null vs2 + let v = IS.findMin vs2 + (c, e') = LA.extract v e + return (v, (negateV e', c), cs) + f _ = Nothing + +-- | @'solve' {x1,…,xn} φ@ returns @Just M@ that @M ⊧_LRA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Rational) +solve vs cs = msum [solve' vs cs2 | cs2 <- unDNF (constraintsToDNF cs)] + +solve' :: VarSet -> [Constr] -> Maybe (Model Rational) +solve' vs cs = do + (cs2,mt) <- projectN' vs =<< simplify cs + let m = IM.empty + guard $ all (evalConstr m) cs2 + return $ mt m + +-- --------------------------------------------------------------------------- + +gcd' :: [Integer] -> Integer +gcd' [] = 1 +gcd' xs = foldl1' gcd xs + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/FourierMotzkin/FOL.hs b/src/ToySolver/Arith/FourierMotzkin/FOL.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/FourierMotzkin/FOL.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -Wall #-} +module ToySolver.Arith.FourierMotzkin.FOL + ( solveFormula + , eliminateQuantifiers + , eliminateQuantifiers' + ) + where + +import Control.Monad +import qualified Data.IntSet as IS +import Data.Maybe +import Data.VectorSpace hiding (project) + +import ToySolver.Data.ArithRel +import ToySolver.Data.Boolean +import ToySolver.Data.DNF +import qualified ToySolver.Data.FOL.Arith as FOL +import qualified ToySolver.Data.LA.FOL as LAFOL +import ToySolver.Data.Var + +import ToySolver.Arith.FourierMotzkin.Base + +-- --------------------------------------------------------------------------- + +-- | +-- +-- * @'solveFormula' {x1,…,xm} φ@ returns @'Sat' M@ such that @M ⊧_LRA φ@ when such @M@ exists, +-- +-- * returns @'Unsat'@ when such @M@ does not exists, and +-- +-- * returns @'Unknown'@ when @φ@ is beyond LRA. +-- +solveFormula :: VarSet -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Rational +solveFormula vs formula = + case eliminateQuantifiers' formula of + Nothing -> FOL.Unknown + Just dnf -> + case msum [solve' vs xs | xs <- unDNF dnf] of + Nothing -> FOL.Unsat + Just m -> FOL.Sat m + +-- | Eliminate quantifiers and returns equivalent quantifier-free formula. +-- +-- @'eliminateQuantifiers' φ@ returns @(ψ, lift)@ such that: +-- +-- * ψ is a quantifier-free formula and @LRA ⊢ ∀y1, …, yn. φ ↔ ψ@ where @{y1, …, yn} = FV(φ) ⊇ FV(ψ)@, and +-- +-- * if @M ⊧_LRA ψ@ then @lift M ⊧_LRA φ@. +-- +-- φ may or may not be a closed formula. +-- +eliminateQuantifiers :: FOL.Formula (FOL.Atom Rational) -> Maybe (FOL.Formula (FOL.Atom Rational)) +eliminateQuantifiers phi = do + dnf <- eliminateQuantifiers' phi + return $ orB $ map (andB . map (LAFOL.toFOLFormula . toLAAtom)) $ unDNF dnf + +eliminateQuantifiers' :: FOL.Formula (FOL.Atom Rational) -> Maybe (DNF Constr) +eliminateQuantifiers' = f + where + f FOL.T = return true + f FOL.F = return false + f (FOL.Atom (ArithRel a op b)) = do + a' <- LAFOL.fromFOLExpr a + b' <- LAFOL.fromFOLExpr b + return $ fromLAAtom $ ArithRel a' op b' + f (FOL.And a b) = liftM2 (.&&.) (f a) (f b) + f (FOL.Or a b) = liftM2 (.||.) (f a) (f b) + f (FOL.Not a) = f (FOL.pushNot a) + f (FOL.Imply a b) = f (notB a .||. b) + f (FOL.Equiv a b) = f ((a .=>. b) .&&. (b .=>.a)) + f (FOL.Forall v a) = do + dnf <- f (FOL.Exists v (FOL.pushNot a)) + return (negateDNFConstr dnf) + f (FOL.Exists v a) = do + dnf <- f a + return $ orB [DNF $ maybeToList $ fmap fst $ project' v xs | xs <- unDNF dnf] + +negateDNFConstr :: DNF Constr -> DNF Constr +negateDNFConstr (DNF xs) = orB . map (andB . map f) $ xs + where + f :: Constr -> DNF Constr + f (IsPos t) = DNF [[IsNonneg (negateV t)]] + f (IsNonneg t) = DNF [[IsPos (negateV t)]] + f (IsZero t) = DNF [[IsPos t], [IsPos (negateV t)]] + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/FourierMotzkin/Optimization.hs b/src/ToySolver/Arith/FourierMotzkin/Optimization.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/FourierMotzkin/Optimization.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.FourierMotzkin.Optimization +-- Copyright : (c) Masahiro Sakai 2014-2015 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Naïve implementation of Fourier-Motzkin Variable Elimination +-- +-- Reference: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.FourierMotzkin.Optimization + ( optimize + ) where + +import Control.Exception (assert) +import Control.Monad +import Data.Maybe +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.ExtendedReal +import qualified Data.Interval as Interval +import Data.Interval (Interval, (<=..<), (<..<=)) +import Data.OptDir + +import ToySolver.Data.DNF +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import ToySolver.Arith.FourierMotzkin.Base + +-- | @optimize dir obj φ@ returns @(I, lift)@ where +-- +-- * @I@ is convex hull of feasible region, and +-- +-- * @lift@ is a function, that takes @x ∈ I@ and returns the feasible solution with objective value /better than or equal to/ @x@. +-- +-- Note: +-- +-- * @'Interval.lowerBound' i@ (resp. @'Interval.upperBound' i@) is the optimal value in case of minimization (resp. maximization). +-- +-- * If @I@ is empty, then the problem is INFEASIBLE. +-- +optimize :: VarSet -> OptDir -> LA.Expr Rational -> [LA.Atom Rational] -> (Interval Rational, Rational -> Model Rational) +optimize vs dir obj cs = (ival, m) + where + rs = [projectToObj' vs obj cs' | cs' <- unDNF (constraintsToDNF cs)] + ival = Interval.hulls (map fst rs) + + m :: Rational -> Model Rational + m x = fromJust $ msum $ map f rs + where + f :: (Interval Rational, Rational -> Model Rational) -> Maybe (Model Rational) + f (i1,m1) = do + x' <- Interval.simplestRationalWithin (Interval.intersection i1 ib) + return (m1 x') + + ib = case dir of + OptMin -> NegInf <..<= Finite x + OptMax -> Finite x <=..< PosInf + +projectToObj' :: VarSet -> LA.Expr Rational -> [Constr] -> (Interval Rational, Rational -> Model Rational) +projectToObj' vs obj cs = projectTo' vs (eqR (toRat (LA.var z)) (toRat obj) : cs) z + where + z = fromMaybe 0 (fmap ((+1) . fst) (IntSet.maxView vs)) + +projectTo' :: VarSet -> [Constr] -> Var -> (Interval Rational, Rational -> Model Rational) +projectTo' vs cs z = fromMaybe (Interval.empty, \_ -> error "ToySolver.FourierMotzkin.projectTo': should not be called") $ do + (ys,mt) <- projectN' vs =<< simplify cs + let (bs,ws) = collectBounds z ys + assert (null ws) $ return () + let ival = evalBounds IntMap.empty bs + return (ival, \v -> mt (IntMap.singleton z v)) diff --git a/src/ToySolver/Arith/LPSolver.hs b/src/ToySolver/Arith/LPSolver.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/LPSolver.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.LPSolver +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables) +-- +-- Naïve implementation of Simplex method +-- +-- Reference: +-- +-- * +-- +----------------------------------------------------------------------------- + +module ToySolver.Arith.LPSolver + ( + -- * Solver type + Solver + , emptySolver + + -- * LP monad + , LP + , getTableau + , putTableau + + -- * Problem specification + , newVar + , addConstraint + , addConstraintWithArtificialVariable + , tableau + , define + + -- * Solving + , phaseI + , simplex + , dualSimplex + , OptResult (..) + , twoPhaseSimplex + , primalDualSimplex + + -- * Extract results + , getModel + + -- * Utilities + , collectNonnegVars + ) where + +import Control.Exception (assert) +import Control.Monad +import Control.Monad.State +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.OptDir +import Data.VectorSpace + +import Data.Interval ((<=!), (>=!), (==!), (!), (/=!)) +import qualified Data.Interval as Interval + +import ToySolver.Data.ArithRel +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import qualified ToySolver.Arith.Simplex as Simplex +import qualified ToySolver.Arith.BoundsInference as BI + +-- --------------------------------------------------------------------------- +-- Solver type + +type Solver r = (Var, Simplex.Tableau r, VarSet, VarMap (LA.Expr r)) + +emptySolver :: VarSet -> Solver r +emptySolver vs = (1 + maximum ((-1) : IS.toList vs), Simplex.emptyTableau, IS.empty, IM.empty) + +-- --------------------------------------------------------------------------- +-- LP Monad + +type LP r = State (Solver r) + +-- | Allocate a new /non-negative/ variable. +newVar :: LP r Var +newVar = do + (x,tbl,avs,defs) <- get + put (x+1,tbl,avs,defs) + return x + +getTableau :: LP r (Simplex.Tableau r) +getTableau = do + (_,tbl,_,_) <- get + return tbl + +putTableau :: Simplex.Tableau r -> LP r () +putTableau tbl = do + (x,_,avs,defs) <- get + put (x,tbl,avs,defs) + +addArtificialVariable :: Var -> LP r () +addArtificialVariable v = do + (x,tbl,avs,defs) <- get + put (x, tbl, IS.insert v avs, defs) + +getArtificialVariables :: LP r VarSet +getArtificialVariables = do + (_,_,avs,_) <- get + return avs + +clearArtificialVariables :: LP r () +clearArtificialVariables = do + (x,tbl,_,defs) <- get + put (x, tbl, IS.empty, defs) + +define :: Var -> LA.Expr r -> LP r () +define v e = do + (x,tbl,avs,defs) <- get + put (x,tbl,avs, IM.insert v e defs) + +getDefs :: LP r (VarMap (LA.Expr r)) +getDefs = do + (_,_,_,defs) <- get + return defs + +-- --------------------------------------------------------------------------- + +-- | Add a contraint and maintain feasibility condition by introducing artificial variable (if necessary). +-- +-- * Disequality is not supported. +-- +-- * Unlike 'addConstraint', an equality contstraint becomes one row with an artificial variable. +-- +addConstraintWithArtificialVariable :: Real r => LA.Atom r -> LP r () +addConstraintWithArtificialVariable c = do + c2 <- expandDefs' c + let (e, rop, b) = normalizeConstraint c2 + assert (b >= 0) $ return () + tbl <- getTableau + case rop of + -- x≥0 is trivially true, since x is non-negative. + Ge | b==0 && isSingleVar e -> return () + -- -x≤0 is trivially true, since x is non-negative. + Le | b==0 && isSingleNegatedVar e -> return () + + Le -> do + v <- newVar -- slack variable + putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) + Ge -> do + v1 <- newVar -- surplus variable + v2 <- newVar -- artificial variable + putTableau $ Simplex.addRow tbl v2 (LA.coeffMap (e ^-^ LA.var v1), b) + addArtificialVariable v2 + Eql -> do + v <- newVar -- artificial variable + putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) + addArtificialVariable v + _ -> error $ "ToySolver.LPSolver.addConstraintWithArtificialVariable does not support " ++ show rop + +-- | Add a contraint, without maintaining feasibilty condition of tableaus. +-- +-- * Disequality is not supported. +-- +-- * Unlike 'addConstraintWithArtificialVariable', an equality constraint becomes two rows. +-- +addConstraint :: Real r => LA.Atom r -> LP r () +addConstraint c = do + ArithRel lhs rop rhs <- expandDefs' c + let + (b', e) = LA.extract LA.unitVar (lhs ^-^ rhs) + b = - b' + case rop of + Le -> f e b + Ge -> f (negateV e) (negate b) + Eql -> do + -- Unlike addConstraintWithArtificialVariable, an equality constraint becomes two rows. + f e b + f (negateV e) (negate b) + _ -> error $ "ToySolver.LPSolver.addConstraint does not support " ++ show rop + where + -- -x≤b with b≥0 is trivially true. + f e b | isSingleNegatedVar e && 0 <= b = return () + f e b = do + tbl <- getTableau + v <- newVar -- slack variable + putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) + +isSingleVar :: Real r => LA.Expr r -> Bool +isSingleVar e = + case LA.terms e of + [(1,_)] -> True + _ -> False + +isSingleNegatedVar :: Real r => LA.Expr r -> Bool +isSingleNegatedVar e = + case LA.terms e of + [(-1,_)] -> True + _ -> False + +expandDefs :: (Num r, Eq r) => LA.Expr r -> LP r (LA.Expr r) +expandDefs e = do + defs <- getDefs + return $ LA.applySubst defs e + +expandDefs' :: (Num r, Eq r) => LA.Atom r -> LP r (LA.Atom r) +expandDefs' (ArithRel lhs op rhs) = do + lhs' <- expandDefs lhs + rhs' <- expandDefs rhs + return $ ArithRel lhs' op rhs' + +tableau :: (RealFrac r) => [LA.Atom r] -> LP r () +tableau cs = do + let (nonnegVars, cs') = collectNonnegVars cs IS.empty + fvs = vars cs `IS.difference` nonnegVars + forM_ (IS.toList fvs) $ \v -> do + v1 <- newVar + v2 <- newVar + define v (LA.var v1 ^-^ LA.var v2) + mapM_ addConstraint cs' + +getModel :: Fractional r => VarSet -> LP r (Model r) +getModel vs = do + tbl <- getTableau + defs <- getDefs + let vs' = (vs `IS.difference` IM.keysSet defs) `IS.union` IS.unions [vars e | e <- IM.elems defs] + m0 = IM.fromAscList [(v, Simplex.currentValue tbl v) | v <- IS.toAscList vs'] + return $ IM.filterWithKey (\k _ -> k `IS.member` vs) $ IM.map (LA.evalExpr m0) defs `IM.union` m0 + +phaseI :: (Fractional r, Real r) => LP r Bool +phaseI = do + introduceArtificialVariables + tbl <- getTableau + avs <- getArtificialVariables + let (ret, tbl') = Simplex.phaseI tbl avs + putTableau tbl' + when ret clearArtificialVariables + return ret + +introduceArtificialVariables :: (Real r) => LP r () +introduceArtificialVariables = do + tbl <- getTableau + tbl' <- liftM IM.fromList $ forM (IM.toList tbl) $ \(v,(e,rhs)) -> do + if rhs >= 0 then do + return (v,(e,rhs)) -- v + e == rhs + else do + a <- newVar + addArtificialVariable a + return (a, (IM.insert v (-1) (IM.map negate e), -rhs)) -- a - (v + e) == -rhs + putTableau tbl' + +simplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r Bool +simplex optdir obj = do + tbl <- getTableau + defs <- getDefs + let (ret, tbl') = Simplex.simplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) + putTableau tbl' + return ret + +dualSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r Bool +dualSimplex optdir obj = do + tbl <- getTableau + defs <- getDefs + let (ret, tbl') = Simplex.dualSimplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) + putTableau tbl' + return ret + +-- | results of optimization +data OptResult = Optimum | Unsat | Unbounded + deriving (Show, Eq, Ord) + +twoPhaseSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r OptResult +twoPhaseSimplex optdir obj = do + ret <- phaseI + if not ret then + return Unsat + else do + ret <- simplex optdir obj + if ret then + return Optimum + else + return Unbounded + +primalDualSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r OptResult +primalDualSimplex optdir obj = do + tbl <- getTableau + defs <- getDefs + let (ret, tbl') = Simplex.primalDualSimplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) + putTableau tbl' + if ret then + return Optimum + else if not (Simplex.isFeasible tbl') then + return Unsat + else + return Unbounded + +-- --------------------------------------------------------------------------- + +-- convert right hand side to be non-negative +normalizeConstraint :: forall r. Real r => LA.Atom r -> (LA.Expr r, RelOp, r) +normalizeConstraint (ArithRel a op b) + | rhs < 0 = (negateV lhs, flipOp op, negate rhs) + | otherwise = (lhs, op, rhs) + where + (c, lhs) = LA.extract LA.unitVar (a ^-^ b) + rhs = - c + +collectNonnegVars :: forall r. (RealFrac r) => [LA.Atom r] -> VarSet -> (VarSet, [LA.Atom r]) +collectNonnegVars cs ivs = (nonnegVars, cs) + where + vs = vars cs + bounds = BI.inferBounds initialBounds cs ivs 1000 + where + initialBounds = IM.fromAscList [(v, Interval.whole) | v <- IS.toAscList vs] + nonnegVars = IS.filter (\v -> 0 <=! (bounds IM.! v)) vs + + isTriviallyTrue :: LA.Atom r -> Bool + isTriviallyTrue (ArithRel a op b) = + case op of + Le -> i <=! 0 + Ge -> i >=! 0 + Lt -> i i >! 0 + Eql -> i ==! 0 + NEq -> i /=! 0 + where + i = LA.computeInterval bounds (a ^-^ b) + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/LPSolverHL.hs b/src/ToySolver/Arith/LPSolverHL.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/LPSolverHL.hs @@ -0,0 +1,275 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.LPSolverHL +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables) +-- +-- High-Level API for LPSolver.hs +-- +----------------------------------------------------------------------------- + +module ToySolver.Arith.LPSolverHL + ( OptResult (..) + , minimize + , maximize + , optimize + , solve + ) where + +import Control.Monad.State +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.OptDir +import Data.VectorSpace + +import ToySolver.Data.ArithRel +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import qualified ToySolver.Arith.Simplex as Simplex +import qualified ToySolver.Arith.LPSolver as LPSolver +import ToySolver.Arith.LPSolver hiding (OptResult (..)) + +-- --------------------------------------------------------------------------- + +-- | results of optimization +data OptResult r = OptUnsat | Unbounded | Optimum r (Model r) + deriving (Show, Eq, Ord) + +maximize :: (RealFrac r) => LA.Expr r -> [LA.Atom r] -> OptResult r +maximize = optimize OptMax + +minimize :: (RealFrac r) => LA.Expr r -> [LA.Atom r] -> OptResult r +minimize = optimize OptMin + +solve :: (RealFrac r) => [LA.Atom r] -> Maybe (Model r) +solve cs = + flip evalState (emptySolver vs) $ do + tableau cs + ret <- phaseI + if not ret + then return Nothing + else do + m <- getModel vs + return (Just m) + where + vs = vars cs + +optimize :: (RealFrac r) => OptDir -> LA.Expr r -> [LA.Atom r] -> OptResult r +optimize optdir obj cs = + flip evalState (emptySolver vs) $ do + tableau cs + ret <- LPSolver.twoPhaseSimplex optdir obj + case ret of + LPSolver.Unsat -> return OptUnsat + LPSolver.Unbounded -> return Unbounded + LPSolver.Optimum -> do + m <- getModel vs + tbl <- getTableau + return $ Optimum (Simplex.currentObjValue tbl) m + where + vs = vars cs `IS.union` vars obj + +-- --------------------------------------------------------------------------- +-- Test cases + +example_3_2 :: (LA.Expr Rational, [LA.Atom Rational]) +example_3_2 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + obj = 3*^x1 ^+^ 2*^x2 ^+^ 3*^x3 + cond = [ 2*^x1 ^+^ x2 ^+^ x3 .<=. LA.constant 2 + , x1 ^+^ 2*^x2 ^+^ 3*^x3 .<=. LA.constant 5 + , 2*^x1 ^+^ 2*^x2 ^+^ x3 .<=. LA.constant 6 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + , x3 .>=. LA.constant 0 + ] + +test_3_2 :: Bool +test_3_2 = + uncurry maximize example_3_2 == + Optimum (27/5) (IM.fromList [(1,1/5),(2,0),(3,8/5)]) + +example_3_5 :: (LA.Expr Rational, [LA.Atom Rational]) +example_3_5 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + x4 = LA.var 4 + x5 = LA.var 5 + obj = (-2)*^x1 ^+^ 4*^x2 ^+^ 7*^x3 ^+^ x4 ^+^ 5*^x5 + cond = [ (-1)*^x1 ^+^ x2 ^+^ 2*^x3 ^+^ x4 ^+^ 2*^x5 .==. LA.constant 7 + , (-1)*^x1 ^+^ 2*^x2 ^+^ 3*^x3 ^+^ x4 ^+^ x5 .==. LA.constant 6 + , (-1)*^x1 ^+^ x2 ^+^ x3 ^+^ 2*^x4 ^+^ x5 .==. LA.constant 4 + , x2 .>=. LA.constant 0 + , x3 .>=. LA.constant 0 + , x4 .>=. LA.constant 0 + , x5 .>=. LA.constant 0 + ] + +test_3_5 :: Bool +test_3_5 = + uncurry minimize example_3_5 == + Optimum 19 (IM.fromList [(1,-1),(2,0),(3,1),(4,0),(5,2)]) + +example_4_1 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_1 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + obj = 2*^x1 ^+^ x2 + cond = [ (-1)*^x1 ^+^ x2 .>=. LA.constant 2 + , x1 ^+^ x2 .<=. LA.constant 1 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + ] + +test_4_1 :: Bool +test_4_1 = + uncurry maximize example_4_1 == + OptUnsat + +example_4_2 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_2 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + obj = 2*^x1 ^+^ x2 + cond = [ (-1)*^x1 ^-^ x2 .<=. LA.constant 10 + , 2*^x1 ^-^ x2 .<=. LA.constant 40 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + ] + +test_4_2 :: Bool +test_4_2 = + uncurry maximize example_4_2 == + Unbounded + +example_4_3 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_3 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + obj = 6*^x1 ^-^ 2*^x2 + cond = [ 2*^x1 ^-^ x2 .<=. LA.constant 2 + , x1 .<=. LA.constant 4 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + ] + +test_4_3 :: Bool +test_4_3 = + uncurry maximize example_4_3 == + Optimum 12 (IM.fromList [(1,4),(2,6)]) + +example_4_5 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_5 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + obj = 2*^x1 ^+^ x2 + cond = [ 4*^x1 ^+^ 3*^x2 .<=. LA.constant 12 + , 4*^x1 ^+^ x2 .<=. LA.constant 8 + , 4*^x1 ^-^ x2 .<=. LA.constant 8 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + ] + +test_4_5 :: Bool +test_4_5 = + uncurry maximize example_4_5 == + Optimum 5 (IM.fromList [(1,3/2),(2,2)]) + +example_4_6 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_6 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + x4 = LA.var 4 + obj = 20*^x1 ^+^ (1/2)*^x2 ^-^ 6*^x3 ^+^ (3/4)*^x4 + cond = [ x1 .<=. LA.constant 2 + , 8*^x1 ^-^ x2 ^+^ 9*^x3 ^+^ (1/4)*^x4 .<=. LA.constant 16 + , 12*^x1 ^-^ (1/2)*^x2 ^+^ 3*^x3 ^+^ (1/2)*^x4 .<=. LA.constant 24 + , x2 .<=. LA.constant 1 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + , x3 .>=. LA.constant 0 + , x4 .>=. LA.constant 0 + ] + +test_4_6 :: Bool +test_4_6 = + uncurry maximize example_4_6 == + Optimum (165/4) (IM.fromList [(1,2),(2,1),(3,0),(4,1)]) + +example_4_7 :: (LA.Expr Rational, [LA.Atom Rational]) +example_4_7 = (obj, cond) + where + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + x4 = LA.var 4 + obj = x1 ^+^ 1.5*^x2 ^+^ 5*^x3 ^+^ 2*^x4 + cond = [ 3*^x1 ^+^ 2*^x2 ^+^ x3 ^+^ 4*^x4 .<=. LA.constant 6 + , 2*^x1 ^+^ x2 ^+^ 5*^x3 ^+^ x4 .<=. LA.constant 4 + , 2*^x1 ^+^ 6*^x2 ^-^ 4*^x3 ^+^ 8*^x4 .==. LA.constant 0 + , x1 ^+^ 3*^x2 ^-^ 2*^x3 ^+^ 4*^x4 .==. LA.constant 0 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + , x3 .>=. LA.constant 0 + , x4 .>=. LA.constant 0 + ] + +test_4_7 :: Bool +test_4_7 = + uncurry maximize example_4_7 == + Optimum (48/11) (IM.fromList [(1,0),(2,0),(3,81),(4,41)]) + +-- 退化して巡回の起こるKuhnの7変数3制約の例 +kuhn_7_3 :: (LA.Expr Rational, [LA.Atom Rational]) +kuhn_7_3 = (obj, cond) + where + [x1,x2,x3,x4,x5,x6,x7] = map LA.var [1..7] + obj = (-2)*^x4 ^+^ (-3)*^x5 ^+^ x6 ^+^ 12*^x7 + cond = [ x1 ^-^ 2*^x4 ^-^ 9*^x5 ^+^ x6 ^+^ 9*^x7 .==. LA.constant 0 + , x2 ^+^ (1/3)*^x4 ^+^ x5 ^-^ (1/3)*^x6 ^-^ 2*^x7 .==. LA.constant 0 + , x3 ^+^ 2*^x4 ^+^ 3*^x5 ^-^ x6 ^-^ 12*^x7 .==. LA.constant 2 + , x1 .>=. LA.constant 0 + , x2 .>=. LA.constant 0 + , x3 .>=. LA.constant 0 + , x4 .>=. LA.constant 0 + , x5 .>=. LA.constant 0 + , x6 .>=. LA.constant 0 + , x7 .>=. LA.constant 0 + ] + +test_kuhn_7_3 :: Bool +test_kuhn_7_3 = + uncurry minimize kuhn_7_3 == + Optimum (-2) (IM.fromList [(1,2),(2,0),(3,0),(4,2),(5,0),(6,2),(7,0)]) + +testAll :: Bool +testAll = and + [ test_3_2 + , test_3_5 + , test_4_1 + , test_4_2 + , test_4_3 + , test_4_5 + , test_4_6 + , test_4_7 + , test_kuhn_7_3 + ] + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/LPUtil.hs b/src/ToySolver/Arith/LPUtil.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/LPUtil.hs @@ -0,0 +1,92 @@ +module ToySolver.Arith.LPUtil + ( toStandardForm + , toStandardForm' + ) where + +import Control.Exception +import Control.Monad +import Control.Monad.State +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Maybe +import Data.VectorSpace + +import qualified Data.Interval as Interval + +import ToySolver.Data.ArithRel +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import qualified ToySolver.Arith.BoundsInference as BI + +toStandardForm + :: (LA.Expr Rational, [ArithRel (LA.Expr Rational)]) + -> ( (LA.Expr Rational, [(LA.Expr Rational, Rational)]) + , Model Rational -> Model Rational + ) +toStandardForm prob1@(obj, cs) = (prob2, mt) + where + vs = vars obj `IS.union` vars cs + (prob2,s) = toStandardForm' prob1 + mt m = IM.fromAscList $ do + v <- IS.toAscList vs + case IM.lookup v s of + Just def -> return (v, LA.evalExpr m def) + Nothing -> return (v, m IM.! v) + +type M = State Var + +toStandardForm' + :: (LA.Expr Rational, [ArithRel (LA.Expr Rational)]) + -> ( (LA.Expr Rational, [(LA.Expr Rational, Rational)]) + , VarMap (LA.Expr Rational) + ) +toStandardForm' (obj, cs) = m + where + vs = vars obj `IS.union` vars cs + v1 = if IS.null vs then 0 else IS.findMax vs + 1 + initialBounds = IM.fromList [(v, Interval.whole) | v <- IS.toList vs] + bounds = BI.inferBounds initialBounds cs IS.empty 10 + + gensym :: M Var + gensym = do + v <- get + put $ v+1 + return v + + m = flip evalState v1 $ do + s <- liftM IM.unions $ forM (IM.toList bounds) $ \(v,i) -> do + case Interval.lowerBound i of + Interval.NegInf -> do + v1 <- gensym + v2 <- gensym + return $ IM.singleton v (LA.var v1 ^-^ LA.var v2) + Interval.Finite lb + | lb >= 0 -> return IM.empty + | otherwise -> do + v1 <- gensym + return $ IM.singleton v (LA.var v1 ^-^ LA.constant lb) + let obj2 = LA.applySubst s obj + + cs2 <- liftM concat $ forM cs $ \(ArithRel lhs op rhs) -> do + case LA.extract LA.unitVar (LA.applySubst s (lhs ^-^ rhs)) of + (c,e) -> do + let (lhs2,op2,rhs2) = + if -c >= 0 + then (e,op,-c) + else (negateV e, flipOp op, c) + case op2 of + Eql -> return [(lhs2,rhs2)] + Le -> do + v <- gensym + return [(lhs2 ^+^ LA.var v, rhs2)] + Ge -> do + case LA.terms lhs2 of + [(1,_)] | rhs2<=0 -> return [] + _ -> do + v <- gensym + return [(lhs2 ^-^ LA.var v, rhs2)] + _ -> error $ "ToySolver.LPUtil.toStandardForm: " ++ show op2 ++ " is not supported" + + assert (and [isNothing $ LA.lookupCoeff LA.unitVar c | (c,_) <- cs2]) $ return () + + return ((obj2,cs2),s) diff --git a/src/ToySolver/Arith/MIPSolver2.hs b/src/ToySolver/Arith/MIPSolver2.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/MIPSolver2.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.MIPSolver2 +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables, Rank2Types) +-- +-- Naïve implementation of MIP solver based on Simplex2 module +-- +-- Reference: +-- +-- * +-- +-- * Ralph E. Gomory. +-- \"An Algorithm for the Mixed Integer Problem\", Technical Report +-- RM-2597, 1960, The Rand Corporation, Santa Monica, CA. +-- +-- +-- * Ralph E. Gomory. +-- \"Outline of an algorithm for integer solutions to linear programs\". +-- Bull. Amer. Math. Soc., Vol. 64, No. 5. (1958), pp. 275-278. +-- +-- +-- * R. C. Daniel and Martyn Jeffreys. +-- \"Unboundedness in Integer and Discrete Programming L.P. Relaxations\" +-- The Journal of the Operational Research Society, Vol. 30, No. 12. (1979) +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.MIPSolver2 + ( + -- * The @Solver@ type + Solver + , newSolver + + -- * Solving + , optimize + + -- * Extract results + , getBestSolution + , getBestValue + , getBestModel + + -- * Configulation + , setNThread + , setLogger + , setOnUpdateBestSolution + , setShowRational + ) where + +import Prelude hiding (log) + +import Control.Monad +import Control.Exception +import Control.Concurrent +import Control.Concurrent.STM +import Data.Default.Class +import Data.List +import Data.OptDir +import Data.Ord +import Data.IORef +import Data.Maybe +import qualified Data.IntSet as IS +import qualified Data.IntMap as IM +import qualified Data.Map as Map +import qualified Data.Sequence as Seq +import qualified Data.Foldable as F +import Data.VectorSpace +import Data.Time +import System.CPUTime +import System.Timeout +import Text.Printf + +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.ArithRel ((.<=.), (.>=.)) +import qualified ToySolver.Arith.Simplex2 as Simplex2 +import ToySolver.Arith.Simplex2 (OptResult (..), Var, Model) +import ToySolver.Internal.Util (isInteger, fracPart) + +data Solver + = MIP + { mipRootLP :: Simplex2.Solver + , mipIVs :: IS.IntSet + , mipBest :: TVar (Maybe Node) + + , mipNThread :: IORef Int + , mipLogger :: IORef (Maybe (String -> IO ())) + , mipOnUpdateBestSolution :: IORef (Model -> Rational -> IO ()) + , mipShowRational :: IORef Bool + } + +data Node = + Node + { ndLP :: Simplex2.Solver + , ndDepth :: {-# UNPACK #-} !Int + , ndValue :: Rational + } + +newSolver :: Simplex2.Solver -> IS.IntSet -> IO Solver +newSolver lp ivs = do + lp2 <- Simplex2.cloneSolver lp + + forM_ (IS.toList ivs) $ \v -> do + lb <- Simplex2.getLB lp2 v + case lb of + Just l | not (isInteger l) -> + Simplex2.assertLower lp2 v (fromInteger (ceiling l)) + _ -> return () + ub <- Simplex2.getUB lp2 v + case ub of + Just u | not (isInteger u) -> + Simplex2.assertLower lp2 v (fromInteger (floor u)) + _ -> return () + + bestRef <- newTVarIO Nothing + + nthreadRef <- newIORef 0 + logRef <- newIORef Nothing + showRef <- newIORef False + updateRef <- newIORef (\_ _ -> return ()) + + return $ + MIP + { mipRootLP = lp2 + , mipIVs = ivs + , mipBest = bestRef + + , mipNThread = nthreadRef + , mipLogger = logRef + , mipOnUpdateBestSolution = updateRef + , mipShowRational = showRef + } + +optimize :: Solver -> IO OptResult +optimize solver = do + let lp = mipRootLP solver + update <- readIORef (mipOnUpdateBestSolution solver) + log solver "MIP: Solving LP relaxation..." + ret <- Simplex2.check lp + if not ret + then return Unsat + else do + s0 <- showValue solver =<< Simplex2.getObjValue lp + log solver (printf "MIP: LP relaxation is satisfiable with obj = %s" s0) + log solver "MIP: Optimizing LP relaxation" + ret2 <- Simplex2.optimize lp def + case ret2 of + Unsat -> error "should not happen" + ObjLimit -> error "should not happen" + Unbounded -> do + log solver "MIP: LP relaxation is unbounded" + let ivs = mipIVs solver + if IS.null ivs + then return Unbounded + else do + {- + * In general, original problem may have optimal + solution even though LP relaxiation is unbounded. + * But if restricted to rational numbers, the + original problem is unbounded or unsatisfiable + when LP relaxation is unbounded. + -} + origObj <- Simplex2.getObj lp + lp2 <- Simplex2.cloneSolver lp + Simplex2.clearLogger lp2 + Simplex2.setObj lp2 (LA.constant 0) + branchAndBound solver lp2 $ \m _ -> do + update m (LA.evalExpr m origObj) + best <- readTVarIO (mipBest solver) + case best of + Just nd -> do + m <- Simplex2.getModel (ndLP nd) + atomically $ writeTVar (mipBest solver) $ Just nd{ ndValue = LA.evalExpr m origObj } + return Unbounded + Nothing -> return Unsat + Optimum -> do + s1 <- showValue solver =<< Simplex2.getObjValue lp + log solver $ "MIP: LP relaxation optimum is " ++ s1 + log solver "MIP: Integer optimization begins..." + Simplex2.clearLogger lp + branchAndBound solver lp update + m <- readTVarIO (mipBest solver) + case m of + Nothing -> return Unsat + Just _ -> return Optimum + +branchAndBound :: Solver -> Simplex2.Solver -> (Model -> Rational -> IO ()) -> IO () +branchAndBound solver rootLP update = do + dir <- Simplex2.getOptDir rootLP + rootVal <- Simplex2.getObjValue rootLP + let root = Node{ ndLP = rootLP, ndDepth = 0, ndValue = rootVal } + + pool <- newTVarIO (Seq.singleton root) + activeThreads <- newTVarIO (Map.empty) + visitedNodes <- newTVarIO 0 + solchan <- newTChanIO + + let addNode :: Node -> STM () + addNode nd = do + modifyTVar pool (Seq.|> nd) + + pickNode :: IO (Maybe Node) + pickNode = do + self <- myThreadId + atomically $ modifyTVar activeThreads (Map.delete self) + atomically $ do + s <- readTVar pool + case Seq.viewl s of + nd Seq.:< s2 -> do + writeTVar pool s2 + modifyTVar activeThreads (Map.insert self nd) + return (Just nd) + Seq.EmptyL -> do + ths <- readTVar activeThreads + if Map.null ths + then return Nothing + else retry + + processNode :: Node -> IO () + processNode node = do + let lp = ndLP node + lim <- liftM (fmap ndValue) $ readTVarIO (mipBest solver) + ret <- Simplex2.dualSimplex lp def{ Simplex2.objLimit = lim } + + case ret of + Unbounded -> error "should not happen" + Unsat -> return () + ObjLimit -> return () + Optimum -> do + val <- Simplex2.getObjValue lp + p <- prune solver val + unless p $ do + xs <- violated node (mipIVs solver) + case xs of + [] -> atomically $ writeTChan solchan $ node { ndValue = val } + _ -> do + r <- if ndDepth node `mod` 100 /= 0 + then return Nothing + else liftM listToMaybe $ filterM (canDeriveGomoryCut lp) $ map fst xs + case r of + Nothing -> do -- branch + let (v0,val0) = fst $ maximumBy (comparing snd) + [((v,vval), abs (fromInteger (round vval) - vval)) | (v,vval) <- xs] + let lp1 = lp + lp2 <- Simplex2.cloneSolver lp + Simplex2.assertAtom lp1 (LA.var v0 .<=. LA.constant (fromInteger (floor val0))) + Simplex2.assertAtom lp2 (LA.var v0 .>=. LA.constant (fromInteger (ceiling val0))) + atomically $ do + addNode $ Node lp1 (ndDepth node + 1) val + addNode $ Node lp2 (ndDepth node + 1) val + modifyTVar visitedNodes (+1) + Just v -> do -- cut + atom <- deriveGomoryCut lp (mipIVs solver) v + Simplex2.assertAtom lp atom + atomically $ do + addNode $ Node lp (ndDepth node + 1) val + + let isCompleted = do + nodes <- readTVar pool + threads <- readTVar activeThreads + return $ Seq.null nodes && Map.null threads + + -- fork worker threads + nthreads <- liftM (max 1) $ readIORef (mipNThread solver) + + log solver $ printf "MIP: forking %d worker threads..." nthreads + + startCPU <- getCPUTime + startWC <- getCurrentTime + ex <- newEmptyTMVarIO + + let printStatus :: Seq.Seq Node -> Int -> IO () + printStatus nodes visited + | Seq.null nodes = return () -- should not happen + | otherwise = do + nowCPU <- getCPUTime + nowWC <- getCurrentTime + let spentCPU = (nowCPU - startCPU) `div` 10^(12::Int) + let spentWC = round (nowWC `diffUTCTime` startWC) :: Int + + let vs = map ndValue (F.toList nodes) + dualBound = + case dir of + OptMin -> minimum vs + OptMax -> maximum vs + + primalBound <- do + x <- readTVarIO (mipBest solver) -- TODO: 引数にするようにした方が良い? + return $ case x of + Nothing -> Nothing + Just node -> Just (ndValue node) + + (p,g) <- case primalBound of + Nothing -> return ("not yet found", "--") + Just val -> do + p <- showValue solver val + let g = if val == 0 + then "inf" + else printf "%.2f%%" (fromRational (abs (dualBound - val) * 100 / abs val) :: Double) + return (p, g) + d <- showValue solver dualBound + + let range = + case dir of + OptMin -> p ++ " >= " ++ d + OptMax -> p ++ " <= " ++ d + + log solver $ printf "cpu time = %d sec; wc time = %d sec; active nodes = %d; visited nodes = %d; %s; gap = %s" + spentCPU spentWC (Seq.length nodes) visited range g + + mask $ \(restore :: forall a. IO a -> IO a) -> do + threads <- replicateM nthreads $ do + forkIO $ do + let loop = do + m <- pickNode + case m of + Nothing -> return () + Just node -> processNode node >> loop + ret <- try $ restore loop + case ret of + Left e -> atomically (putTMVar ex e) + Right _ -> return () + + let propagateException :: SomeException -> IO () + propagateException e = do + mapM_ (\t -> throwTo t e) threads + throwIO e + + let loop = do + ret <- try $ timeout (2*1000*1000) $ restore $ atomically $ msum + [ do node <- readTChan solchan + ret <- do + old <- readTVar (mipBest solver) + case old of + Nothing -> do + writeTVar (mipBest solver) (Just node) + return True + Just best -> do + let isBetter = if dir==OptMin then ndValue node < ndValue best else ndValue node > ndValue best + when isBetter $ writeTVar (mipBest solver) (Just node) + return isBetter + return $ do + when ret $ do + let lp = ndLP node + m <- Simplex2.getModel lp + update m (ndValue node) + loop + , do b <- isCompleted + guard b + return $ return () + , do e <- readTMVar ex + return $ propagateException e + ] + + case ret of + Left (e::SomeException) -> propagateException e + Right (Just m) -> m + Right Nothing -> do -- timeout + (nodes, visited) <- atomically $ do + nodes <- readTVar pool + athreads <- readTVar activeThreads + visited <- readTVar visitedNodes + return (Seq.fromList (Map.elems athreads) Seq.>< nodes, visited) + printStatus nodes visited + loop + + loop + +getBestSolution :: Solver -> IO (Maybe (Model, Rational)) +getBestSolution solver = do + ret <- readTVarIO (mipBest solver) + case ret of + Nothing -> return Nothing + Just node -> do + m <- Simplex2.getModel (ndLP node) + return $ Just (m, ndValue node) + +getBestModel :: Solver -> IO (Maybe Model) +getBestModel solver = liftM (fmap fst) $ getBestSolution solver + +getBestValue :: Solver -> IO (Maybe Rational) +getBestValue solver = liftM (fmap snd) $ getBestSolution solver + +violated :: Node -> IS.IntSet -> IO [(Var, Rational)] +violated node ivs = do + m <- Simplex2.getModel (ndLP node) + let p (v,val) = v `IS.member` ivs && not (isInteger val) + return $ filter p (IM.toList m) + +prune :: Solver -> Rational -> IO Bool +prune solver lb = do + b <- readTVarIO (mipBest solver) + case b of + Nothing -> return False + Just node -> do + dir <- Simplex2.getOptDir (mipRootLP solver) + return $ if dir==OptMin then ndValue node <= lb else ndValue node >= lb + +showValue :: Solver -> Rational -> IO String +showValue solver v = do + printRat <- readIORef (mipShowRational solver) + return $ Simplex2.showValue printRat v + +setShowRational :: Solver -> Bool -> IO () +setShowRational solver = writeIORef (mipShowRational solver) + +setNThread :: Solver -> Int -> IO () +setNThread solver = writeIORef (mipNThread solver) + +{-------------------------------------------------------------------- + Logging +--------------------------------------------------------------------} + +-- | set callback function for receiving messages. +setLogger :: Solver -> (String -> IO ()) -> IO () +setLogger solver logger = do + writeIORef (mipLogger solver) (Just logger) + +setOnUpdateBestSolution :: Solver -> (Model -> Rational -> IO ()) -> IO () +setOnUpdateBestSolution solver cb = do + writeIORef (mipOnUpdateBestSolution solver) cb + +log :: Solver -> String -> IO () +log solver msg = logIO solver (return msg) + +logIO :: Solver -> IO String -> IO () +logIO solver action = do + m <- readIORef (mipLogger solver) + case m of + Nothing -> return () + Just logger -> action >>= logger + +{-------------------------------------------------------------------- + GomoryCut +--------------------------------------------------------------------} + +deriveGomoryCut :: Simplex2.Solver -> IS.IntSet -> Var -> IO (LA.Atom Rational) +deriveGomoryCut lp ivs xi = do + v0 <- Simplex2.getValue lp xi + let f0 = fracPart v0 + assert (0 < f0 && f0 < 1) $ return () + + row <- Simplex2.getRow lp xi + + -- remove fixed variables + let p (_,xj) = do + lb <- Simplex2.getLB lp xj + ub <- Simplex2.getUB lp xj + case (lb,ub) of + (Just l, Just u) -> return (l < u) + _ -> return True + ns <- filterM p $ LA.terms row + + js <- flip filterM ns $ \(_, xj) -> do + vj <- Simplex2.getValue lp xj + lb <- Simplex2.getLB lp xj + return $ Just vj == lb + ks <- flip filterM ns $ \(_, xj) -> do + vj <- Simplex2.getValue lp xj + ub <- Simplex2.getUB lp xj + return $ Just vj == ub + + xs1 <- forM js $ \(aij, xj) -> do + let fj = fracPart aij + Just lj <- Simplex2.getLB lp xj + let c = if xj `IS.member` ivs + then (if fj <= 1 - f0 then fj / (1 - f0) else ((1 - fj) / f0)) + else (if aij > 0 then aij / (1 - f0) else (-aij / f0)) + return $ c *^ (LA.var xj ^-^ LA.constant lj) + xs2 <- forM ks $ \(aij, xj) -> do + let fj = fracPart aij + Just uj <- Simplex2.getUB lp xj + let c = if xj `IS.member` ivs + then (if fj <= f0 then fj / f0 else ((1 - fj) / (1 - f0))) + else (if aij > 0 then aij / f0 else (-aij / (1 - f0))) + return $ c *^ (LA.constant uj ^-^ LA.var xj) + + return $ sumV xs1 ^+^ sumV xs2 .>=. LA.constant 1 + +-- TODO: Simplex2をδに対応させたら、xi, xj がδを含まない有理数であるという条件も必要 +canDeriveGomoryCut :: Simplex2.Solver -> Var -> IO Bool +canDeriveGomoryCut lp xi = do + b <- Simplex2.isBasicVariable lp xi + if not b + then return False + else do + val <- Simplex2.getValue lp xi + if isInteger val + then return False + else do + row <- Simplex2.getRow lp xi + ys <- forM (LA.terms row) $ \(_,xj) -> do + vj <- Simplex2.getValue lp xj + lb <- Simplex2.getLB lp xj + ub <- Simplex2.getUB lp xj + return $ Just vj == lb || Just vj == ub + return (and ys) diff --git a/src/ToySolver/Arith/MIPSolverHL.hs b/src/ToySolver/Arith/MIPSolverHL.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/MIPSolverHL.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.MIPSolverHL +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables) +-- +-- References: +-- +-- * [Gomory1960] +-- Ralph E. Gomory. +-- An Algorithm for the Mixed Integer Problem, Technical Report +-- RM-2597, 1960, The Rand Corporation, Santa Monica, CA. +-- +-- +-- * [Gomory1958] +-- Ralph E. Gomory. +-- Outline of an algorithm for integer solutions to linear programs. +-- Bull. Amer. Math. Soc., Vol. 64, No. 5. (1958), pp. 275-278. +-- +----------------------------------------------------------------------------- + +module ToySolver.Arith.MIPSolverHL + ( module Data.OptDir + , OptResult (..) + , minimize + , maximize + , optimize + ) where + +import Control.Exception +import Control.Monad.State +import Data.Default.Class +import Data.Ord +import Data.Maybe +import Data.List (maximumBy) +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.OptDir +import Data.VectorSpace + +import ToySolver.Data.ArithRel +import ToySolver.Data.Var +import qualified ToySolver.Data.LA as LA +import qualified ToySolver.Arith.Simplex as Simplex +import qualified ToySolver.Arith.LPSolver as LPSolver +import ToySolver.Arith.LPSolver hiding (OptResult (..)) +import ToySolver.Arith.LPSolverHL (OptResult (..)) +import qualified ToySolver.Arith.OmegaTest as OmegaTest +import ToySolver.Internal.Util (isInteger, fracPart) + +-- --------------------------------------------------------------------------- + +data Node r + = Node + { ndSolver :: LPSolver.Solver r + , ndDepth :: {-# UNPACK #-} !Int +-- , ndCutSlackVariables :: VarSet + } + +ndTableau :: Node r -> Simplex.Tableau r +ndTableau node = evalState getTableau (ndSolver node) + +ndLowerBound :: (Num r, Eq r) => Node r -> r +ndLowerBound node = evalState (liftM Simplex.currentObjValue getTableau) (ndSolver node) + +data Err = ErrUnbounded | ErrUnsat deriving (Ord, Eq, Show, Enum, Bounded) + +maximize :: RealFrac r => LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r +maximize = optimize OptMax + +minimize :: RealFrac r => LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r +minimize = optimize OptMin + +optimize :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r +optimize optdir obj cs ivs = + case mkInitialNode optdir obj cs ivs of + Left err -> + case err of + ErrUnsat -> OptUnsat + ErrUnbounded -> + if IS.null ivs + then Unbounded + else + {- + Fallback to Fourier-Motzkin + OmegaTest + * In general, original problem may have optimal + solution even though LP relaxiation is unbounded. + * But if restricted to rational numbers, the + original problem is unbounded or unsatisfiable + when LP relaxation is unbounded. + -} + case OmegaTest.solveQFLIRAConj def (vars cs `IS.union` ivs) (map conv cs) ivs of + Nothing -> OptUnsat + Just _ -> Unbounded + Right (node0, ivs2) -> + case traverse optdir obj ivs2 node0 of + Left ErrUnbounded -> error "shoud not happen" + Left ErrUnsat -> OptUnsat + Right node -> flip evalState (ndSolver node) $ do + tbl <- getTableau + model <- getModel vs + return $ Optimum (Simplex.currentObjValue tbl) model + where + vs = vars cs `IS.union` vars obj + +tableau' :: (RealFrac r) => [LA.Atom r] -> VarSet -> LP r VarSet +tableau' cs ivs = do + let (nonnegVars, cs') = collectNonnegVars cs ivs + fvs = vars cs `IS.difference` nonnegVars + ivs2 <- liftM IS.unions $ forM (IS.toList fvs) $ \v -> do + v1 <- newVar + v2 <- newVar + define v (LA.var v1 ^-^ LA.var v2) + return $ if v `IS.member` ivs then IS.fromList [v1,v2] else IS.empty + mapM_ addConstraint cs' + return ivs2 + +conv :: RealFrac r => LA.Atom r -> LA.Atom Rational +conv = fmap (LA.mapCoeff toRational) + +mkInitialNode :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> Either Err (Node r, VarSet) +mkInitialNode optdir obj cs ivs = + flip evalState (emptySolver vs) $ do + ivs2 <- tableau' cs ivs + ret <- LPSolver.twoPhaseSimplex optdir obj + case ret of + LPSolver.Unsat -> return (Left ErrUnsat) + LPSolver.Unbounded -> return (Left ErrUnbounded) + LPSolver.Optimum -> do + solver <- get + return $ Right $ + ( Node{ ndSolver = solver + , ndDepth = 0 +-- , ndCutSlackVariables = IS.empty + } + , ivs `IS.union` ivs2 + ) + where + vs = vars cs `IS.union` vars obj + +isStrictlyBetter :: RealFrac r => OptDir -> r -> r -> Bool +isStrictlyBetter optdir = if optdir==OptMin then (<) else (>) + +traverse :: forall r. RealFrac r => OptDir -> LA.Expr r -> VarSet -> Node r -> Either Err (Node r) +traverse optdir obj ivs node0 = loop [node0] Nothing + where + loop :: [Node r] -> Maybe (Node r) -> Either Err (Node r) + loop [] (Just best) = Right best + loop [] Nothing = Left ErrUnsat + loop (n:ns) Nothing = + case children n of + Nothing -> loop ns (Just n) + Just cs -> loop (cs++ns) Nothing + loop (n:ns) (Just best) + | isStrictlyBetter optdir (ndLowerBound n) (ndLowerBound best) = + case children n of + Nothing -> loop ns (Just n) + Just cs -> loop (cs++ns) (Just best) + | otherwise = loop ns (Just best) + + reopt :: Solver r -> Maybe (Solver r) + reopt s = flip evalState s $ do + ret <- dualSimplex optdir obj + if ret + then liftM Just get + else return Nothing + + children :: Node r -> Maybe [Node r] + children node + | null xs = Nothing -- no violation + | ndDepth node `mod` 100 == 0 = -- cut + let + (f0, m0) = maximumBy (comparing fst) [(fracPart val, m) | (_,m,val) <- xs] + sv = flip execState (ndSolver node) $ do + s <- newVar + let g j x = assert (a >= 0) a + where + a | j `IS.member` ivs = + if fracPart x <= f0 + then fracPart x + else (f0 / (f0 - 1)) * (fracPart x - 1) + -- [Gomory1960] では (f0 / (1 - f0)) * (fracPart x - 1) としているが、 + -- これは誤り + | otherwise = + if x >= 0 + then x + else (f0 / (f0 - 1)) * x + putTableau $ IM.insert s (IM.mapWithKey (\j x -> negate (g j x)) m0, negate f0) tbl + in Just $ [node{ ndSolver = sv2, ndDepth = ndDepth node + 1 } | sv2 <- maybeToList (reopt sv)] + | otherwise = -- branch + let (v0, val0) = snd $ maximumBy (comparing fst) [(fracPart val, (v, val)) | (v,_,val) <- xs] + cs = [ LA.var v0 .>=. LA.constant (fromIntegral (ceiling val0 :: Integer)) + , LA.var v0 .<=. LA.constant (fromIntegral (floor val0 :: Integer)) + ] + svs = [execState (addConstraint c) (ndSolver node) | c <- cs] + in Just $ [node{ ndSolver = sv, ndDepth = ndDepth node + 1 } | Just sv <- map reopt svs] + + where + tbl :: Simplex.Tableau r + tbl = ndTableau node + + xs :: [(Var, VarMap r, r)] + xs = [ (v, m, val) + | v <- IS.toList ivs + , Just (m, val) <- return (IM.lookup v tbl) + , not (isInteger val) + ] + +-- --------------------------------------------------------------------------- + +example1 :: (Fractional r, Eq r) => (OptDir, LA.Expr r, [LA.Atom r], VarSet) +example1 = (optdir, obj, cs, ivs) + where + optdir = OptMax + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + x4 = LA.var 4 + obj = x1 ^+^ 2 *^ x2 ^+^ 3 *^ x3 ^+^ x4 + cs = + [ (-1) *^ x1 ^+^ x2 ^+^ x3 ^+^ 10*^x4 .<=. LA.constant 20 + , x1 ^-^ 3 *^ x2 ^+^ x3 .<=. LA.constant 30 + , x2 ^-^ 3.5 *^ x4 .==. LA.constant 0 + , LA.constant 0 .<=. x1 + , x1 .<=. LA.constant 40 + , LA.constant 0 .<=. x2 + , LA.constant 0 .<=. x3 + , LA.constant 2 .<=. x4 + , x4 .<=. LA.constant 3 + ] + ivs = IS.singleton 4 + +test1 :: Bool +test1 = result==expected + where + (optdir, obj, cs, ivs) = example1 + result, expected :: OptResult Rational + result = optimize optdir obj cs ivs + expected = Optimum (245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) + +test1' :: Bool +test1' = result==expected + where + (optdir, obj, cs, ivs) = example1 + f OptMin = OptMax + f OptMax = OptMin + result, expected :: OptResult Rational + result = optimize (f optdir) (negateV obj) cs ivs + expected = Optimum (-245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) + +-- 『数理計画法の基礎』(坂和 正敏) p.109 例 3.8 +example2 :: (Fractional r, Eq r) => (OptDir, LA.Expr r, [LA.Atom r], VarSet) +example2 = (optdir, obj, cs, ivs) + where + optdir = OptMin + [x1,x2,x3] = map LA.var [1..3] + obj = (-1) *^ x1 ^-^ 3 *^ x2 ^-^ 5 *^ x3 + cs = + [ 3 *^ x1 ^+^ 4 *^ x2 .<=. LA.constant 10 + , 2 *^ x1 ^+^ x2 ^+^ x3 .<=. LA.constant 7 + , 3*^x1 ^+^ x2 ^+^ 4 *^ x3 .==. LA.constant 12 + , LA.constant 0 .<=. x1 + , LA.constant 0 .<=. x2 + , LA.constant 0 .<=. x3 + ] + ivs = IS.fromList [1,2] + +test2 :: Bool +test2 = result == expected + where + result, expected :: OptResult Rational + result = optimize optdir obj cs ivs + expected = Optimum (-37/2) (IM.fromList [(1,0),(2,2),(3,5/2)]) + (optdir, obj, cs, ivs) = example2 + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/OmegaTest.hs b/src/ToySolver/Arith/OmegaTest.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/OmegaTest.hs @@ -0,0 +1,80 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.OmegaTest +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- (incomplete) implementation of Omega Test +-- +-- References: +-- +-- * William Pugh. The Omega test: a fast and practical integer +-- programming algorithm for dependence analysis. In Proceedings of +-- the 1991 ACM/IEEE conference on Supercomputing (1991), pp. 4-13. +-- +-- * +-- +-- See also: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.OmegaTest + ( + -- * Solving + Model + , solve + , solveQFLIRAConj + -- * Options for solving + , Options (..) + , defaultOptions + , checkRealNoCheck + , checkRealByFM + , checkRealByCAD + , checkRealByVS + , checkRealBySimplex + ) where + +import Control.Monad +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Maybe +import qualified Data.Set as Set +import System.IO.Unsafe + +import qualified ToySolver.Data.LA as LA +import qualified ToySolver.Data.Polynomial as P +import ToySolver.Data.Var +import qualified ToySolver.Arith.CAD as CAD +import qualified ToySolver.Arith.Simplex2 as Simplex2 +import qualified ToySolver.Arith.VirtualSubstitution as VS +import ToySolver.Arith.OmegaTest.Base + +checkRealByCAD :: VarSet -> [LA.Atom Rational] -> Bool +checkRealByCAD vs as = isJust $ CAD.solve vs2 (map (fmap f) as) + where + vs2 = Set.fromAscList $ IS.toAscList vs + + f :: LA.Expr Rational -> P.Polynomial Rational Int + f t = sum [ if x == LA.unitVar + then P.constant c + else P.constant c * P.var x + | (c,x) <- LA.terms t ] + +checkRealByVS :: VarSet -> [LA.Atom Rational] -> Bool +checkRealByVS vs as = isJust $ VS.solve vs as + +checkRealBySimplex :: VarSet -> [LA.Atom Rational] -> Bool +checkRealBySimplex vs as = unsafePerformIO $ do + solver <- Simplex2.newSolver + s <- liftM IM.fromList $ forM (IS.toList vs) $ \v -> do + v2 <- Simplex2.newVar solver + return (v, LA.var v2) + forM_ as $ \a -> do + Simplex2.assertAtomEx solver (fmap (LA.applySubst s) a) + Simplex2.check solver diff --git a/src/ToySolver/Arith/OmegaTest/Base.hs b/src/ToySolver/Arith/OmegaTest/Base.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/OmegaTest/Base.hs @@ -0,0 +1,337 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.OmegaTest.Base +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- (incomplete) implementation of Omega Test +-- +-- References: +-- +-- * William Pugh. The Omega test: a fast and practical integer +-- programming algorithm for dependence analysis. In Proceedings of +-- the 1991 ACM/IEEE conference on Supercomputing (1991), pp. 4-13. +-- +-- * +-- +-- See also: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.OmegaTest.Base + ( Model + , solve + , solveQFLIRAConj + , Options (..) + , defaultOptions + , checkRealNoCheck + , checkRealByFM + + -- * Exported just for testing + , zmod + ) where + +import Control.Exception (assert) +import Control.Monad +import Data.Default.Class +import Data.List +import Data.Maybe +import Data.Ord +import Data.Ratio +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.VectorSpace + +import ToySolver.Data.ArithRel +import ToySolver.Data.Boolean +import ToySolver.Data.DNF +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var +import ToySolver.Internal.Util (combineMaybe) +import qualified ToySolver.Arith.FourierMotzkin as FM +import ToySolver.Arith.FourierMotzkin.Base (Constr (..), toLAAtom) + +-- --------------------------------------------------------------------------- + +data Options + = Options + { optCheckReal :: VarSet -> [LA.Atom Rational] -> Bool + -- ^ optCheckReal is used for checking whether real shadow is satisfiable. + -- + -- * If it returns @True@, the real shadow may or may not be satisfiable. + -- + -- * If it returns @False@, the real shadow must be unsatisfiable + } + +instance Default Options where + def = defaultOptions + +defaultOptions :: Options +defaultOptions = + Options + { optCheckReal = + -- checkRealNoCheck + checkRealByFM + } + +checkRealNoCheck :: VarSet -> [LA.Atom Rational] -> Bool +checkRealNoCheck _ _ = True + +checkRealByFM :: VarSet -> [LA.Atom Rational] -> Bool +checkRealByFM vs as = isJust $ FM.solve vs as + +-- --------------------------------------------------------------------------- + +type ExprZ = LA.Expr Integer + +-- 制約集合の単純化 +-- It returns Nothing when a inconsistency is detected. +simplify :: [Constr] -> Maybe [Constr] +simplify = fmap concat . mapM f + where + f :: Constr -> Maybe [Constr] + f (IsPos e) = f (IsNonneg (e ^-^ LA.constant 1)) + f constr@(IsNonneg e) = + case LA.asConst e of + Just x -> guard (x >= 0) >> return [] + Nothing -> return [constr] + f constr@(IsZero e) = + case LA.asConst e of + Just x -> guard (x == 0) >> return [] + Nothing -> return [constr] + +leZ, ltZ, geZ, gtZ, eqZ :: ExprZ -> ExprZ -> Constr +-- Note that constants may be floored by division +leZ e1 e2 = IsNonneg (LA.mapCoeff (`div` d) e) + where + e = e2 ^-^ e1 + d = abs $ gcd' [c | (c,v) <- LA.terms e, v /= LA.unitVar] +ltZ e1 e2 = (e1 ^+^ LA.constant 1) `leZ` e2 +geZ = flip leZ +gtZ = flip ltZ +eqZ e1 e2 = + case isZero (e1 ^-^ e2) of + Just c -> c + Nothing -> IsZero (LA.constant 1) -- unsatisfiable + +isZero :: ExprZ -> Maybe Constr +isZero e + = if LA.coeff LA.unitVar e `mod` d == 0 + then Just $ IsZero $ LA.mapCoeff (`div` d) e + else Nothing + where + d = abs $ gcd' [c | (c,v) <- LA.terms e, v /= LA.unitVar] + +applySubst1Constr :: Var -> ExprZ -> Constr -> Constr +applySubst1Constr v e (IsPos e2) = LA.applySubst1 v e e2 `gtZ` LA.constant 0 +applySubst1Constr v e (IsNonneg e2) = LA.applySubst1 v e e2 `geZ` LA.constant 0 +applySubst1Constr v e (IsZero e2) = LA.applySubst1 v e e2 `eqZ` LA.constant 0 + +evalConstr :: Model Integer -> Constr -> Bool +evalConstr m (IsPos t) = LA.evalExpr m t > 0 +evalConstr m (IsNonneg t) = LA.evalExpr m t >= 0 +evalConstr m (IsZero t) = LA.evalExpr m t == 0 + +-- --------------------------------------------------------------------------- + +-- | (t,c) represents t/c, and c must be >0. +type Rat = (ExprZ, Integer) + +{- +(ls,us) represents +{ x | ∀(M,c)∈ls. M/c≤x, ∀(M,c)∈us. x≤M/c } +-} +type BoundsZ = ([Rat],[Rat]) + +evalBoundsZ :: Model Integer -> BoundsZ -> IntervalZ +evalBoundsZ model (ls,us) = + foldl' intersectZ univZ $ + [ (Just (ceiling (LA.evalExpr model x % c)), Nothing) | (x,c) <- ls ] ++ + [ (Nothing, Just (floor (LA.evalExpr model x % c))) | (x,c) <- us ] + +collectBoundsZ :: Var -> [Constr] -> (BoundsZ, [Constr]) +collectBoundsZ v = foldr phi (([],[]),[]) + where + phi :: Constr -> (BoundsZ,[Constr]) -> (BoundsZ,[Constr]) + phi (IsPos t) x = phi (IsNonneg (t ^-^ LA.constant 1)) x + phi constr@(IsNonneg t) ((ls,us),xs) = + case LA.extract v t of + (c,t') -> + case c `compare` 0 of + EQ -> ((ls, us), constr : xs) + GT -> (((negateV t', c) : ls, us), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x + LT -> ((ls, (t', negate c) : us), xs) -- 0 ≤ cx + M ⇔ x ≤ M/-c + phi constr@(IsZero _) (bnd,xs) = (bnd, constr : xs) -- we assume v does not appear in constr + +-- --------------------------------------------------------------------------- + +solve' :: Options -> VarSet -> [Constr] -> Maybe (Model Integer) +solve' opt vs2 xs = simplify xs >>= go vs2 + where + go :: VarSet -> [Constr] -> Maybe (Model Integer) + go vs cs | IS.null vs = do + let m = IM.empty + guard $ all (evalConstr m) cs + return m + go vs cs | Just (e,cs2) <- extractEq cs = do + (vs',cs3, mt) <- eliminateEq e vs cs2 + m <- go vs' =<< simplify cs3 + return (mt m) + go vs cs = do + guard $ optCheckReal opt vs (map toLAAtom cs) + if isExact bnd then + case1 + else + case1 `mplus` case2 + + where + (v,vs',bnd@(ls,us),rest) = chooseVariable vs cs + + case1 = do + let zs = [ LA.constant ((a-1)*(b-1)) `leZ` (a *^ d ^-^ b *^ c) + | (c,a)<-ls , (d,b)<-us ] + model <- go vs' =<< simplify (zs ++ rest) + case pickupZ (evalBoundsZ model bnd) of + Nothing -> error "ToySolver.OmegaTest.solve': should not happen" + Just val -> return $ IM.insert v val model + + case2 = msum + [ do c <- isZero $ a' *^ LA.var v ^-^ (c' ^+^ LA.constant k) + model <- go vs (c : cs) + return model + | let m = maximum [b | (_,b)<-us] + , (c',a') <- ls + , k <- [0 .. (m*a'-a'-m) `div` m] + ] + +isExact :: BoundsZ -> Bool +isExact (ls,us) = and [a==1 || b==1 | (_,a)<-ls , (_,b)<-us] + +chooseVariable :: VarSet -> [Constr] -> (Var, VarSet, BoundsZ, [Constr]) +chooseVariable vs xs = head $ [e | e@(_,_,bnd,_) <- table, isExact bnd] ++ table + where + table = [ (v, IS.fromAscList vs', bnd, rest) + | (v,vs') <- pickup (IS.toAscList vs), let (bnd, rest) = collectBoundsZ v xs + ] + +-- Find an equality constraint (e==0) and extract e with rest of constraints. +extractEq :: [Constr] -> Maybe (ExprZ, [Constr]) +extractEq = msum . map f . pickup + where + f :: (Constr, [Constr]) -> Maybe (ExprZ, [Constr]) + f (IsZero e, ls) = Just (e, ls) + f _ = Nothing + +-- Eliminate an equality equality constraint (e==0). +eliminateEq :: ExprZ -> VarSet -> [Constr] -> Maybe (VarSet, [Constr], Model Integer -> Model Integer) +eliminateEq e vs cs | Just c <- LA.asConst e = guard (c==0) >> return (vs, cs, id) +eliminateEq e vs cs = do + let (ak,xk) = minimumBy (comparing (abs . fst)) [(a,x) | (a,x) <- LA.terms e, x /= LA.unitVar] + if abs ak == 1 then + case LA.extract xk e of + (_, e') -> do + let xk_def = signum ak *^ negateV e' + return $ + ( IS.delete xk vs + , [applySubst1Constr xk xk_def c | c <- cs] + , \model -> IM.insert xk (LA.evalExpr model xk_def) model + ) + else do + let m = abs ak + 1 + assert (ak `zmod` m == - signum ak) $ return () + let -- sigma is a fresh variable + sigma = if IS.null vs then 0 else IS.findMax vs + 1 + -- m *^ LA.var sigma == LA.fromTerms [(a `zmod` m, x) | (a,x) <- LA.terms e] + -- m *^ LA.var sigma == LA.fromTerms [(a `zmod` m, x) | (a,x) <- LA.terms e, x /= xk] ^+^ (ak `zmod` m) *^ LA.var xk + -- m *^ LA.var sigma == LA.fromTerms [(a `zmod` m, x) | (a,x) <- LA.terms e, x /= xk] ^+^ (- signum ak) *^ LA.var xk + -- LA.var xk == (- signum ak * m) *^ LA.var sigma ^+^ LA.fromTerms [(signum ak * (a `zmod` m), x) | (a,x) <- LA.terms e, x /= xk] + xk_def = (- signum ak * m) *^ LA.var sigma ^+^ + LA.fromTerms [(signum ak * (a `zmod` m), x) | (a,x) <- LA.terms e, x /= xk] + -- e2 is normalized version of (LA.applySubst1 xk xk_def e). + e2 = (- abs ak) *^ LA.var sigma ^+^ + LA.fromTerms [((floor (a%m + 1/2) + (a `zmod` m)), x) | (a,x) <- LA.terms e, x /= xk] + assert (m *^ e2 == LA.applySubst1 xk xk_def e) $ return () + let mt model = IM.delete sigma $ IM.insert xk (LA.evalExpr model xk_def) model + c <- isZero e2 + return (IS.insert sigma (IS.delete xk vs), c : [applySubst1Constr xk xk_def c | c <- cs], mt) + +-- --------------------------------------------------------------------------- + +type IntervalZ = (Maybe Integer, Maybe Integer) + +univZ :: IntervalZ +univZ = (Nothing, Nothing) + +intersectZ :: IntervalZ -> IntervalZ -> IntervalZ +intersectZ (l1,u1) (l2,u2) = (combineMaybe max l1 l2, combineMaybe min u1 u2) + +pickupZ :: IntervalZ -> Maybe Integer +pickupZ (Nothing,Nothing) = return 0 +pickupZ (Just x, Nothing) = return x +pickupZ (Nothing, Just x) = return x +pickupZ (Just x, Just y) = if x <= y then return x else mzero + +-- --------------------------------------------------------------------------- + +-- | @'solve' opt {x1,…,xn} φ@ returns @Just M@ that @M ⊧_LIA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solve :: Options -> VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) +solve opt vs cs = msum [solve' opt vs cs | cs <- unDNF dnf] + where + dnf = andB (map f cs) + f (ArithRel lhs op rhs) = + case op of + Lt -> DNF [[a `ltZ` b]] + Le -> DNF [[a `leZ` b]] + Gt -> DNF [[a `gtZ` b]] + Ge -> DNF [[a `geZ` b]] + Eql -> DNF [[a `eqZ` b]] + NEq -> DNF [[a `ltZ` b], [a `gtZ` b]] + where + (e1,c1) = g lhs + (e2,c2) = g rhs + a = c2 *^ e1 + b = c1 *^ e2 + g :: LA.Expr Rational -> (ExprZ, Integer) + g a = (LA.mapCoeff (\c -> floor (c * fromInteger d)) a, d) + where + d = foldl' lcm 1 [denominator c | (c,_) <- LA.terms a] + +-- | @'solveQFLIRAConj' {x1,…,xn} φ I@ returns @Just M@ that @M ⊧_LIRA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- * @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +-- * @I@ is a set of integer variables and must be a subset of @{x1,…,xn}@. +-- +solveQFLIRAConj :: Options -> VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) +solveQFLIRAConj opt vs cs ivs = listToMaybe $ do + (cs2, mt) <- FM.projectN rvs cs + m <- maybeToList $ solve opt ivs cs2 + return $ mt $ IM.map fromInteger m + where + rvs = vs `IS.difference` ivs + +-- --------------------------------------------------------------------------- + +zmod :: Integer -> Integer -> Integer +a `zmod` b = a - b * floor (a % b + 1 / 2) + +gcd' :: [Integer] -> Integer +gcd' [] = 1 +gcd' xs = foldl1' gcd xs + +pickup :: [a] -> [(a,[a])] +pickup [] = [] +pickup (x:xs) = (x,xs) : [(y,x:ys) | (y,ys) <- pickup xs] + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/Simplex.hs b/src/ToySolver/Arith/Simplex.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/Simplex.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.Simplex +-- Copyright : (c) Masahiro Sakai 2011 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (ScopedTypeVariables) +-- +-- Naïve implementation of Simplex method +-- +-- Reference: +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.Simplex + ( + -- * The @Tableau@ type + Tableau + , RowIndex + , ColIndex + , Row + , emptyTableau + , objRowIndex + , pivot + , lookupRow + , addRow + , setObjFun + + -- * Optimization direction + , module Data.OptDir + + -- * Reading status + , currentValue + , currentObjValue + , isFeasible + , isOptimal + + -- * High-level solving functions + , simplex + , dualSimplex + , phaseI + , primalDualSimplex + + -- * For debugging + , isValidTableau + , toCSV + ) where + +import Data.Ord +import Data.List +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.OptDir +import Data.VectorSpace +import Control.Exception + +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var + +-- --------------------------------------------------------------------------- + +type Tableau r = VarMap (Row r) +{- +tbl ! v == (m, val) +==> +var v .+. m .==. constant val +-} + +-- | Basic variables +type RowIndex = Int + +-- | Non-basic variables +type ColIndex = Int + +type Row r = (VarMap r, r) + +data PivotResult r = PivotUnbounded | PivotFinished | PivotSuccess (Tableau r) + deriving (Show, Eq, Ord) + +emptyTableau :: Tableau r +emptyTableau = IM.empty + +objRowIndex :: RowIndex +objRowIndex = -1 + +pivot :: (Fractional r, Eq r) => RowIndex -> ColIndex -> Tableau r -> Tableau r +{-# INLINE pivot #-} +{-# SPECIALIZE pivot :: RowIndex -> ColIndex -> Tableau Rational -> Tableau Rational #-} +{-# SPECIALIZE pivot :: RowIndex -> ColIndex -> Tableau Double -> Tableau Double #-} +pivot r s tbl = + assert (isValidTableau tbl) $ -- precondition + assert (isValidTableau tbl') $ -- postcondition + tbl' + where + tbl' = IM.insert s row_s $ IM.map f $ IM.delete r $ tbl + f orig@(row_i, row_i_val) = + case IM.lookup s row_i of + Nothing -> orig + Just c -> + ( IM.filter (0/=) $ IM.unionWith (+) (IM.delete s row_i) (IM.map (negate c *) row_r') + , row_i_val - c*row_r_val' + ) + (row_r, row_r_val) = lookupRow r tbl + a_rs = row_r IM.! s + row_r' = IM.map (/ a_rs) $ IM.insert r 1 $ IM.delete s row_r + row_r_val' = row_r_val / a_rs + row_s = (row_r', row_r_val') + +-- | Lookup a row by basic variable +lookupRow :: RowIndex -> Tableau r -> Row r +lookupRow r m = m IM.! r + +-- 行の基底変数の列が0になるように変形 +normalizeRow :: (Num r, Eq r) => Tableau r -> Row r -> Row r +normalizeRow a (row0,val0) = obj' + where + obj' = g $ foldl' f (IM.empty, val0) $ + [ case IM.lookup j a of + Nothing -> (IM.singleton j x, 0) + Just (row,val) -> (IM.map ((-x)*) (IM.delete j row), -x*val) + | (j,x) <- IM.toList row0 ] + f (m1,v1) (m2,v2) = (IM.unionWith (+) m1 m2, v1+v2) + g (m,v) = (IM.filter (0/=) m, v) + +setRow :: (Num r, Eq r) => Tableau r -> RowIndex -> Row r -> Tableau r +setRow tbl i row = assert (isValidTableau tbl) $ assert (isValidTableau tbl') $ tbl' + where + tbl' = IM.insert i (normalizeRow tbl row) tbl + +addRow :: (Num r, Eq r) => Tableau r -> RowIndex -> Row r -> Tableau r +addRow tbl i row = assert (i `IM.notMember` tbl) $ setRow tbl i row + +setObjFun :: (Num r, Eq r) => Tableau r -> LA.Expr r -> Tableau r +setObjFun tbl e = addRow tbl objRowIndex row + where + row = + case LA.extract LA.unitVar e of + (c, e') -> (LA.coeffMap (negateV e'), c) + +copyObjRow :: (Num r, Eq r) => Tableau r -> Tableau r -> Tableau r +copyObjRow from to = + case IM.lookup objRowIndex from of + Nothing -> IM.delete objRowIndex to + Just row -> addRow to objRowIndex row + +currentValue :: Num r => Tableau r -> Var -> r +currentValue tbl v = + case IM.lookup v tbl of + Nothing -> 0 + Just (_, val) -> val + +currentObjValue :: Num r => Tableau r -> r +currentObjValue = snd . lookupRow objRowIndex + +isValidTableau :: Tableau r -> Bool +isValidTableau tbl = + and [v `IM.notMember` m | (v, (m,_)) <- IM.toList tbl, v /= objRowIndex] && + and [IS.null (IM.keysSet m `IS.intersection` vs) | (m,_) <- IM.elems tbl'] + where + tbl' = IM.delete objRowIndex tbl + vs = IM.keysSet tbl' + +isFeasible :: Real r => Tableau r -> Bool +isFeasible tbl = + and [val >= 0 | (v, (_,val)) <- IM.toList tbl, v /= objRowIndex] + +isOptimal :: Real r => OptDir -> Tableau r -> Bool +isOptimal optdir tbl = + and [not (cmp cj) | cj <- IM.elems (fst (lookupRow objRowIndex tbl))] + where + cmp = case optdir of + OptMin -> (0<) + OptMax -> (0>) + +isImproving :: Real r => OptDir -> Tableau r -> Tableau r -> Bool +isImproving OptMin from to = currentObjValue to <= currentObjValue from +isImproving OptMax from to = currentObjValue to >= currentObjValue from + +-- --------------------------------------------------------------------------- +-- primal simplex + +simplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) +{-# SPECIALIZE simplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} +{-# SPECIALIZE simplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} +simplex optdir = go + where + go tbl = assert (isFeasible tbl) $ + case primalPivot optdir tbl of + PivotFinished -> assert (isOptimal optdir tbl) (True, tbl) + PivotUnbounded -> (False, tbl) + PivotSuccess tbl' -> assert (isImproving optdir tbl tbl') $ go tbl' + +primalPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> PivotResult r +{-# INLINE primalPivot #-} +primalPivot optdir tbl + | null cs = PivotFinished + | null rs = PivotUnbounded + | otherwise = PivotSuccess (pivot r s tbl) + where + cmp = case optdir of + OptMin -> (0<) + OptMax -> (0>) + cs = [(j,cj) | (j,cj) <- IM.toList (fst (lookupRow objRowIndex tbl)), cmp cj] + -- smallest subscript rule + s = fst $ head cs + -- classical rule + --s = fst $ (if optdir==OptMin then maximumBy else minimumBy) (compare `on` snd) cs + rs = [ (i, y_i0 / y_is) + | (i, (row_i, y_i0)) <- IM.toList tbl, i /= objRowIndex + , let y_is = IM.findWithDefault 0 s row_i, y_is > 0 + ] + r = fst $ minimumBy (comparing snd) rs + +-- --------------------------------------------------------------------------- +-- dual simplex + +dualSimplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) +{-# SPECIALIZE dualSimplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} +{-# SPECIALIZE dualSimplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} +dualSimplex optdir = go + where + go tbl = assert (isOptimal optdir tbl) $ + case dualPivot optdir tbl of + PivotFinished -> assert (isFeasible tbl) $ (True, tbl) + PivotUnbounded -> (False, tbl) + PivotSuccess tbl' -> assert (isImproving optdir tbl' tbl) $ go tbl' + +dualPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> PivotResult r +{-# INLINE dualPivot #-} +dualPivot optdir tbl + | null rs = PivotFinished + | null cs = PivotUnbounded + | otherwise = PivotSuccess (pivot r s tbl) + where + rs = [(i, row_i) | (i, (row_i, y_i0)) <- IM.toList tbl, i /= objRowIndex, 0 > y_i0] + (r, row_r) = head rs + cs = [ (j, if optdir==OptMin then y_0j / y_rj else - y_0j / y_rj) + | (j, y_rj) <- IM.toList row_r + , y_rj < 0 + , let y_0j = IM.findWithDefault 0 j obj + ] + s = fst $ minimumBy (comparing snd) cs + (obj,_) = lookupRow objRowIndex tbl + +-- --------------------------------------------------------------------------- +-- phase I of the two-phased method + +phaseI :: (Real r, Fractional r) => Tableau r -> VarSet -> (Bool, Tableau r) +{-# SPECIALIZE phaseI :: Tableau Rational -> VarSet -> (Bool, Tableau Rational) #-} +{-# SPECIALIZE phaseI :: Tableau Double -> VarSet -> (Bool, Tableau Double) #-} +phaseI tbl avs + | currentObjValue tbl1' /= 0 = (False, tbl1') + | otherwise = (True, copyObjRow tbl $ removeArtificialVariables avs $ tbl1') + where + optdir = OptMax + tbl1 = setObjFun tbl $ negateV $ sumV [LA.var v | v <- IS.toList avs] + tbl1' = go tbl1 + go tbl2 + | currentObjValue tbl2 == 0 = tbl2 + | otherwise = + case primalPivot optdir tbl2 of + PivotSuccess tbl2' -> assert (isImproving optdir tbl2 tbl2') $ go tbl2' + PivotFinished -> assert (isOptimal optdir tbl2) tbl2 + PivotUnbounded -> error "phaseI: should not happen" + +-- post-processing of phaseI +-- pivotを使ってartificial variablesを基底から除いて、削除 +removeArtificialVariables :: (Real r, Fractional r) => VarSet -> Tableau r -> Tableau r +removeArtificialVariables avs tbl0 = tbl2 + where + tbl1 = foldl' f (IM.delete objRowIndex tbl0) (IS.toList avs) + tbl2 = IM.map (\(row,val) -> (IM.filterWithKey (\j _ -> j `IS.notMember` avs) row, val)) tbl1 + f tbl i = + case IM.lookup i tbl of + Nothing -> tbl + Just row -> + case [j | (j,c) <- IM.toList (fst row), c /= 0, j `IS.notMember` avs] of + [] -> IM.delete i tbl + j:_ -> pivot i j tbl + +-- --------------------------------------------------------------------------- +-- primal-dual simplex + +data PDResult = PDUnsat | PDOptimal | PDUnbounded + +primalDualSimplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) +{-# SPECIALIZE primalDualSimplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} +{-# SPECIALIZE primalDualSimplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} +primalDualSimplex optdir = go + where + go tbl = + case pdPivot optdir tbl of + Left PDOptimal -> assert (isFeasible tbl) $ assert (isOptimal optdir tbl) $ (True, tbl) + Left PDUnsat -> assert (not (isFeasible tbl)) $ (False, tbl) + Left PDUnbounded -> assert (not (isOptimal optdir tbl)) $ (False, tbl) + Right tbl' -> go tbl' + +pdPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> Either PDResult (Tableau r) +pdPivot optdir tbl + | null ps && null qs = Left PDOptimal -- optimal + | otherwise = + case ret of + Left p -> -- primal update + let rs = [ (i, (bi - t) / y_ip) + | (i, (row_i, bi)) <- IM.toList tbl, i /= objRowIndex + , let y_ip = IM.findWithDefault 0 p row_i, y_ip > 0 + ] + q = fst $ minimumBy (comparing snd) rs + in if null rs + then Left PDUnsat + else Right (pivot q p tbl) + Right q -> -- dual update + let (row_q, _bq) = (tbl IM.! q) + cs = [ (j, (cj'-t) / (-y_qj)) + | (j, y_qj) <- IM.toList row_q + , y_qj < 0 + , let cj = IM.findWithDefault 0 j obj + , let cj' = if optdir==OptMax then cj else -cj + ] + p = fst $ maximumBy (comparing snd) cs + (obj,_) = lookupRow objRowIndex tbl + in if null cs + then Left PDUnbounded -- dual infeasible + else Right (pivot q p tbl) + where + qs = [ (Right i, bi) | (i, (row_i, bi)) <- IM.toList tbl, i /= objRowIndex, 0 > bi ] + ps = [ (Left j, cj') + | (j,cj) <- IM.toList (fst (lookupRow objRowIndex tbl)) + , let cj' = if optdir==OptMax then cj else -cj + , 0 > cj' ] + (ret, t) = minimumBy (comparing snd) (qs ++ ps) + +-- --------------------------------------------------------------------------- + +toCSV :: (Num r, Eq r, Show r) => (r -> String) -> Tableau r -> String +toCSV showCell tbl = unlines . map (concat . intersperse ",") $ header : body + where + header :: [String] + header = "" : map colName cols ++ [""] + + body :: [[String]] + body = [showRow i (lookupRow i tbl) | i <- rows] + + rows :: [RowIndex] + rows = IM.keys (IM.delete objRowIndex tbl) ++ [objRowIndex] + + cols :: [ColIndex] + cols = [0..colMax] + where + colMax = maximum (-1 : [c | (row, _) <- IM.elems tbl, c <- IM.keys row]) + + rowName :: RowIndex -> String + rowName i = if i==objRowIndex then "obj" else "x" ++ show i + + colName :: ColIndex -> String + colName j = "x" ++ show j + + showRow i (row, row_val) = rowName i : [showCell (IM.findWithDefault 0 j row') | j <- cols] ++ [showCell row_val] + where row' = IM.insert i 1 row + +-- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Arith/Simplex2.hs b/src/ToySolver/Arith/Simplex2.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/Simplex2.hs @@ -0,0 +1,1033 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.Simplex2 +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP) +-- +-- Naïve implementation of Simplex method +-- +-- Reference: +-- +-- * +-- +-- * Bruno Dutertre and Leonardo de Moura. +-- A Fast Linear-Arithmetic Solver for DPLL(T). +-- Computer Aided Verification In Computer Aided Verification, Vol. 4144 (2006), pp. 81-94. +-- +-- +-- * Bruno Dutertre and Leonardo de Moura. +-- Integrating Simplex with DPLL(T). +-- CSL Technical Report SRI-CSL-06-01. 2006. +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.Simplex2 + ( + -- * The @Solver@ type + Solver + , GenericSolver + , SolverValue (..) + , newSolver + , cloneSolver + + -- * Problem specification + , Var + , newVar + , RelOp (..) + , (.<=.), (.>=.), (.==.), (.<.), (.>.) + , Atom (..) + , assertAtom + , assertAtomEx + , assertLower + , assertUpper + , setObj + , getObj + , OptDir (..) + , setOptDir + , getOptDir + + -- * Solving + , check + , Options (..) + , defaultOptions + , OptResult (..) + , optimize + , dualSimplex + + -- * Extract results + , Model + , getModel + , RawModel + , getRawModel + , getValue + , getObjValue + + -- * Reading status + , getTableau + , getRow + , getCol + , getCoeff + , nVars + , isBasicVariable + , isNonBasicVariable + , isFeasible + , isOptimal + , getLB + , getUB + + -- * Configulation + , setLogger + , clearLogger + , PivotStrategy (..) + , setPivotStrategy + + -- * Debug + , dump + ) where + +import Prelude hiding (log) +import Control.Exception +import Control.Monad +import Data.Default.Class +import Data.Ord +import Data.IORef +import Data.List +import Data.Maybe +import Data.Ratio +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Text.Printf +import Data.Time +import Data.OptDir +import Data.VectorSpace +import System.CPUTime + +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.LA (Atom (..)) +import ToySolver.Data.ArithRel +import ToySolver.Data.Delta +import ToySolver.Internal.Util (showRational) + +{-------------------------------------------------------------------- + The @Solver@ type +--------------------------------------------------------------------} + +type Var = Int + +data GenericSolver v + = GenericSolver + { svTableau :: !(IORef (IntMap (LA.Expr Rational))) + , svLB :: !(IORef (IntMap v)) + , svUB :: !(IORef (IntMap v)) + , svModel :: !(IORef (IntMap v)) + , svVCnt :: !(IORef Int) + , svOk :: !(IORef Bool) + , svOptDir :: !(IORef OptDir) + + , svDefDB :: !(IORef (Map (LA.Expr Rational) Var)) + + , svLogger :: !(IORef (Maybe (String -> IO ()))) + , svPivotStrategy :: !(IORef PivotStrategy) + , svNPivot :: !(IORef Int) + } + +type Solver = GenericSolver Rational + +-- special basic variable +objVar :: Int +objVar = -1 + +newSolver :: SolverValue v => IO (GenericSolver v) +newSolver = do + t <- newIORef (IntMap.singleton objVar zeroV) + l <- newIORef IntMap.empty + u <- newIORef IntMap.empty + m <- newIORef (IntMap.singleton objVar zeroV) + v <- newIORef 0 + ok <- newIORef True + dir <- newIORef OptMin + defs <- newIORef Map.empty + logger <- newIORef Nothing + pivot <- newIORef PivotStrategyBlandRule + npivot <- newIORef 0 + return $ + GenericSolver + { svTableau = t + , svLB = l + , svUB = u + , svModel = m + , svVCnt = v + , svOk = ok + , svOptDir = dir + , svDefDB = defs + , svLogger = logger + , svNPivot = npivot + , svPivotStrategy = pivot + } + +cloneSolver :: GenericSolver v -> IO (GenericSolver v) +cloneSolver solver = do + t <- newIORef =<< readIORef (svTableau solver) + l <- newIORef =<< readIORef (svLB solver) + u <- newIORef =<< readIORef (svUB solver) + m <- newIORef =<< readIORef (svModel solver) + v <- newIORef =<< readIORef (svVCnt solver) + ok <- newIORef =<< readIORef (svOk solver) + dir <- newIORef =<< readIORef (svOptDir solver) + defs <- newIORef =<< readIORef (svDefDB solver) + logger <- newIORef =<< readIORef (svLogger solver) + pivot <- newIORef =<< readIORef (svPivotStrategy solver) + npivot <- newIORef =<< readIORef (svNPivot solver) + return $ + GenericSolver + { svTableau = t + , svLB = l + , svUB = u + , svModel = m + , svVCnt = v + , svOk = ok + , svOptDir = dir + , svDefDB = defs + , svLogger = logger + , svNPivot = npivot + , svPivotStrategy = pivot + } + +class (VectorSpace v, Scalar v ~ Rational, Ord v) => SolverValue v where + toValue :: Rational -> v + showValue :: Bool -> v -> String + getModel :: GenericSolver v -> IO Model + +instance SolverValue Rational where + toValue = id + showValue = showRational + getModel = getRawModel + +instance SolverValue (Delta Rational) where + toValue = fromReal + showValue = showDelta + getModel solver = do + xs <- variables solver + ys <- liftM concat $ forM xs $ \x -> do + Delta p q <- getValue solver x + lb <- getLB solver x + ub <- getUB solver x + return $ + [(p - c) / (k - q) | Just (Delta c k) <- return lb, c < p, k > q] ++ + [(d - p) / (q - h) | Just (Delta d h) <- return ub, p < d, q > h] + let delta0 :: Rational + delta0 = if null ys then 0.1 else minimum ys + f :: Delta Rational -> Rational + f (Delta r k) = r + k * delta0 + liftM (IntMap.map f) $ readIORef (svModel solver) + +{- +Largest coefficient rule: original rule suggested by G. Dantzig. +Largest increase rule: computationally more expensive in comparison with Largest coefficient, but locally maximizes the progress. +Steepest edge rule: best pivot rule in practice, an efficient approximate implementation is "Devex". +Bland’s rule: avoids cycling but one of the slowest rules. +Random edge rule: Randomized have lead to the current best provable bounds for the number of pivot steps of the simplex method. +Lexicographic rule: used for avoiding cyclying. +-} +data PivotStrategy + = PivotStrategyBlandRule + | PivotStrategyLargestCoefficient +-- | PivotStrategySteepestEdge + deriving (Eq, Ord, Enum, Show, Read) + +setPivotStrategy :: GenericSolver v -> PivotStrategy -> IO () +setPivotStrategy solver ps = writeIORef (svPivotStrategy solver) ps + +{-------------------------------------------------------------------- + problem description +--------------------------------------------------------------------} + +newVar :: SolverValue v => GenericSolver v -> IO Var +newVar solver = do + v <- readIORef (svVCnt solver) + writeIORef (svVCnt solver) $! v+1 + modifyIORef (svModel solver) (IntMap.insert v zeroV) + return v + +assertAtom :: Solver -> LA.Atom Rational -> IO () +assertAtom solver atom = do + (v,op,rhs') <- simplifyAtom solver atom + case op of + Le -> assertUpper solver v (toValue rhs') + Ge -> assertLower solver v (toValue rhs') + Eql -> do + assertLower solver v (toValue rhs') + assertUpper solver v (toValue rhs') + _ -> error "unsupported" + return () + +assertAtomEx :: GenericSolver (Delta Rational) -> LA.Atom Rational -> IO () +assertAtomEx solver atom = do + (v,op,rhs') <- simplifyAtom solver atom + case op of + Le -> assertUpper solver v (toValue rhs') + Ge -> assertLower solver v (toValue rhs') + Lt -> assertUpper solver v (toValue rhs' ^-^ delta) + Gt -> assertLower solver v (toValue rhs' ^+^ delta) + Eql -> do + assertLower solver v (toValue rhs') + assertUpper solver v (toValue rhs') + return () + +simplifyAtom :: SolverValue v => GenericSolver v -> LA.Atom Rational -> IO (Var, RelOp, Rational) +simplifyAtom solver (ArithRel lhs op rhs) = do + let (lhs',rhs') = + case LA.extract LA.unitVar (lhs ^-^ rhs) of + (n,e) -> (e, -n) + case LA.terms lhs' of + [(1,v)] -> return (v, op, rhs') + [(-1,v)] -> return (v, flipOp op, -rhs') + _ -> do + defs <- readIORef (svDefDB solver) + let (c,lhs'') = scale lhs' -- lhs' = lhs'' / c = rhs' + rhs'' = c *^ rhs' + op'' = if c < 0 then flipOp op else op + case Map.lookup lhs'' defs of + Just v -> do + return (v,op'',rhs'') + Nothing -> do + v <- newVar solver + setRow solver v lhs'' + modifyIORef (svDefDB solver) $ Map.insert lhs'' v + return (v,op'',rhs'') + where + scale :: LA.Expr Rational -> (Rational, LA.Expr Rational) + scale e = (c, c *^ e) + where + c = c1 * c2 + c1 = fromIntegral $ foldl' lcm 1 [denominator c | (c, _) <- LA.terms e] + c2 = signum $ head ([c | (c,x) <- LA.terms e] ++ [1]) + +assertLower :: SolverValue v => GenericSolver v -> Var -> v -> IO () +assertLower solver x l = do + l0 <- getLB solver x + u0 <- getUB solver x + case (l0,u0) of + (Just l0', _) | l <= l0' -> return () + (_, Just u0') | u0' < l -> markBad solver + _ -> do + modifyIORef (svLB solver) (IntMap.insert x l) + b <- isNonBasicVariable solver x + v <- getValue solver x + when (b && not (l <= v)) $ update solver x l + checkNBFeasibility solver + +assertUpper :: SolverValue v => GenericSolver v -> Var -> v -> IO () +assertUpper solver x u = do + l0 <- getLB solver x + u0 <- getUB solver x + case (l0,u0) of + (_, Just u0') | u0' <= u -> return () + (Just l0', _) | u < l0' -> markBad solver + _ -> do + modifyIORef (svUB solver) (IntMap.insert x u) + b <- isNonBasicVariable solver x + v <- getValue solver x + when (b && not (v <= u)) $ update solver x u + checkNBFeasibility solver + +-- FIXME: 式に定数項が含まれる可能性を考えるとこれじゃまずい? +setObj :: SolverValue v => GenericSolver v -> LA.Expr Rational -> IO () +setObj solver e = setRow solver objVar e + +getObj :: SolverValue v => GenericSolver v -> IO (LA.Expr Rational) +getObj solver = getRow solver objVar + +setRow :: SolverValue v => GenericSolver v -> Var -> LA.Expr Rational -> IO () +setRow solver v e = do + modifyIORef (svTableau solver) $ \t -> + IntMap.insert v (LA.applySubst t e) t + modifyIORef (svModel solver) $ \m -> + IntMap.insert v (LA.evalLinear m (toValue 1) e) m + +setOptDir :: GenericSolver v -> OptDir -> IO () +setOptDir solver dir = writeIORef (svOptDir solver) dir + +getOptDir :: GenericSolver v -> IO OptDir +getOptDir solver = readIORef (svOptDir solver) + +{-------------------------------------------------------------------- + Status +--------------------------------------------------------------------} + +nVars :: GenericSolver v -> IO Int +nVars solver = readIORef (svVCnt solver) + +isBasicVariable :: GenericSolver v -> Var -> IO Bool +isBasicVariable solver v = do + t <- readIORef (svTableau solver) + return $ v `IntMap.member` t + +isNonBasicVariable :: GenericSolver v -> Var -> IO Bool +isNonBasicVariable solver x = liftM not (isBasicVariable solver x) + +isFeasible :: SolverValue v => GenericSolver v -> IO Bool +isFeasible solver = do + xs <- variables solver + liftM and $ forM xs $ \x -> do + v <- getValue solver x + l <- getLB solver x + u <- getUB solver x + return (testLB l v && testUB u v) + +isOptimal :: SolverValue v => GenericSolver v -> IO Bool +isOptimal solver = do + obj <- getRow solver objVar + ret <- selectEnteringVariable solver + return $! isNothing ret + +{-------------------------------------------------------------------- + Satisfiability solving +--------------------------------------------------------------------} + +check :: SolverValue v => GenericSolver v -> IO Bool +check solver = do + let + loop :: IO Bool + loop = do + m <- selectViolatingBasicVariable solver + + case m of + Nothing -> return True + Just xi -> do + li <- getLB solver xi + ui <- getUB solver xi + isLBViolated <- do + vi <- getValue solver xi + return $ not (testLB li vi) + let q = if isLBViolated + then -- select the smallest non-basic variable xj such that + -- (aij > 0 and β(xj) < uj) or (aij < 0 and β(xj) > lj) + canIncrease solver + else -- select the smallest non-basic variable xj such that + -- (aij < 0 and β(xj) < uj) or (aij > 0 and β(xj) > lj) + canDecrease solver + xi_def <- getRow solver xi + r <- liftM (fmap snd) $ findM q (LA.terms xi_def) + case r of + Nothing -> markBad solver >> return False + Just xj -> do + pivotAndUpdate solver xi xj (fromJust (if isLBViolated then li else ui)) + loop + + ok <- readIORef (svOk solver) + if not ok + then return False + else do + log solver "check" + result <- recordTime solver loop + when result $ checkFeasibility solver + return result + +selectViolatingBasicVariable :: SolverValue v => GenericSolver v -> IO (Maybe Var) +selectViolatingBasicVariable solver = do + let + p :: Var -> IO Bool + p x | x == objVar = return False + p xi = do + li <- getLB solver xi + ui <- getUB solver xi + vi <- getValue solver xi + return $ not (testLB li vi) || not (testUB ui vi) + vs <- basicVariables solver + + ps <- readIORef (svPivotStrategy solver) + case ps of + PivotStrategyBlandRule -> + findM p vs + PivotStrategyLargestCoefficient -> do + xs <- filterM p vs + case xs of + [] -> return Nothing + _ -> do + xs2 <- forM xs $ \xi -> do + vi <- getValue solver xi + li <- getLB solver xi + ui <- getUB solver xi + if not (testLB li vi) + then return (xi, fromJust li ^-^ vi) + else return (xi, vi ^-^ fromJust ui) + return $ Just $ fst $ maximumBy (comparing snd) xs2 + +{-------------------------------------------------------------------- + Optimization +--------------------------------------------------------------------} + +-- | results of optimization +data OptResult = Optimum | Unsat | Unbounded | ObjLimit + deriving (Show, Eq, Ord) + +data Options + = Options + { objLimit :: Maybe Rational + } + deriving (Show, Eq, Ord) + +instance Default Options where + def = defaultOptions + +defaultOptions :: Options +defaultOptions + = Options + { objLimit = Nothing + } + +optimize :: Solver -> Options -> IO OptResult +optimize solver opt = do + ret <- do + is_fea <- isFeasible solver + if is_fea then return True else check solver + if not ret + then return Unsat -- unsat + else do + log solver "optimize" + result <- recordTime solver loop + when (result == Optimum) $ checkOptimality solver + return result + where + loop :: IO OptResult + loop = do + checkFeasibility solver + ret <- selectEnteringVariable solver + case ret of + Nothing -> return Optimum + Just (c,xj) -> do + dir <- getOptDir solver + r <- if dir==OptMin + then if c > 0 + then decreaseNB solver xj -- xj を小さくして目的関数を小さくする + else increaseNB solver xj -- xj を大きくして目的関数を小さくする + else if c > 0 + then increaseNB solver xj -- xj を大きくして目的関数を大きくする + else decreaseNB solver xj -- xj を小さくして目的関数を大きくする + if r + then loop + else return Unbounded + +selectEnteringVariable :: SolverValue v => GenericSolver v -> IO (Maybe (Rational, Var)) +selectEnteringVariable solver = do + ps <- readIORef (svPivotStrategy solver) + obj_def <- getRow solver objVar + case ps of + PivotStrategyBlandRule -> + findM canEnter (LA.terms obj_def) + PivotStrategyLargestCoefficient -> do + ts <- filterM canEnter (LA.terms obj_def) + case ts of + [] -> return Nothing + _ -> return $ Just $ snd $ maximumBy (comparing fst) [(abs c, (c,xj)) | (c,xj) <- ts] + where + canEnter :: (Rational, Var) -> IO Bool + canEnter (_,xj) | xj == LA.unitVar = return False + canEnter (c,xj) = do + dir <- getOptDir solver + if dir==OptMin + then canDecrease solver (c,xj) + else canIncrease solver (c,xj) + +canIncrease :: SolverValue v => GenericSolver v -> (Rational,Var) -> IO Bool +canIncrease solver (a,x) = + case compare a 0 of + EQ -> return False + GT -> canIncrease1 solver x + LT -> canDecrease1 solver x + +canDecrease :: SolverValue v => GenericSolver v -> (Rational,Var) -> IO Bool +canDecrease solver (a,x) = + case compare a 0 of + EQ -> return False + GT -> canDecrease1 solver x + LT -> canIncrease1 solver x + +canIncrease1 :: SolverValue v => GenericSolver v -> Var -> IO Bool +canIncrease1 solver x = do + u <- getUB solver x + v <- getValue solver x + case u of + Nothing -> return True + Just uv -> return $! (v < uv) + +canDecrease1 :: SolverValue v => GenericSolver v -> Var -> IO Bool +canDecrease1 solver x = do + l <- getLB solver x + v <- getValue solver x + case l of + Nothing -> return True + Just lv -> return $! (lv < v) + +-- | feasibility を保ちつつ non-basic variable xj の値を大きくする +increaseNB :: Solver -> Var -> IO Bool +increaseNB solver xj = do + col <- getCol solver xj + + -- Upper bounds of θ + -- NOTE: xj 自体の上限も考慮するのに注意 + ubs <- liftM concat $ forM ((xj,1) : IntMap.toList col) $ \(xi,aij) -> do + v1 <- getValue solver xi + li <- getLB solver xi + ui <- getUB solver xi + return [ assert (theta >= zeroV) ((xi,v2), theta) + | Just v2 <- [ui | aij > 0] ++ [li | aij < 0] + , let theta = (v2 ^-^ v1) ^/ aij ] + + -- β(xj) := β(xj) + θ なので θ を大きく + case ubs of + [] -> return False -- unbounded + _ -> do + let (xi, v) = fst $ minimumBy (comparing snd) ubs + pivotAndUpdate solver xi xj v + return True + +-- | feasibility を保ちつつ non-basic variable xj の値を小さくする +decreaseNB :: Solver -> Var -> IO Bool +decreaseNB solver xj = do + col <- getCol solver xj + + -- Lower bounds of θ + -- NOTE: xj 自体の下限も考慮するのに注意 + lbs <- liftM concat $ forM ((xj,1) : IntMap.toList col) $ \(xi,aij) -> do + v1 <- getValue solver xi + li <- getLB solver xi + ui <- getUB solver xi + return [ assert (theta <= zeroV) ((xi,v2), theta) + | Just v2 <- [li | aij > 0] ++ [ui | aij < 0] + , let theta = (v2 ^-^ v1) ^/ aij ] + + -- β(xj) := β(xj) + θ なので θ を小さく + case lbs of + [] -> return False -- unbounded + _ -> do + let (xi, v) = fst $ maximumBy (comparing snd) lbs + pivotAndUpdate solver xi xj v + return True + +dualSimplex :: Solver -> Options -> IO OptResult +dualSimplex solver opt = do + let + loop :: IO OptResult + loop = do + checkOptimality solver + + p <- prune solver opt + if p + then return ObjLimit + else do + m <- selectViolatingBasicVariable solver + case m of + Nothing -> return Optimum + Just xi -> do + xi_def <- getRow solver xi + li <- getLB solver xi + ui <- getUB solver xi + isLBViolated <- do + vi <- getValue solver xi + return $ not (testLB li vi) + r <- dualRTest solver xi_def isLBViolated + case r of + Nothing -> markBad solver >> return Unsat -- dual unbounded + Just xj -> do + pivotAndUpdate solver xi xj (fromJust (if isLBViolated then li else ui)) + loop + + ok <- readIORef (svOk solver) + if not ok + then return Unsat + else do + log solver "dual simplex" + result <- recordTime solver loop + when (result == Optimum) $ checkFeasibility solver + return result + +dualRTest :: Solver -> LA.Expr Rational -> Bool -> IO (Maybe Var) +dualRTest solver row isLBViolated = do + -- normalize to the cases of minimization + obj_def <- do + def <- getRow solver objVar + dir <- getOptDir solver + return $ + case dir of + OptMin -> def + OptMax -> negateV def + -- normalize to the cases of lower bound violation + let xi_def = + if isLBViolated + then row + else negateV row + ws <- do + -- select non-basic variable xj such that + -- (aij > 0 and β(xj) < uj) or (aij < 0 and β(xj) > lj) + liftM concat $ forM (LA.terms xi_def) $ \(aij, xj) -> do + b <- canIncrease solver (aij, xj) + if b + then do + let cj = LA.coeff xj obj_def + let ratio = cj / aij + return [(xj, ratio) | ratio >= 0] + else + return [] + case ws of + [] -> return Nothing + _ -> return $ Just $ fst $ minimumBy (comparing snd) ws + +prune :: Solver -> Options -> IO Bool +prune solver opt = + case objLimit opt of + Nothing -> return False + Just lim -> do + o <- getObjValue solver + dir <- getOptDir solver + case dir of + OptMin -> return $! (lim <= o) + OptMax -> return $! (lim >= o) + +{-------------------------------------------------------------------- + Extract results +--------------------------------------------------------------------} + +type RawModel v = IntMap v + +getRawModel :: GenericSolver v -> IO (RawModel v) +getRawModel solver = do + xs <- variables solver + liftM IntMap.fromList $ forM xs $ \x -> do + val <- getValue solver x + return (x,val) + +getObjValue :: GenericSolver v -> IO v +getObjValue solver = getValue solver objVar + +type Model = IntMap Rational + +{-------------------------------------------------------------------- + major function +--------------------------------------------------------------------} + +update :: SolverValue v => GenericSolver v -> Var -> v -> IO () +update solver xj v = do + -- log solver $ printf "before update x%d (%s)" xj (show v) + -- dump solver + + v0 <- getValue solver xj + let diff = v ^-^ v0 + + aj <- getCol solver xj + modifyIORef (svModel solver) $ \m -> + let m2 = IntMap.map (\aij -> aij *^ diff) aj + in IntMap.insert xj v $ IntMap.unionWith (^+^) m2 m + + -- log solver $ printf "after update x%d (%s)" xj (show v) + -- dump solver + +pivot :: SolverValue v => GenericSolver v -> Var -> Var -> IO () +pivot solver xi xj = do + modifyIORef' (svNPivot solver) (+1) + modifyIORef' (svTableau solver) $ \defs -> + case LA.solveFor (LA.var xi .==. (defs IntMap.! xi)) xj of + Just (Eql, xj_def) -> + IntMap.insert xj xj_def . IntMap.map (LA.applySubst1 xj xj_def) . IntMap.delete xi $ defs + _ -> error "pivot: should not happen" + +pivotAndUpdate :: SolverValue v => GenericSolver v -> Var -> Var -> v -> IO () +pivotAndUpdate solver xi xj v | xi == xj = update solver xi v -- xi = xj is non-basic variable +pivotAndUpdate solver xi xj v = do + -- xi is basic variable + -- xj is non-basic varaible + + -- log solver $ printf "before pivotAndUpdate x%d x%d (%s)" xi xj (show v) + -- dump solver + + m <- readIORef (svModel solver) + + aj <- getCol solver xj + let aij = aj IntMap.! xi + let theta = (v ^-^ (m IntMap.! xi)) ^/ aij + + let m' = IntMap.fromList $ + [(xi, v), (xj, (m IntMap.! xj) ^+^ theta)] ++ + [(xk, (m IntMap.! xk) ^+^ (akj *^ theta)) | (xk, akj) <- IntMap.toList aj, xk /= xi] + writeIORef (svModel solver) (IntMap.union m' m) -- note that 'IntMap.union' is left biased. + + pivot solver xi xj + + -- log solver $ printf "after pivotAndUpdate x%d x%d (%s)" xi xj (show v) + -- dump solver + +getLB :: GenericSolver v -> Var -> IO (Maybe v) +getLB solver x = do + lb <- readIORef (svLB solver) + return $ IntMap.lookup x lb + +getUB :: GenericSolver v -> Var -> IO (Maybe v) +getUB solver x = do + ub <- readIORef (svUB solver) + return $ IntMap.lookup x ub + +getTableau :: GenericSolver v -> IO (IntMap (LA.Expr Rational)) +getTableau solver = do + t <- readIORef (svTableau solver) + return $ IntMap.delete objVar t + +getValue :: GenericSolver v -> Var -> IO v +getValue solver x = do + m <- readIORef (svModel solver) + return $ m IntMap.! x + +getRow :: GenericSolver v -> Var -> IO (LA.Expr Rational) +getRow solver x = do + -- x should be basic variable or 'objVar' + t <- readIORef (svTableau solver) + return $! (t IntMap.! x) + +-- aijが非ゼロの列も全部探しているのは効率が悪い +getCol :: SolverValue v => GenericSolver v -> Var -> IO (IntMap Rational) +getCol solver xj = do + t <- readIORef (svTableau solver) + return $ IntMap.mapMaybe (LA.lookupCoeff xj) t + +getCoeff :: GenericSolver v -> Var -> Var -> IO Rational +getCoeff solver xi xj = do + xi_def <- getRow solver xi + return $! LA.coeff xj xi_def + +markBad :: GenericSolver v -> IO () +markBad solver = writeIORef (svOk solver) False + +{-------------------------------------------------------------------- + utility +--------------------------------------------------------------------} + +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM _ [] = return Nothing +findM p (x:xs) = do + r <- p x + if r + then return (Just x) + else findM p xs + +testLB :: SolverValue v => Maybe v -> v -> Bool +testLB Nothing _ = True +testLB (Just l) x = l <= x + +testUB :: SolverValue v => Maybe v -> v -> Bool +testUB Nothing _ = True +testUB (Just u) x = x <= u + +variables :: GenericSolver v -> IO [Var] +variables solver = do + vcnt <- nVars solver + return [0..vcnt-1] + +basicVariables :: GenericSolver v -> IO [Var] +basicVariables solver = do + t <- readIORef (svTableau solver) + return (IntMap.keys t) + +#if !MIN_VERSION_base(4,6,0) + +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + writeIORef ref $! f x + +#endif + +recordTime :: SolverValue v => GenericSolver v -> IO a -> IO a +recordTime solver act = do + dumpSize solver + writeIORef (svNPivot solver) 0 + + startCPU <- getCPUTime + startWC <- getCurrentTime + + result <- act + + endCPU <- getCPUTime + endWC <- getCurrentTime + + (log solver . printf "cpu time = %.3fs") (fromIntegral (endCPU - startCPU) / 10^(12::Int) :: Double) + (log solver . printf "wall clock time = %.3fs") (realToFrac (endWC `diffUTCTime` startWC) :: Double) + (log solver . printf "#pivot = %d") =<< readIORef (svNPivot solver) + return result + +showDelta :: Bool -> Delta Rational -> String +showDelta asRatio v = + case v of + (Delta r k) -> + f r ++ + case compare k 0 of + EQ -> "" + GT -> " + " ++ f k ++ " delta" + LT -> " - " ++ f (abs k) ++ " delta" + where + f = showRational asRatio + +{-------------------------------------------------------------------- + Logging +--------------------------------------------------------------------} + +-- | set callback function for receiving messages. +setLogger :: GenericSolver v -> (String -> IO ()) -> IO () +setLogger solver logger = do + writeIORef (svLogger solver) (Just logger) + +clearLogger :: GenericSolver v -> IO () +clearLogger solver = writeIORef (svLogger solver) Nothing + +log :: GenericSolver v -> String -> IO () +log solver msg = logIO solver (return msg) + +logIO :: GenericSolver v -> IO String -> IO () +logIO solver action = do + m <- readIORef (svLogger solver) + case m of + Nothing -> return () + Just logger -> action >>= logger + +{-------------------------------------------------------------------- + debug and tests +--------------------------------------------------------------------} + +test4 :: IO () +test4 = do + solver <- newSolver + setLogger solver putStrLn + x0 <- newVar solver + x1 <- newVar solver + + writeIORef (svTableau solver) (IntMap.fromList [(x1, LA.var x0)]) + writeIORef (svLB solver) (IntMap.fromList [(x0, toValue 0), (x1, toValue 0)]) + writeIORef (svUB solver) (IntMap.fromList [(x0, toValue 2), (x1, toValue 3)]) + setObj solver (LA.fromTerms [(-1, x0)]) + + ret <- optimize solver def + print ret + dump solver + +test5 :: IO () +test5 = do + solver <- newSolver + setLogger solver putStrLn + x0 <- newVar solver + x1 <- newVar solver + + writeIORef (svTableau solver) (IntMap.fromList [(x1, LA.var x0)]) + writeIORef (svLB solver) (IntMap.fromList [(x0, toValue 0), (x1, toValue 0)]) + writeIORef (svUB solver) (IntMap.fromList [(x0, toValue 2), (x1, toValue 0)]) + setObj solver (LA.fromTerms [(-1, x0)]) + + checkFeasibility solver + + ret <- optimize solver def + print ret + dump solver + +test6 :: IO () +test6 = do + solver <- newSolver + setLogger solver putStrLn + x0 <- newVar solver + + assertAtom solver (LA.constant 1 .<. LA.var x0) + assertAtom solver (LA.constant 2 .>. LA.var x0) + + ret <- check solver + print ret + dump solver + + m <- getModel solver + print m + +dumpSize :: SolverValue v => GenericSolver v -> IO () +dumpSize solver = do + t <- readIORef (svTableau solver) + let nrows = IntMap.size t - 1 -- -1 is objVar + xs <- variables solver + let ncols = length xs - nrows + let nnz = sum [IntMap.size $ LA.coeffMap xi_def | (xi,xi_def) <- IntMap.toList t, xi /= objVar] + log solver $ printf "%d rows, %d columns, %d non-zeros" nrows ncols nnz + +dump :: SolverValue v => GenericSolver v -> IO () +dump solver = do + log solver "=============" + + log solver "Tableau:" + t <- readIORef (svTableau solver) + log solver $ printf "obj = %s" (show (t IntMap.! objVar)) + forM_ (IntMap.toList t) $ \(xi, e) -> do + when (xi /= objVar) $ log solver $ printf "x%d = %s" xi (show e) + + log solver "" + + log solver "Assignments and Bounds:" + objVal <- getValue solver objVar + log solver $ printf "beta(obj) = %s" (showValue True objVal) + xs <- variables solver + forM_ xs $ \x -> do + l <- getLB solver x + u <- getUB solver x + v <- getValue solver x + let f Nothing = "Nothing" + f (Just x) = showValue True x + log solver $ printf "beta(x%d) = %s; %s <= x%d <= %s" x (showValue True v) (f l) x (f u) + + log solver "" + log solver "Status:" + is_fea <- isFeasible solver + is_opt <- isOptimal solver + log solver $ printf "Feasible: %s" (show is_fea) + log solver $ printf "Optimal: %s" (show is_opt) + + log solver "=============" + +checkFeasibility :: SolverValue v => GenericSolver v -> IO () +checkFeasibility _ | True = return () +checkFeasibility solver = do + xs <- variables solver + forM_ xs $ \x -> do + v <- getValue solver x + l <- getLB solver x + u <- getUB solver x + let f Nothing = "Nothing" + f (Just x) = showValue True x + unless (testLB l v) $ + error (printf "(%s) <= x%d is violated; x%d = (%s)" (f l) x x (showValue True v)) + unless (testUB u v) $ + error (printf "x%d <= (%s) is violated; x%d = (%s)" x (f u) x (showValue True v)) + return () + +checkNBFeasibility :: SolverValue v => GenericSolver v -> IO () +checkNBFeasibility _ | True = return () +checkNBFeasibility solver = do + xs <- variables solver + forM_ xs $ \x -> do + b <- isNonBasicVariable solver x + when b $ do + v <- getValue solver x + l <- getLB solver x + u <- getUB solver x + let f Nothing = "Nothing" + f (Just x) = showValue True x + unless (testLB l v) $ + error (printf "checkNBFeasibility: (%s) <= x%d is violated; x%d = (%s)" (f l) x x (showValue True v)) + unless (testUB u v) $ + error (printf "checkNBFeasibility: x%d <= (%s) is violated; x%d = (%s)" x (f u) x (showValue True v)) + +checkOptimality :: Solver -> IO () +checkOptimality _ | True = return () +checkOptimality solver = do + ret <- selectEnteringVariable solver + case ret of + Nothing -> return () -- optimal + Just (_,x) -> error (printf "checkOptimality: not optimal (x%d can be changed)" x) diff --git a/src/ToySolver/Arith/VirtualSubstitution.hs b/src/ToySolver/Arith/VirtualSubstitution.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Arith/VirtualSubstitution.hs @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.VirtualSubstitution +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Naive implementation of virtual substitution +-- +-- Reference: +-- +-- * V. Weispfenning. The complexity of linear problems in fields. +-- Journal of Symbolic Computation, 5(1-2): 3-27, Feb.-Apr. 1988. +-- +-- * Hirokazu Anai, Shinji Hara. Parametric Robust Control by Quantifier Elimination. +-- J.JSSAC, Vol. 10, No. 1, pp. 41-51, 2003. +-- +----------------------------------------------------------------------------- +module ToySolver.Arith.VirtualSubstitution + ( QFFormula + , evalQFFormula + + -- * Projection + , project + , projectN + , projectCases + , projectCasesN + + -- * Constraint solving + , solve + , solveQFFormula + ) where + +import Control.Exception +import Control.Monad +import qualified Data.Foldable as Foldable +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Maybe +import Data.VectorSpace hiding (project) + +import ToySolver.Data.ArithRel +import ToySolver.Data.Boolean +import ToySolver.Data.BoolExpr (BoolExpr (..)) +import qualified ToySolver.Data.BoolExpr as BoolExpr +import qualified ToySolver.Data.LA as LA +import ToySolver.Data.Var + +-- | Quantifier-free formula of LRA +type QFFormula = BoolExpr (LA.Atom Rational) + +-- | @'evalQFFormula' M φ@ returns whether @M ⊧_LRA φ@ or not. +evalQFFormula :: Model Rational -> QFFormula -> Bool +evalQFFormula m = BoolExpr.fold f + where + f (ArithRel lhs op rhs) = evalOp op (LA.evalExpr m lhs) (LA.evalExpr m rhs) + +{-| @'project' x φ@ returns @(ψ, lift)@ such that: + +* @⊢_LRA ∀y1, …, yn. (∃x. φ) ↔ ψ@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LRA ψ@ then @lift M ⊧ φ@. +-} +project :: Var -> QFFormula -> (QFFormula, Model Rational -> Model Rational) +project x formula = (formula', mt) + where + xs = projectCases x formula + formula' = orB' [phi | (phi,_) <- xs] + mt m = head $ do + (phi, mt') <- xs + guard $ evalQFFormula m phi + return $ mt' m + orB' = orB . concatMap f + where + f (Or xs) = concatMap f xs + f x = [x] + +{-| @'projectN' {x1,…,xm} φ@ returns @(ψ, lift)@ such that: + +* @⊢_LRA ∀y1, …, yn. (∃x1, …, xm. φ) ↔ ψ@ where @{y1, …, yn} = FV(φ) \\ {x1,…,xm}@, and + +* if @M ⊧_LRA ψ@ then @lift M ⊧_LRA φ@. +-} +projectN :: VarSet -> QFFormula -> (QFFormula, Model Rational -> Model Rational) +projectN vs2 = f (IS.toList vs2) + where + f :: [Var] -> QFFormula -> (QFFormula, Model Rational -> Model Rational) + f [] formula = (formula, id) + f (v:vs) formula = (formula3, mt1 . mt2) + where + (formula2, mt1) = project v formula + (formula3, mt2) = f vs formula2 + +{-| @'projectCases' x φ@ returns @[(ψ_1, lift_1), …, (ψ_m, lift_m)]@ such that: + +* @⊢_LRA ∀y1, …, yn. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_m)@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. +-} +projectCases :: Var -> QFFormula -> [(QFFormula, Model Rational -> Model Rational)] +projectCases v phi = [(psi, \m -> IM.insert v (LA.evalExpr m t) m) | (psi, t) <- projectCases' v phi] + +{-| @'projectCases' x φ@ returns @[(ψ_1, lift_1), …, (ψ_m, lift_m)]@ such that: + +* @⊢_LRA ∀y1, …, yn. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_m)@ where @{y1, …, yn} = FV(φ) \\ {x}@, and + +* if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. + +Note that + +> (∃x. φ(x)) ⇔ ∨_{t∈S} φ(t) +> where +> Ψ = {a_i x - b_i ρ_i 0 | i ∈ I, ρ_i ∈ {=, ≠, ≤, <}} the set of atomic subformulas in φ(x) +> S = { b_i / a_i, b_i / a_i + 1, b_i / a_i - 1 | i∈I } ∪ {1/2 (b_i / a_i + b_j / a_j) | i,j∈I, i≠j} +-} +projectCases' :: Var -> QFFormula -> [(QFFormula, LA.Expr Rational)] +projectCases' v phi + | phi' == false = [] + | Set.null xs = [(phi', LA.constant 0)] + | otherwise = [(phi'', t) | t <- Set.toList s, let phi'' = applySubst1 v t phi', phi'' /= false] + where + phi' = simplify phi + xs = collect v phi' + s = Set.unions + [ xs + , Set.fromList [e ^+^ LA.constant 1 | e <- Set.toList xs] + , Set.fromList [e ^-^ LA.constant 1 | e <- Set.toList xs] + , Set.fromList [(e1 ^+^ e2) ^/ 2 | (e1,e2) <- pairs (Set.toList xs)] + ] + +{-| @'projectCasesN' {x1,…,xm} φ@ returns @[(ψ_1, lift_1), …, (ψ_n, lift_n)]@ such that: + +* @⊢_LRA ∀y1, …, yp. (∃x. φ) ↔ (ψ_1 ∨ … ∨ φ_n)@ where @{y1, …, yp} = FV(φ) \\ {x1,…,xm}@, and + +* if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. +-} +projectCasesN :: VarSet -> QFFormula -> [(QFFormula, Model Rational -> Model Rational)] +projectCasesN vs = f (IS.toList vs) + where + f [] phi = return (phi, id) + f (v:vs) phi = do + (phi2, mt1) <- projectCases v phi + (phi3, mt2) <- f vs phi2 + return (phi3, mt1 . mt2) + +simplify :: QFFormula -> QFFormula +simplify = BoolExpr.simplify . BoolExpr.fold simplifyLit + +simplifyLit :: LA.Atom Rational -> QFFormula +simplifyLit (ArithRel lhs op rhs) = + case LA.asConst e of + Just c -> if evalOp op c 0 then true else false + Nothing -> Atom (ArithRel e op (LA.constant 0)) + where + e = lhs ^-^ rhs + +collect :: Var -> QFFormula -> Set (LA.Expr Rational) +collect v = Foldable.foldMap f + where + f (ArithRel lhs _ rhs) = assert (rhs == LA.constant 0) $ + case LA.extractMaybe v lhs of + Nothing -> Set.empty + Just (a,b) -> Set.singleton (negateV (b ^/ a)) + +applySubst1 :: Var -> LA.Expr Rational -> QFFormula -> QFFormula +applySubst1 v t = BoolExpr.fold f + where + f rel = Atom (LA.applySubst1Atom v t rel) + +pairs :: [a] -> [(a,a)] +pairs [] = [] +pairs (x:xs) = [(x,x2) | x2 <- xs] ++ pairs xs + +-- | @'solveQFFormula' {x1,…,xn} φ@ returns @Just M@ such that @M ⊧_LRA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solveQFFormula :: VarSet -> QFFormula -> Maybe (Model Rational) +solveQFFormula vs formula = listToMaybe $ do + (formula2, mt) <- projectCasesN vs formula + let m = IM.empty + guard $ evalQFFormula m formula2 + return $ mt m + +-- | @'solve' {x1,…,xn} φ@ returns @Just M@ such that @M ⊧_LRA φ@ when +-- such @M@ exists, returns @Nothing@ otherwise. +-- +-- @FV(φ)@ must be a subset of @{x1,…,xn}@. +-- +solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Rational) +solve vs cs = solveQFFormula vs (andB [Atom c | c <- cs]) diff --git a/src/ToySolver/BoundsInference.hs b/src/ToySolver/BoundsInference.hs deleted file mode 100644 --- a/src/ToySolver/BoundsInference.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.BoundsInference --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns) --- --- Tightening variable bounds by constraint propagation. --- ------------------------------------------------------------------------------ -module ToySolver.BoundsInference - ( BoundsEnv - , inferBounds - , LA.computeInterval - ) where - -import Control.Monad -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.VectorSpace -import Data.Interval - -import ToySolver.Data.ArithRel -import ToySolver.Data.LA (BoundsEnv) -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import ToySolver.Internal.Util (isInteger) - -type C r = (RelOp, LA.Expr r) - --- | tightening variable bounds by constraint propagation. -inferBounds :: forall r. (RealFrac r) - => LA.BoundsEnv r -- ^ initial bounds - -> [LA.Atom r] -- ^ constraints - -> VarSet -- ^ integral variables - -> Int -- ^ limit of iterations - -> LA.BoundsEnv r -inferBounds bounds constraints ivs limit = loop 0 bounds - where - cs :: VarMap [C r] - cs = IM.fromListWith (++) $ do - Rel lhs op rhs <- constraints - let m = LA.coeffMap (lhs ^-^ rhs) - (v,c) <- IM.toList m - guard $ v /= LA.unitVar - let op' = if c < 0 then flipOp op else op - rhs' = (-1/c) *^ LA.fromCoeffMap (IM.delete v m) - return (v, [(op', rhs')]) - - loop :: Int -> LA.BoundsEnv r -> LA.BoundsEnv r - loop !i b = if (limit>=0 && i>=limit) || b==b' then b else loop (i+1) b' - where - b' = refine b - - refine :: LA.BoundsEnv r -> LA.BoundsEnv r - refine b = IM.mapWithKey (\v i -> tighten v $ f b (IM.findWithDefault [] v cs) i) b - - -- tighten bounds of integer variables - tighten :: Var -> Interval r -> Interval r - tighten v x = - if v `IS.notMember` ivs - then x - else tightenToInteger x - -f :: (Real r, Fractional r) => LA.BoundsEnv r -> [C r] -> Interval r -> Interval r -f b cs i = foldr intersection i $ do - (op, rhs) <- cs - let i' = LA.computeInterval b rhs - lb = lowerBound' i' - ub = upperBound' i' - case op of - Eql -> return i' - Le -> return $ interval (NegInf, False) ub - Ge -> return $ interval lb (PosInf, False) - Lt -> return $ interval (NegInf, False) (strict ub) - Gt -> return $ interval (strict ub) (PosInf, False) - NEq -> [] - -strict :: (EndPoint r, Bool) -> (EndPoint r, Bool) -strict (x, _) = (x, False) - --- | tightening intervals by ceiling lower bounds and flooring upper bounds. -tightenToInteger :: forall r. (RealFrac r) => Interval r -> Interval r -tightenToInteger ival = interval lb2 ub2 - where - lb@(x1, in1) = lowerBound' ival - ub@(x2, in2) = upperBound' ival - lb2 = - case x1 of - Finite x -> - ( if isInteger x && not in1 - then Finite (x + 1) - else Finite (fromInteger (ceiling x)) - , True - ) - _ -> lb - ub2 = - case x2 of - Finite x -> - ( if isInteger x && not in2 - then Finite (x - 1) - else Finite (fromInteger (floor x)) - , True - ) - _ -> ub diff --git a/src/ToySolver/CAD.hs b/src/ToySolver/CAD.hs deleted file mode 100644 --- a/src/ToySolver/CAD.hs +++ /dev/null @@ -1,667 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.CAD --- Copyright : (c) Masahiro Sakai 2012 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns) --- --- References: --- --- * Christian Michaux and Adem Ozturk. --- Quantifier Elimination following Muchnik --- --- --- * Arnab Bhattacharyya. --- Something you should know about: Quantifier Elimination (Part I) --- --- --- * Arnab Bhattacharyya. --- Something you should know about: Quantifier Elimination (Part II) --- --- ------------------------------------------------------------------------------ -module ToySolver.CAD - ( - -- * Basic data structures - Point (..) - , Cell (..) - - -- * Projection - , project - - -- * Solving - , solve - , solve' - - -- * Model - , Model - , findSample - , evalCell - , evalPoint - ) where - -import Control.Exception -import Control.Monad.State -import Data.List -import Data.Maybe -import Data.Ord -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Text.Printf -import Text.PrettyPrint.HughesPJClass - -import qualified Data.Interval as I -import Data.Sign (Sign (..)) -import qualified Data.Sign as Sign - -import ToySolver.Data.ArithRel -import qualified ToySolver.Data.AlgebraicNumber.Real as AReal -import ToySolver.Data.DNF -import ToySolver.Data.Polynomial (Polynomial, UPolynomial, X (..), PrettyVar, PrettyCoeff) -import qualified ToySolver.Data.Polynomial as P -import qualified ToySolver.Data.Polynomial.GroebnerBasis as GB - -import Debug.Trace - --- --------------------------------------------------------------------------- - -data Point c = NegInf | RootOf (UPolynomial c) Int | PosInf - deriving (Eq, Ord, Show) - -data Cell c - = Point (Point c) - | Interval (Point c) (Point c) - deriving (Eq, Ord, Show) - -showCell :: (Num c, Ord c, PrettyCoeff c) => Cell c -> String -showCell (Point pt) = showPoint pt -showCell (Interval lb ub) = printf "(%s, %s)" (showPoint lb) (showPoint ub) - -showPoint :: (Num c, Ord c, PrettyCoeff c) => Point c -> String -showPoint NegInf = "-inf" -showPoint PosInf = "+inf" -showPoint (RootOf p n) = "rootOf(" ++ prettyShow p ++ ", " ++ show n ++ ")" - --- --------------------------------------------------------------------------- - -type SignConf c = [(Cell c, Map (UPolynomial c) Sign)] - -emptySignConf :: SignConf c -emptySignConf = - [ (Point NegInf, Map.empty) - , (Interval NegInf PosInf, Map.empty) - , (Point PosInf, Map.empty) - ] - -showSignConf :: forall c. (Num c, Ord c, PrettyCoeff c) => SignConf c -> [String] -showSignConf = f - where - f :: SignConf c -> [String] - f = concatMap $ \(cell, m) -> showCell cell : g m - - g :: Map (UPolynomial c) Sign -> [String] - g m = - [printf " %s: %s" (prettyShow p) (Sign.symbol s) | (p, s) <- Map.toList m] - -normalizeSignConfKey :: Ord v => UPolynomial (Polynomial Rational v) -> UPolynomial (Polynomial Rational v) -normalizeSignConfKey p - | p == 0 = 0 - | otherwise = q - where - c = P.lc P.grevlex $ P.lc P.nat p - q = P.mapCoeff (P.mapCoeff (/ c)) p - -lookupSignConf :: Ord v => UPolynomial (Polynomial Rational v) -> Map (UPolynomial (Polynomial Rational v)) Sign -> Sign -lookupSignConf p m - | p == 0 = Zero - | otherwise = Sign.signOf c `Sign.mult` (m Map.! q) - where - c = P.lc P.grevlex $ P.lc P.nat p - q = P.mapCoeff (P.mapCoeff (/ c)) p - --- --------------------------------------------------------------------------- - --- modified reminder -mr - :: forall k. (Ord k, Show k, Num k, PrettyCoeff k) - => UPolynomial k - -> UPolynomial k - -> (k, Integer, UPolynomial k) -mr p q - | n >= m = assert (P.constant (bm^(n-m+1)) * p == q * l + r && m > P.deg r) $ (bm, n-m+1, r) - | otherwise = error "mr p q: not (deg p >= deg q)" - where - x = P.var X - n = P.deg p - m = P.deg q - bm = P.lc P.nat q - (l,r) = f p n - - f :: UPolynomial k -> Integer -> (UPolynomial k, UPolynomial k) - f p n - | n==m = - let l = P.constant an - r = P.constant bm * p - P.constant an * q - in assert (P.constant (bm^(n-m+1)) * p == q*l + r && m > P.deg r) $ (l, r) - | otherwise = - let p' = (P.constant bm * p - P.constant an * x^(n-m) * q) - (l',r) = f p' (n-1) - l = l' + P.constant (an*bm^(n-m)) * x^(n-m) - in assert (n > P.deg p') $ - assert (P.constant (bm^(n-m+1)) * p == q*l + r && m > P.deg r) $ (l, r) - where - an = P.coeff (P.var X `P.mpow` n) p - -test_mr_1 :: (Coeff Int, Integer, UPolynomial (Coeff Int)) -test_mr_1 = mr (P.toUPolynomialOf p 3) (P.toUPolynomialOf q 3) - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - x = P.var 3 - p = a*x^(2::Int) + b*x + c - q = 2*a*x + b - -test_mr_2 :: (Coeff Int, Integer, UPolynomial (Coeff Int)) -test_mr_2 = mr (P.toUPolynomialOf p 3) (P.toUPolynomialOf p 3) - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - x = P.var 3 - p = a*x^(2::Int) + b*x + c - --- --------------------------------------------------------------------------- - -type Coeff v = Polynomial Rational v - -type M v = StateT (Assumption v) [] - -runM :: M v a -> [(a, Assumption v)] -runM m = runStateT m emptyAssumption - -assume :: (Ord v, Show v, PrettyVar v) => Polynomial Rational v -> [Sign] -> M v () -assume p ss = do - (m,gb) <- get - p <- return $ P.reduce P.grevlex p gb - ss <- return $ Set.fromList ss - ss <- return $ ss `Set.intersection` computeSignSet m p - guard $ not $ Set.null ss - when (P.deg p > 0) $ do - let c = P.lc P.grlex p - (p,ss) <- return $ (P.mapCoeff (/c) p, Set.map (\s -> s `Sign.div` Sign.signOf c) ss) - let ss_orig = Map.findWithDefault (Set.fromList [Neg,Zero,Pos]) p m - ss <- return $ Set.intersection ss ss_orig - guard $ not $ Set.null ss - case propagate (Map.insertWith Set.intersection p ss m, gb) of - Nothing -> mzero - Just a -> put a - -project - :: forall v. (Ord v, Show v, PrettyVar v) - => [(UPolynomial (Polynomial Rational v), [Sign])] - -> [([(Polynomial Rational v, [Sign])], [Cell (Polynomial Rational v)])] -project cs = [ (assumption2cond gs, cells) | (cells, gs) <- result ] - where - result :: [([Cell (Polynomial Rational v)], Assumption v)] - result = runM $ do - forM_ cs $ \(p,ss) -> do - when (1 > P.deg p) $ assume (P.coeff P.mone p) ss - conf <- buildSignConf (map fst cs) - -- normalizePoly前に次数が1以上で、normalizePoly結果の次数が0以下の時のための処理が必要なので注意 - cs' <- liftM catMaybes $ forM cs $ \(p,ss) -> do - p' <- normalizePoly p - if (1 > P.deg p') - then assume (P.coeff P.mone p') ss >> return Nothing - else return $ Just (p',ss) - let satCells = [cell | (cell, m) <- conf, cell /= Point NegInf, cell /= Point PosInf, ok cs' m] - guard $ not $ null satCells - return satCells - - ok :: [(UPolynomial (Polynomial Rational v), [Sign])] -> Map (UPolynomial (Polynomial Rational v)) Sign -> Bool - ok cs m = and [checkSign m p ss | (p,ss) <- cs] - where - checkSign m p ss = lookupSignConf p m `elem` ss - -buildSignConf - :: (Ord v, Show v, PrettyVar v) - => [UPolynomial (Polynomial Rational v)] - -> M v (SignConf (Polynomial Rational v)) -buildSignConf ps = do - ps2 <- collectPolynomials ps - -- normalizePoly後の多項式の次数でソートしておく必要があるので注意 - let ts = sortBy (comparing P.deg) ps2 - --trace ("collected polynomials: " ++ prettyShow ts) $ return () - foldM (flip refineSignConf) emptySignConf ts - -collectPolynomials - :: (Ord v, Show v, PrettyVar v) - => [UPolynomial (Polynomial Rational v)] - -> M v [UPolynomial (Polynomial Rational v)] -collectPolynomials ps = go Set.empty =<< f ps - where - f ps = do - ps' <- mapM normalizePoly $ Set.toList $ Set.fromList $ [p | p <- ps, P.deg p > 0] - return $ Set.fromList $ map normalizeSignConfKey $ filter (\p -> P.deg p > 0) ps' - - go result ps | Set.null ps = return $ Set.toList result - go result ps = do - rs <- f [P.deriv p X | p <- Set.toList ps] - rss <- - forM [(p1,p2) | p1 <- Set.toList ps, p2 <- Set.toList ps ++ Set.toList result, p1 /= p2] $ \(p1,p2) -> do - let d = P.deg p1 - e = P.deg p2 - f [r | (_,_,r) <- [mr p1 p2 | d >= e] ++ [mr p2 p1 | e >= d]] - let ps' = Set.unions (rs:rss) - go (result `Set.union` ps) (ps' `Set.difference` result) - --- ゼロであるような高次の項を消した多項式を返す -normalizePoly - :: forall v. (Ord v, Show v, PrettyVar v) - => UPolynomial (Polynomial Rational v) - -> M v (UPolynomial (Polynomial Rational v)) -normalizePoly p = liftM P.fromTerms $ go $ sortBy (flip (comparing (P.deg . snd))) $ P.terms p - where - go [] = return [] - go xxs@((c,d):xs) = - mplus - (assume c [Pos, Neg] >> return xxs) - (assume c [Zero] >> go xs) - -refineSignConf - :: forall v. (Show v, Ord v, PrettyVar v) - => UPolynomial (Polynomial Rational v) - -> SignConf (Polynomial Rational v) - -> M v (SignConf (Polynomial Rational v)) -refineSignConf p conf = liftM (extendIntervals 0) $ mapM extendPoint conf - where - extendPoint - :: (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) - -> M v (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) - extendPoint (Point pt, m) = do - s <- signAt pt m - return (Point pt, Map.insert p s m) - extendPoint x = return x - - extendIntervals - :: Int - -> [(Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign)] - -> [(Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign)] - extendIntervals !n (pt1@(Point _, m1) : (Interval lb ub, m) : pt2@(Point _, m2) : xs) = - pt1 : ys ++ extendIntervals n2 (pt2 : xs) - where - s1 = lookupSignConf p m1 - s2 = lookupSignConf p m2 - n1 = if s1 == Zero then n+1 else n - root = RootOf p n1 - (ys, n2) - | s1 == s2 = ( [ (Interval lb ub, Map.insert p s1 m) ], n1 ) - | s1 == Zero = ( [ (Interval lb ub, Map.insert p s2 m) ], n1 ) - | s2 == Zero = ( [ (Interval lb ub, Map.insert p s1 m) ], n1 ) - | otherwise = ( [ (Interval lb root, Map.insert p s1 m) - , (Point root, Map.insert p Zero m) - , (Interval root ub, Map.insert p s2 m) - ] - , n1 + 1 - ) - extendIntervals _ xs = xs - - signAt :: Point (Polynomial Rational v) -> Map (UPolynomial (Polynomial Rational v)) Sign -> M v Sign - signAt PosInf _ = signCoeff (P.lc P.nat p) - signAt NegInf _ = do - let (c,mm) = P.lt P.nat p - if even (P.deg mm) - then signCoeff c - else liftM Sign.negate $ signCoeff c - signAt (RootOf q _) m = do - let (bm,k,r) = mr p q - r <- normalizePoly r - s1 <- if P.deg r > 0 - then return $ lookupSignConf r m - else signCoeff $ P.coeff P.mone r - -- 場合分けを出来るだけ避ける - if even k - then return s1 - else do - s2 <- signCoeff bm - return $ s1 `Sign.div` Sign.pow s2 k - - signCoeff :: Polynomial Rational v -> M v Sign - signCoeff c = - msum [ assume c [s] >> return s - | s <- [Neg, Zero, Pos] - ] - --- --------------------------------------------------------------------------- - -type Assumption v = (Map (Polynomial Rational v) (Set Sign), [Polynomial Rational v]) - -emptyAssumption :: Assumption v -emptyAssumption = (Map.empty, []) - -propagate :: Ord v => Assumption v -> Maybe (Assumption v) -propagate = go - where - go a = do - a' <- f a - if a == a' - then return a - else go a' - f a = liftM dropConstants $ propagateSign =<< propagateEq a - -propagateEq :: forall v. Ord v => Assumption v -> Maybe (Assumption v) -propagateEq (m, gb) - | any (\(p,ss) -> Set.singleton Zero == ss) (Map.toList m) = do - (m', gb') <- f (m, gb) - propagateEq (m', gb') - | otherwise = - return (m, gb) - where - f :: Assumption v -> Maybe (Assumption v) - f (m, gb) = - case Map.partition (Set.singleton Zero ==) m of - (m0, m) -> do - let gb' = GB.basis P.grevlex (Map.keys m0 ++ gb) - m' = Map.fromListWith Set.intersection $ do - (p,ss) <- Map.toList m - let p' = P.reduce P.grevlex p gb' - c = P.lc P.grlex p' - (p'',ss') - | c == 0 = (p', ss) - | otherwise = (P.mapCoeff (/c) p', Set.map (\s -> s `Sign.div` Sign.signOf c) ss) - return (p'', ss') - return $ (m', gb') - -propagateSign :: Ord v => Assumption v -> Maybe (Assumption v) -propagateSign (m, gb) = go (m, gb) - where - go a@(m, gb) - | not (isOkay a) = Nothing - | m == m' = Just (m, gb) - | otherwise = go (m', gb) - where - m' = Map.mapWithKey (\p ss -> Set.intersection ss (computeSignSet m p)) m - -isOkay :: Ord v => Assumption v -> Bool -isOkay (m, gb) = - and [not (Set.null ss) | (_,ss) <- Map.toList m] && - and [Set.member Zero (computeSignSet m p) | p <- gb] - -dropConstants :: Ord v => Assumption v -> Assumption v -dropConstants (m, gb) = (Map.filterWithKey (\p _ -> P.deg p > 0) m, gb) - -assumption2cond :: Ord v => Assumption v -> [(Polynomial Rational v, [Sign])] -assumption2cond (m, gb) = [(p, Set.toList ss) | (p, ss) <- Map.toList m] ++ [(p, [Zero]) | p <- gb] - --- --------------------------------------------------------------------------- - -computeSignSet :: Ord v => Map (Polynomial Rational v) (Set Sign) -> Polynomial Rational v -> Set Sign -computeSignSet m p = P.eval env (P.mapCoeff fromRational p) - where - env v = - case Map.lookup (P.var v) m of - Just ss -> ss - Nothing -> Set.fromList [Neg,Zero,Pos] - --- --------------------------------------------------------------------------- - -type Model v = Map v AReal.AReal - -findSample :: Ord v => Model v -> Cell (Polynomial Rational v) -> Maybe AReal.AReal -findSample m cell = - case evalCell m cell of - Point (RootOf p n) -> - Just $ AReal.realRoots p !! n - Interval lb ub -> - case I.simplestRationalWithin (f lb I.<..< f ub) of - Nothing -> error $ "ToySolver.CAD.findSample: should not happen" - Just r -> Just $ fromRational r - where - f :: Point Rational -> I.EndPoint AReal.AReal - f NegInf = I.NegInf - f PosInf = I.PosInf - f (RootOf p n) = I.Finite (AReal.realRoots p !! n) - -evalCell :: Ord v => Model v -> Cell (Polynomial Rational v) -> Cell Rational -evalCell m (Point pt) = Point $ evalPoint m pt -evalCell m (Interval pt1 pt2) = Interval (evalPoint m pt1) (evalPoint m pt2) - -evalPoint :: Ord v => Model v -> Point (Polynomial Rational v) -> Point Rational -evalPoint _ NegInf = NegInf -evalPoint _ PosInf = PosInf -evalPoint m (RootOf p n) = RootOf (AReal.minimalPolynomial a) (AReal.rootIndex a) - where - a = AReal.realRootsEx (P.mapCoeff (P.eval (m Map.!) . P.mapCoeff fromRational) p) !! n - --- --------------------------------------------------------------------------- - -solve - :: forall v. (Ord v, Show v, PrettyVar v) - => Set v - -> [(Rel (Polynomial Rational v))] - -> Maybe (Model v) -solve vs cs0 = solve' vs (map f cs0) - where - f (Rel lhs op rhs) = (lhs - rhs, g op) - g Le = [Zero, Neg] - g Ge = [Zero, Pos] - g Lt = [Neg] - g Gt = [Pos] - g Eql = [Zero] - g NEq = [Pos,Neg] - -solve' - :: forall v. (Ord v, Show v, PrettyVar v) - => Set v - -> [(Polynomial Rational v, [Sign])] - -> Maybe (Model v) -solve' vs0 cs0 = go (Set.toList vs0) cs0 - where - go :: [v] -> [(Polynomial Rational v, [Sign])] -> Maybe (Model v) - go [] cs = - if and [Sign.signOf v `elem` ss | (p,ss) <- cs, let v = P.eval (\_ -> undefined) p] - then Just Map.empty - else Nothing - go (v:vs) cs = listToMaybe $ do - (cs2, cell:_) <- project [(P.toUPolynomialOf p v, ss) | (p,ss) <- cs] - case go vs cs2 of - Nothing -> mzero - Just m -> do - let Just val = findSample m cell - seq val $ return $ Map.insert v val m - --- --------------------------------------------------------------------------- - -showDNF :: (Ord v, Show v, PrettyVar v) => DNF (Polynomial Rational v, [Sign]) -> String -showDNF (DNF xss) = intercalate " | " [showConj xs | xs <- xss] - where - showConj xs = "(" ++ intercalate " & " [f p ss | (p,ss) <- xs] ++ ")" - f p ss = prettyShow p ++ g ss - g [Zero] = " = 0" - g [Pos] = " > 0" - g [Neg] = " < 0" - g xs - | Set.fromList xs == Set.fromList [Pos,Neg] = "/= 0" - | Set.fromList xs == Set.fromList [Zero,Pos] = ">= 0" - | Set.fromList xs == Set.fromList [Zero,Neg] = "<= 0" - | otherwise = error "showDNF: should not happen" - -dumpProjection - :: (Ord v, Show v, PrettyVar v) - => [([(Polynomial Rational v, [Sign])], [Cell (Polynomial Rational v)])] - -> IO () -dumpProjection xs = - forM_ xs $ \(gs, cells) -> do - putStrLn "============" - forM_ gs $ \(p, ss) -> do - putStrLn $ f p ss - putStrLn " =>" - forM_ cells $ \cell -> do - putStrLn $ showCell cell - where - f p ss = prettyShow p ++ g ss - g [Zero] = " = 0" - g [Pos] = " > 0" - g [Neg] = " < 0" - g xs - | Set.fromList xs == Set.fromList [Pos,Neg] = "/= 0" - | Set.fromList xs == Set.fromList [Zero,Pos] = ">= 0" - | Set.fromList xs == Set.fromList [Zero,Neg] = "<= 0" - | otherwise = error "showDNF: should not happen" - -dumpSignConf - :: forall v. - (Ord v, PrettyVar v, Show v) - => [(SignConf (Polynomial Rational v), Assumption v)] - -> IO () -dumpSignConf x = - forM_ x $ \(conf, as) -> do - putStrLn "============" - mapM_ putStrLn $ showSignConf conf - forM_ (assumption2cond as) $ \(p, ss) -> - printf "%s %s\n" (prettyShow p) (show ss) - --- --------------------------------------------------------------------------- - -test1a :: IO () -test1a = mapM_ putStrLn $ showSignConf conf - where - x = P.var X - ps :: [UPolynomial (Polynomial Rational Int)] - ps = [x + 1, -2*x + 3, x] - [(conf, _)] = runM $ buildSignConf ps - -test1b :: Bool -test1b = isJust $ solve vs cs - where - x = P.var X - vs = Set.singleton X - cs = [x + 1 .>. 0, -2*x + 3 .>. 0, x .>. 0] - -test1c :: Bool -test1c = isJust $ do - m <- solve' (Set.singleton X) cs - guard $ and $ do - (p, ss) <- cs - let val = P.eval (m Map.!) (P.mapCoeff fromRational p) - return $ Sign.signOf val `elem` ss - where - x = P.var X - cs = [(x + 1, [Pos]), (-2*x + 3, [Pos]), (x, [Pos])] - -test2a :: IO () -test2a = mapM_ putStrLn $ showSignConf conf - where - x = P.var X - ps :: [UPolynomial (Polynomial Rational Int)] - ps = [x^(2::Int)] - [(conf, _)] = runM $ buildSignConf ps - -test2b :: Bool -test2b = isNothing $ solve vs cs - where - x = P.var X - vs = Set.singleton X - cs = [x^(2::Int) .<. 0] - -test = and [test1b, test1c, test2b] - -test_project :: DNF (Polynomial Rational Int, [Sign]) -test_project = DNF $ map fst $ project [(p', [Zero])] - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - x = P.var 3 - p :: Polynomial Rational Int - p = a*x^(2::Int) + b*x + c - p' = P.toUPolynomialOf p 3 - -test_project_print :: IO () -test_project_print = putStrLn $ showDNF $ test_project - -test_project_2 = project [(p, [Zero]), (x, [Pos])] - where - x = P.var X - p :: UPolynomial (Polynomial Rational Int) - p = x^(2::Int) + 4*x - 10 - -test_project_3_print = dumpProjection $ project [(P.toUPolynomialOf p 0, [Neg])] - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - p :: Polynomial Rational Int - p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1 - -test_solve = solve vs [p .<. 0] - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - vs = Set.fromList [0,1,2] - p :: Polynomial Rational Int - p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1 - -test_collectPolynomials - :: [( [UPolynomial (Polynomial Rational Int)] - , Assumption Int - )] -test_collectPolynomials = runM $ collectPolynomials [p'] - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - x = P.var 3 - p :: Polynomial Rational Int - p = a*x^(2::Int) + b*x + c - p' = P.toUPolynomialOf p 3 - -test_collectPolynomials_print :: IO () -test_collectPolynomials_print = do - forM_ test_collectPolynomials $ \(ps,g) -> do - putStrLn "============" - mapM_ (putStrLn . prettyShow) ps - forM_ (assumption2cond g) $ \(p, ss) -> - printf "%s %s\n" (prettyShow p) (show ss) - -test_buildSignConf :: [(SignConf (Polynomial Rational Int), Assumption Int)] -test_buildSignConf = runM $ buildSignConf [P.toUPolynomialOf p 3] - where - a = P.var 0 - b = P.var 1 - c = P.var 2 - x = P.var 3 - p :: Polynomial Rational Int - p = a*x^(2::Int) + b*x + c - -test_buildSignConf_print :: IO () -test_buildSignConf_print = dumpSignConf test_buildSignConf - -test_buildSignConf_2 :: [(SignConf (Polynomial Rational Int), Assumption Int)] -test_buildSignConf_2 = runM $ buildSignConf [P.toUPolynomialOf p 0 | p <- ps] - where - x = P.var 0 - ps :: [Polynomial Rational Int] - ps = [x + 1, -2*x + 3, x] - -test_buildSignConf_2_print :: IO () -test_buildSignConf_2_print = dumpSignConf test_buildSignConf_2 - -test_buildSignConf_3 :: [(SignConf (Polynomial Rational Int), Assumption Int)] -test_buildSignConf_3 = runM $ buildSignConf [P.toUPolynomialOf p 0 | p <- ps] - where - x = P.var 0 - ps :: [Polynomial Rational Int] - ps = [x, 2*x] - -test_buildSignConf_3_print :: IO () -test_buildSignConf_3_print = dumpSignConf test_buildSignConf_3 - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs b/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Combinatorial.HittingSet.HTCBDD +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (DeriveDataTypeable) +-- +-- Wrapper for htcbdd command. +-- +-- * HTC-BDD: Hypergraph Transversal Computation with Binary Decision Diagrams +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Combinatorial.HittingSet.HTCBDD + ( Options (..) + , Method (..) + , Failure (..) + , defaultOptions + , minimalHittingSets + ) where + +import Control.Exception (Exception, throwIO) +import Control.Monad +import Data.Default.Class +import Data.Array.Unboxed +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List +import Data.Typeable +import System.Exit +import System.IO +import System.IO.Temp +import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) + +type Vertex = Int +type HyperEdge = IntSet +type HittingSet = IntSet + +data Options + = Options + { optHTCBDDCommand :: FilePath + , optMethod :: Method + , optOnGetLine :: String -> IO () + , optOnGetErrorLine :: String -> IO () + } + +data Method + = MethodToda + | MethodKnuth + deriving (Eq, Ord, Show) + +instance Default Method where + def = MethodToda + +instance Default Options where + def = defaultOptions + +defaultOptions :: Options +defaultOptions = + Options + { optHTCBDDCommand = "htcbdd" + , optMethod = def + , optOnGetLine = \_ -> return () + , optOnGetErrorLine = \_ -> return () + } + +data Failure = Failure !Int + deriving (Show, Typeable) + +instance Exception Failure + +minimalHittingSets :: Options -> [HyperEdge] -> IO [HittingSet] +minimalHittingSets opt es = do + withSystemTempFile "htcbdd-input.dat" $ \fname1 h1 -> do + forM_ es $ \e -> do + hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] + hClose h1 + withSystemTempFile "htcbdd-out.dat" $ \fname2 h2 -> do + hClose h2 + execHTCBDD opt fname1 fname2 + s <- readFile fname2 + return $ map (IntSet.fromList . map ((decTable !) . read) . words) $ lines s + where + vs :: IntSet + vs = IntSet.unions es + + nv :: Int + nv = IntSet.size vs + + encTable :: IntMap Int + encTable = IntMap.fromList (zip (IntSet.toList vs) [1..nv]) + + decTable :: UArray Int Int + decTable = array (1,nv) (zip [1..nv] (IntSet.toList vs)) + +execHTCBDD :: Options -> FilePath -> FilePath -> IO () +execHTCBDD opt inputFile outputFile = do + let args = ["-k" | optMethod opt == MethodKnuth] ++ [inputFile, outputFile] + exitcode <- runProcessWithOutputCallback (optHTCBDDCommand opt) args "" (optOnGetLine opt) (optOnGetErrorLine opt) + case exitcode of + ExitFailure n -> throwIO $ Failure n + ExitSuccess -> return () diff --git a/src/ToySolver/Combinatorial/HittingSet/SHD.hs b/src/ToySolver/Combinatorial/HittingSet/SHD.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Combinatorial/HittingSet/SHD.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Combinatorial.HittingSet.SHD +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (DeriveDataTypeable) +-- +-- Wrapper for shd command. +-- +-- * Hypergraph Dualization Repository +-- +-- +----------------------------------------------------------------------------- +module ToySolver.Combinatorial.HittingSet.SHD + ( Options (..) + , Failure (..) + , defaultOptions + , minimalHittingSets + ) where + +import Control.Exception (Exception, throwIO) +import Control.Monad +import Data.Array.Unboxed +import Data.Default.Class +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List +import Data.Typeable +import System.Exit +import System.IO +import System.IO.Temp +import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) + +type Vertex = Int +type HyperEdge = IntSet +type HittingSet = IntSet + +data Options + = Options + { optSHDCommand :: FilePath + , optSHDArgs :: [String] + , optOnGetLine :: String -> IO () + , optOnGetErrorLine :: String -> IO () + } + +instance Default Options where + def = defaultOptions + +defaultOptions :: Options +defaultOptions = + Options + { optSHDCommand = "shd" + , optSHDArgs = ["0"] + , optOnGetLine = \_ -> return () + , optOnGetErrorLine = \_ -> return () + } + +data Failure = Failure !Int + deriving (Show, Typeable) + +instance Exception Failure + +minimalHittingSets :: Options -> [HyperEdge] -> IO [HittingSet] +minimalHittingSets opt es = do + withSystemTempFile "shd-input.dat" $ \fname1 h1 -> do + forM_ es $ \e -> do + hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] + hClose h1 + withSystemTempFile "shd-out.dat" $ \fname2 h2 -> do + hClose h2 + execSHD opt fname1 fname2 + s <- readFile fname2 + return $ map (IntSet.fromList . map ((decTable !) . read) . words) $ lines s + where + vs :: IntSet + vs = IntSet.unions es + + nv :: Int + nv = IntSet.size vs + + encTable :: IntMap Int + encTable = IntMap.fromList (zip (IntSet.toList vs) [0..nv-1]) + + decTable :: UArray Int Int + decTable = array (0,nv-1) (zip [0..nv-1] (IntSet.toList vs)) + +execSHD :: Options -> FilePath -> FilePath -> IO () +execSHD opt inputFile outputFile = do + let args = optSHDArgs opt ++ [inputFile, outputFile] + exitcode <- runProcessWithOutputCallback (optSHDCommand opt) args "" (optOnGetLine opt) (optOnGetErrorLine opt) + case exitcode of + ExitFailure n -> throwIO $ Failure n + ExitSuccess -> return () diff --git a/src/ToySolver/Combinatorial/HittingSet/Simple.hs b/src/ToySolver/Combinatorial/HittingSet/Simple.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Combinatorial/HittingSet/Simple.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Combinatorial.HittingSet.Simple +-- Copyright : (c) Masahiro Sakai 2012-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module ToySolver.Combinatorial.HittingSet.Simple + ( minimalHittingSets + ) where + +import Control.Monad +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List +import qualified Data.Set as Set + +type Vertex = Int +type HyperEdge = IntSet +type HittingSet = IntSet + +minimalHittingSets :: [HyperEdge] -> [HittingSet] +minimalHittingSets es = nubOrd $ f es IntSet.empty + where + f :: [HyperEdge] -> HittingSet -> [HittingSet] + f [] hs = return hs + f es hs = do + v <- IntSet.toList $ IntSet.unions es + let hs' = IntSet.insert v hs + e <- es + guard $ v `IntSet.member` e + let es' = propagateChoice es v e + f es' hs' + +propagateChoice :: [HyperEdge] -> Vertex -> HyperEdge -> [HyperEdge] +propagateChoice es v e = zs + where + xs = filter (v `IntSet.notMember`) es + ys = map (IntSet.filter (v <) . (`IntSet.difference` e)) xs + zs = maintainNoSupersets ys + +maintainNoSupersets :: [IntSet] -> [IntSet] +maintainNoSupersets xss = go [] xss + where + go yss [] = yss + go yss (xs:xss) = go (xs : filter p yss) (filter p xss) + where + p zs = not (xs `IntSet.isSubsetOf` zs) + +nubOrd :: Ord a => [a] -> [a] +nubOrd = go Set.empty + where + go occurred (x:xs) + | x `Set.member` occurred = go occurred xs + | otherwise = x : go (Set.insert x occurred) xs + go _ [] = [] diff --git a/src/ToySolver/Combinatorial/Knapsack/BB.hs b/src/ToySolver/Combinatorial/Knapsack/BB.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Combinatorial/Knapsack/BB.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Combinatorial.Knapsack.BB +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Simple 0-1 knapsack problem solver that uses branch-and-bound with LP-relaxation based upper bound. +-- +----------------------------------------------------------------------------- +module ToySolver.Combinatorial.Knapsack.BB + ( Weight + , Value + , solve + ) where + +import Control.Monad.State +import Data.Function (on) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.List + +type Weight = Rational +type Value = Rational + +solve + :: [(Value, Weight)] + -> Weight + -> (Value, Weight, [Bool]) +solve items limit = + ( sum [v | (n,(v,_)) <- zip [0..] items, n `IntSet.member` sol] + , sum [w | (n,(_,w)) <- zip [0..] items, n `IntSet.member` sol] + , [n `IntSet.member` sol | (n,_) <- zip [0..] items] + ) + where + items' :: [(Value, Weight, Int)] + items' = map fst $ sortBy (flip compare `on` snd) [((v, w, n), (v / w, v)) | (n, (v, w)) <- zip [0..] items] + + sol :: IntSet + sol = IntSet.fromList $ fst $ execState (f items' limit ([],0)) ([],0) + + f :: [(Value, Weight, Int)] -> Weight -> ([Int],Value) -> State ([Int],Value) () + f items !slack (is, !value) = do + (_, bestVal) <- get + when (computeUB items slack value > bestVal) $ do + case items of + [] -> put (is,value) + (v,w,i):items -> do + when (slack >= w) $ f items (slack - w) (i : is, v + value) + f items slack (is, value) + + computeUB :: [(Value, Weight, Int)] -> Weight -> Value -> Value + computeUB items slack value = go items slack value + where + go _ 0 val = val + go [] _ val = val + go ((v,w,_):items) slack val + | slack >= w = go items (slack - w) (val + v) + | otherwise = val + (v / w) * slack diff --git a/src/ToySolver/Combinatorial/Knapsack/DP.hs b/src/ToySolver/Combinatorial/Knapsack/DP.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Combinatorial/Knapsack/DP.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Combinatorial.Knapsack.DP +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Simple 0-1 knapsack problem solver that uses DP. +-- +----------------------------------------------------------------------------- +module ToySolver.Combinatorial.Knapsack.DP + ( Weight + , Value + , solve + ) where + +import Data.Array +import Data.Function (on) +import Data.List + +type Weight = Int +type Value = Rational + +solve + :: [(Value, Weight)] + -> Weight + -> (Value, Weight, [Bool]) +solve items limit = (val, sum [w | (b,(_,w)) <- zip bs items, b], bs) + where + bs = reverse bs' + (bs',val) = m!(n-1, limit) + + n = length items + m = array ((-1, 0), (n-1, limit)) $ + [((-1,w), ([],0)) | w <- [0 .. limit]] ++ + [((i,0), ([],0)) | i <- [0 .. n-1]] ++ + [((i,w), best) + | (i,(vi,wi)) <- zip [0..] items + , w <- [1..limit] + , let s1 = [(False:bs,v) | let (bs,v) = m!(i-1, w)] + , let s2 = [(True:as,v+vi) | w >= wi, let (as,v) = m!(i-1, w-wi)] + , let best = maximumBy (compare `on` snd) (s1 ++ s2) + ] + +test1 = solve [(5,4), (4,5), (3,2)] 9 +test2 = solve [(45,5), (48,8), (35,3)] 10 diff --git a/src/ToySolver/ContiTraverso.hs b/src/ToySolver/ContiTraverso.hs deleted file mode 100644 --- a/src/ToySolver/ContiTraverso.hs +++ /dev/null @@ -1,124 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : ToySolver.ContiTraverso --- Copyright : (c) Masahiro Sakai 2012 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- References: --- --- * P. Conti and C. Traverso, "Buchberger algorithm and integer programming," --- Applied Algebra, Algebraic Algorithms and Error-Correcting Codes, --- Lecture Notes in Computer Science Volume 539, 1991, pp 130-139 --- --- --- --- * IKEGAMI Daisuke, "数列と多項式の愛しい関係," 2011, --- --- --- * 伊藤雅史, , 平林 隆一, "整数計画問題のための b-Gröbner 基底変換アルゴリズム," --- --- --- ------------------------------------------------------------------------------ -module ToySolver.ContiTraverso - ( solve - , solve' - ) where - -import Data.Function -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import Data.List -import Data.Monoid -import Data.Ratio -import Data.VectorSpace - -import Data.OptDir - -import ToySolver.Data.ArithRel -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Polynomial (Polynomial, UPolynomial, Monomial, MonomialOrder) -import qualified ToySolver.Data.Polynomial as P -import ToySolver.Data.Polynomial.GroebnerBasis as GB -import ToySolver.Data.Var -import qualified ToySolver.LPUtil as LPUtil - -solve :: MonomialOrder Var -> VarSet -> OptDir -> LA.Expr Rational -> [LA.Atom Rational] -> Maybe (Model Integer) -solve cmp vs dir obj cs = do - m <- solve' cmp vs obj3 cs3 - return . IM.map round . mt . IM.map fromInteger $ m - where - ((obj2,cs2), mt) = LPUtil.toStandardForm (if dir == OptMin then obj else negateV obj, cs) - obj3 = LA.mapCoeff g obj2 - where - g = round . (c*) - c = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms obj] - cs3 = map f cs2 - f (lhs,rhs) = (LA.mapCoeff g lhs, g rhs) - where - g = round . (c*) - c = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms lhs] - -solve' :: MonomialOrder Var -> VarSet -> LA.Expr Integer -> [(LA.Expr Integer, Integer)] -> Maybe (Model Integer) -solve' cmp vs' obj cs - | or [c < 0 | (c,x) <- LA.terms obj, x /= LA.unitVar] = error "all coefficient of cost function should be non-negative" - | otherwise = - if IM.keysSet (IM.filter (/= 0) m) `IS.isSubsetOf` vs' - then Just $ IM.filterWithKey (\y _ -> y `IS.member` vs') m - else Nothing - - where - vs :: [Var] - vs = IS.toList vs' - - v2 :: Var - v2 = if IS.null vs' then 0 else IS.findMax vs' + 1 - - vs2 :: [Var] - vs2 = [v2 .. v2 + length cs - 1] - - vs2' :: IS.IntSet - vs2' = IS.fromList vs2 - - t :: Var - t = v2 + length cs - - cmp2 :: MonomialOrder Var - cmp2 = elimOrdering (IS.fromList vs2) `mappend` elimOrdering (IS.singleton t) `mappend` costOrdering obj `mappend` cmp - - gb :: [Polynomial Rational Var] - gb = GB.basis' GB.defaultOptions cmp2 (product (map P.var (t:vs2)) - 1 : phi) - where - phi = do - xj <- vs - let aj = [(yi, aij) | (yi,(ai,_)) <- zip vs2 cs, let aij = LA.coeff xj ai] - return $ product [P.var yi ^ aij | (yi, aij) <- aj, aij > 0] - - product [P.var yi ^ (-aij) | (yi, aij) <- aj, aij < 0] * P.var xj - - yb = product [P.var yi ^ bi | ((_,bi),yi) <- zip cs vs2] - - [(_,z)] = P.terms (P.reduce cmp2 yb gb) - - m = mkModel (vs++vs2++[t]) z - -mkModel :: [Var] -> Monomial Var -> Model Integer -mkModel vs xs = IM.fromDistinctAscList (Map.toAscList (P.mindicesMap xs)) `IM.union` IM.fromList [(x, 0) | x <- vs] --- IM.union is left-biased - -costOrdering :: LA.Expr Integer -> MonomialOrder Var -costOrdering obj = compare `on` f - where - vs = vars obj - f xs = LA.evalExpr (mkModel (IS.toList vs) xs) obj - -elimOrdering :: IS.IntSet -> MonomialOrder Var -elimOrdering xs = compare `on` f - where - f ys = not $ IS.null $ xs `IS.intersection` ys' - where - ys' = IS.fromDistinctAscList [y | (y,_) <- Map.toAscList $ P.mindicesMap ys] diff --git a/src/ToySolver/Converter/MIP2SMT.hs b/src/ToySolver/Converter/MIP2SMT.hs --- a/src/ToySolver/Converter/MIP2SMT.hs +++ b/src/ToySolver/Converter/MIP2SMT.hs @@ -19,6 +19,7 @@ ) where import Data.Char +import Data.Default.Class import Data.Ord import Data.List import Data.Ratio @@ -42,6 +43,9 @@ } deriving (Show, Eq, Ord) +instance Default Options where + def = defaultOptions + defaultOptions :: Options defaultOptions = Options @@ -217,25 +221,50 @@ bnd v = (c1, Nothing) where v2 = env Map.! v - v3 = if isInt mip v - then toReal opt (showString v2) - else showString v2 (lb,ub) = MIP.getBounds mip v - s1 = case lb of - MIP.NegInf -> [] - MIP.PosInf -> [showString "false"] - MIP.Finite x -> - if isInt mip v - then [list [showString "<=", intNum opt (ceiling x), showString v2]] - else [list [showString "<=", realNum opt x, v3]] - s2 = case ub of - MIP.NegInf -> [showString "false"] - MIP.PosInf -> [] - MIP.Finite x -> - if isInt mip v - then [list [showString "<=", showString v2, intNum opt (floor x)]] - else [list [showString "<=", v3, realNum opt x]] - c0 = and' (s1 ++ s2) + + c0 = + case optLanguage opt of + -- In SMT-LIB2 format, inequalities can be chained. + -- For example, "(<= 0 x 10)" is equivalent to "(and (<= 0 x) (<= x 10))". + -- + -- Supported solvers: cvc4-1.1, yices-2.2.1, z3-4.3.0 + -- Unsupported solvers: z3-4.0 + SMTLIB2 + | lb == MIP.PosInf || ub == MIP.NegInf -> showString "false" + | length args >= 2 -> list (showString "<=" : args) + | otherwise -> showString "true" + where + args = lb2 ++ [showString v2] ++ ub2 + lb2 = case lb of + MIP.NegInf -> [] + MIP.PosInf -> error "should not happen" + MIP.Finite x + | isInt mip v -> [intNum opt (ceiling x)] + | otherwise -> [realNum opt x] + ub2 = case ub of + MIP.NegInf -> error "should not happen" + MIP.PosInf -> [] + MIP.Finite x + | isInt mip v -> [intNum opt (floor x)] + | otherwise -> [realNum opt x] + YICES _ -> and' (s1 ++ s2) + where + s1 = case lb of + MIP.NegInf -> [] + MIP.PosInf -> [showString "false"] + MIP.Finite x -> + if isInt mip v + then [list [showString "<=", intNum opt (ceiling x), showString v2]] + else [list [showString "<=", realNum opt x, showString v2]] + s2 = case ub of + MIP.NegInf -> [showString "false"] + MIP.PosInf -> [] + MIP.Finite x -> + if isInt mip v + then [list [showString "<=", showString v2, intNum opt (floor x)]] + else [list [showString "<=", showString v2, realNum opt x]] + c1 = case MIP.getVarType mip v of MIP.SemiContinuousVariable -> or' [list [showString "=", showString v2, realNum opt 0], c0] @@ -243,6 +272,7 @@ or' [list [showString "=", showString v2, intNum opt 0], c0] _ -> c0 + cs = map (constraint opt q env mip) (MIP.constraints mip) ss = concatMap sos (MIP.sosConstraints mip) sos (MIP.SOSConstraint label typ xs) = do @@ -356,11 +386,11 @@ testFile fname = do result <- LPFile.parseFile fname case result of - Right mip -> putStrLn $ convert defaultOptions mip "" + Right mip -> putStrLn $ convert def mip "" Left err -> hPrint stderr err test :: IO () -test = putStrLn $ convert defaultOptions testdata "" +test = putStrLn $ convert def testdata "" testdata :: MIP.Problem Right testdata = LPFile.parseString "test" $ unlines diff --git a/src/ToySolver/Converter/PB2IP.hs b/src/ToySolver/Converter/PB2IP.hs --- a/src/ToySolver/Converter/PB2IP.hs +++ b/src/ToySolver/Converter/PB2IP.hs @@ -38,7 +38,7 @@ [ ( v , MIP.VarInfo { MIP.varType = MIP.IntegerVariable - , MIP.varBounds = (MIP.Finite 0, MIP.Finite 1) + , MIP.varBounds = (0, 1) } ) | v <- vs @@ -100,7 +100,7 @@ [ ( v , MIP.VarInfo { MIP.varType = MIP.IntegerVariable - , MIP.varBounds = (MIP.Finite 0, MIP.Finite 1) + , MIP.varBounds = (0, 1) } ) | v <- vs @@ -182,7 +182,7 @@ mtrans :: Int -> Map MIP.Var Rational -> SAT.Model mtrans nvar m = array (1, nvar) - [　(i, val) + [ (i, val) | i <- [1 .. nvar] , let val = case Map.findWithDefault 0 (convVar i) m of diff --git a/src/ToySolver/Cooper.hs b/src/ToySolver/Cooper.hs deleted file mode 100644 --- a/src/ToySolver/Cooper.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Cooper --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (FlexibleInstances) --- --- Naive implementation of Cooper's algorithm --- --- Reference: --- --- * --- --- * --- --- See also: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.Cooper - ( - -- * Language of presburger arithmetics - ExprZ - , Lit (..) - , QFFormula (..) - , fromLAAtom - , (.|.) - - -- * Projection - , project - , projectCases - , projectCasesN - - -- * Quantifier elimination - , eliminateQuantifiers - - -- * Constraint solving - , solve - , solveQFFormula - , solveFormula - , solveQFLA - ) where - -import ToySolver.Cooper.Core -import ToySolver.Cooper.FOL diff --git a/src/ToySolver/Cooper/Core.hs b/src/ToySolver/Cooper/Core.hs deleted file mode 100644 --- a/src/ToySolver/Cooper/Core.hs +++ /dev/null @@ -1,435 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Cooper.Core --- Copyright : (c) Masahiro Sakai 2011-2013 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (FlexibleInstances) --- --- Naive implementation of Cooper's algorithm --- --- Reference: --- --- * --- --- * --- --- See also: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.Cooper.Core - ( - -- * Language of presburger arithmetics - ExprZ - , Lit (..) - , evalLit - , QFFormula (..) - , fromLAAtom - , (.|.) - , evalQFFormula - - -- * Projection - , project - , projectN - , projectCases - , projectCasesN - - -- * Constraint solving - , solve - , solveQFFormula - , solveQFLA - ) where - -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.VectorSpace hiding (project) - -import ToySolver.Data.ArithRel -import ToySolver.Data.Boolean -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import qualified ToySolver.FourierMotzkin as FM -import qualified ToySolver.FourierMotzkin.Core as FM - --- --------------------------------------------------------------------------- - --- | Linear arithmetic expression over integers. -type ExprZ = LA.Expr Integer - -fromLAAtom :: LA.Atom Rational -> QFFormula -fromLAAtom (Rel a op b) = rel op a' b' - where - (e1,c1) = FM.toRat a - (e2,c2) = FM.toRat b - a' = c2 *^ e1 - b' = c1 *^ e2 - -leZ, ltZ, geZ, gtZ :: ExprZ -> ExprZ -> Lit -leZ e1 e2 = e1 `ltZ` (e2 ^+^ LA.constant 1) -ltZ e1 e2 = Pos $ (e2 ^-^ e1) -geZ = flip leZ -gtZ = flip gtZ - -eqZ :: ExprZ -> ExprZ -> QFFormula -eqZ e1 e2 = Lit (e1 `leZ` e2) .&&. Lit (e1 `geZ` e2) - --- | Literal --- --- * @Pos e@ means @e > 0@ --- --- * @Divisible True d e@ means @e@ can be divided by @d@ (i.e. @d|e@) --- --- * @Divisible False d e@ means @e@ can not be divided by @d@ (i.e. @¬(d|e)@) -data Lit - = Pos ExprZ - | Divisible Bool Integer ExprZ - deriving (Show, Eq, Ord) - -instance Variables Lit where - vars (Pos t) = vars t - vars (Divisible _ _ t) = vars t - -instance Complement Lit where - notB (Pos e) = e `leZ` LA.constant 0 - notB (Divisible b c e) = Divisible (not b) c e - --- | quantifier-free negation normal form -data QFFormula - = T - | F - | And QFFormula QFFormula - | Or QFFormula QFFormula - | Lit Lit - deriving (Show, Eq, Ord) - -instance Complement QFFormula where - notB T = F - notB F = T - notB (And a b) = Or (notB a) (notB b) - notB (Or a b) = And (notB a) (notB b) - notB (Lit lit) = Lit (notB lit) - -instance Boolean QFFormula where - true = T - false = F - (.&&.) = And - (.||.) = Or - -instance Variables QFFormula where - vars T = IS.empty - vars F = IS.empty - vars (And a b) = vars a `IS.union` vars b - vars (Or a b) = vars a `IS.union` vars b - vars (Lit l) = vars l - -instance IsRel (LA.Expr Integer) QFFormula where - rel op lhs rhs = - case op of - Le -> Lit $ leZ lhs rhs - Ge -> Lit $ geZ lhs rhs - Lt -> Lit $ ltZ lhs rhs - Gt -> Lit $ gtZ lhs rhs - Eql -> eqZ lhs rhs - NEq -> notB $ rel Eql lhs rhs - -(.|.) :: Integer -> ExprZ -> QFFormula -n .|. e = Lit $ Divisible True n e - -subst1 :: Var -> ExprZ -> QFFormula -> QFFormula -subst1 x e = go - where - go T = T - go F = F - go (And a b) = And (go a) (go b) - go (Or a b) = Or (go a) (go b) - go (Lit (Divisible b c e1)) = Lit $ Divisible b c $ LA.applySubst1 x e e1 - go (Lit (Pos e1)) = Lit $ Pos $ LA.applySubst1 x e e1 - -simplify :: QFFormula -> QFFormula -simplify (And a b) = simplify1 $ And (simplify a) (simplify b) -simplify (Or a b) = simplify1 $ Or (simplify a) (simplify b) -simplify formula = simplify1 formula - -simplify1 :: QFFormula -> QFFormula -simplify1 T = T -simplify1 F = F -simplify1 (And a b) = - case (a, b) of - (T, b') -> b' - (a', T) -> a' - (F, _) -> false - (_, F) -> false - (a',b') -> a' .&&. b' -simplify1 (Or a b) = - case (a, b) of - (F, b') -> b' - (a', F) -> a' - (T, _) -> true - (_, T) -> true - (a',b') -> a' .||. b' -simplify1 (Lit lit) = simplifyLit lit - -simplifyLit :: Lit -> QFFormula -simplifyLit (Pos e) = - case LA.asConst e of - Just c -> if c > 0 then true else false - Nothing -> - -- e > 0 <=> e - 1 >= 0 - -- <=> LA.mapCoeff (`div` d) (e - 1) >= 0 - -- <=> LA.mapCoeff (`div` d) (e - 1) + 1 > 0 - Lit $ Pos $ LA.mapCoeff (`div` d) e1 ^+^ LA.constant 1 - where - e1 = e ^-^ LA.constant 1 - d = if null cs then 1 else abs $ foldl1' gcd cs - cs = [c | (c,x) <- LA.terms e1, x /= LA.unitVar] -simplifyLit lit@(Divisible b c e) - | LA.coeff LA.unitVar e `mod` d /= 0 = if b then false else true - | c' == 1 = if b then true else false - | d == 1 = Lit lit - | otherwise = Lit $ Divisible b c' e' - where - d = abs $ foldl' gcd c [c2 | (c2,x) <- LA.terms e, x /= LA.unitVar] - c' = c `div` d - e' = LA.mapCoeff (`div` d) e - -evalQFFormula :: Model Integer -> QFFormula -> Bool -evalQFFormula m = f - where - f T = True - f F = False - f (And x1 x2) = f x1 && f x2 - f (Or x1 x2) = f x1 || f x2 - f (Lit lit) = evalLit m lit - -evalLit :: Model Integer -> Lit -> Bool -evalLit m (Pos e) = LA.evalExpr m e > 0 -evalLit m (Divisible True n e) = LA.evalExpr m e `mod` n == 0 -evalLit m (Divisible False n e) = LA.evalExpr m e `mod` n /= 0 - --- --------------------------------------------------------------------------- - -data Witness = WCase1 Integer ExprZ | WCase2 Integer Integer Integer [ExprZ] - -evalWitness :: Model Integer -> Witness -> Integer -evalWitness model (WCase1 c e) = LA.evalExpr model e `div` c -evalWitness model (WCase2 c j delta us) - | null us' = j `div` c - | otherwise = (j + (((u - delta - 1) `div` delta) * delta)) `div` c - where - us' = map (LA.evalExpr model) us - u = minimum us' - --- --------------------------------------------------------------------------- - -project :: Var -> QFFormula -> (QFFormula, Model Integer -> Model Integer) -project x formula = (formula', mt) - where - xs = projectCases x formula - formula' = simplify $ orB [phi | (phi,_) <- xs, phi /= F] - mt m = head $ do - (phi, mt') <- xs - guard $ evalQFFormula m phi - return $ mt' m - -projectN :: VarSet -> QFFormula -> (QFFormula, Model Integer -> Model Integer) -projectN vs2 = f (IS.toList vs2) - where - f :: [Var] -> QFFormula -> (QFFormula, Model Integer -> Model Integer) - f [] formula = (formula, id) - f (v:vs) formula = (formula3, mt1 . mt2) - where - (formula2, mt1) = project v formula - (formula3, mt2) = f vs formula2 - -projectCases :: Var -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] -projectCases x formula = do - (phi, wit) <- projectCases' x formula - return (phi, \m -> IM.insert x (evalWitness m wit) m) - -projectCases' :: Var -> QFFormula -> [(QFFormula, Witness)] -projectCases' x formula = [(simplify phi, w) | (phi,w) <- case1 ++ case2] - where - -- xの係数の最小公倍数 - c :: Integer - c = f formula - where - f :: QFFormula -> Integer - f T = 1 - f F = 1 - f (And a b) = lcm (f a) (f b) - f (Or a b) = lcm (f a) (f b) - f (Lit (Pos e)) = fromMaybe 1 (LA.lookupCoeff x e) - f (Lit (Divisible _ _ e)) = fromMaybe 1 (LA.lookupCoeff x e) - - -- 式をスケールしてxの係数の絶対値をcへと変換し、その後cxをxで置き換え、 - -- xがcで割り切れるという制約を追加した論理式 - formula1 :: QFFormula - formula1 = simplify $ f formula .&&. Lit (Divisible True c (LA.var x)) - where - f :: QFFormula -> QFFormula - f T = T - f F = F - f (And a b) = f a .&&. f b - f (Or a b) = f a .||. f b - f lit@(Lit (Pos e)) = - case LA.lookupCoeff x e of - Nothing -> lit - Just a -> - let s = abs (c `div` a) - in Lit $ Pos $ g s e - f lit@(Lit (Divisible b d e)) = - case LA.lookupCoeff x e of - Nothing -> lit - Just a -> - let s = abs (c `div` a) - in Lit $ Divisible b (s*d) $ g s e - - g :: Integer -> ExprZ -> ExprZ - g s = LA.mapCoeffWithVar (\c' x' -> if x==x' then signum c' else s*c') - - -- d|x+t という形の論理式の d の最小公倍数 - delta :: Integer - delta = f formula1 - where - f :: QFFormula -> Integer - f T = 1 - f F = 1 - f (And a b) = lcm (f a) (f b) - f (Or a b) = lcm (f a) (f b) - f (Lit (Divisible _ d _)) = d - f (Lit (Pos _)) = 1 - - -- ts = {t | t < x は formula1 に現れる原子論理式} - ts :: [ExprZ] - ts = f formula1 - where - f :: QFFormula -> [ExprZ] - f T = [] - f F = [] - f (And a b) = f a ++ f b - f (Or a b) = f a ++ f b - f (Lit (Divisible _ _ _)) = [] - f (Lit (Pos e)) = - case LA.extractMaybe x e of - Nothing -> [] - Just (1, e') -> [negateV e'] -- Pos e <=> (x + e' > 0) <=> (-e' < x) - Just (-1, _) -> [] -- Pos e <=> (-x + e' > 0) <=> (x < e') - _ -> error "should not happen" - - -- formula1を真にする最小のxが存在する場合 - case1 :: [(QFFormula, Witness)] - case1 = [ (subst1 x e formula1, WCase1 c e) - | j <- [1..delta], t <- ts, let e = t ^+^ LA.constant j ] - - -- formula1のなかの x < t を真に t < x を偽に置き換えた論理式 - formula2 :: QFFormula - formula2 = simplify $ f formula1 - where - f :: QFFormula -> QFFormula - f T = T - f F = F - f (And a b) = f a .&&. f b - f (Or a b) = f a .||. f b - f lit@(Lit (Pos e)) = - case LA.lookupCoeff x e of - Nothing -> lit - Just 1 -> F -- Pos e <=> ( x + e' > 0) <=> -e' < x - Just (-1) -> T -- Pos e <=> (-x + e' > 0) <=> x < e' - _ -> error "should not happen" - f lit@(Lit (Divisible _ _ _)) = lit - - -- us = {u | x < u は formula1 に現れる原子論理式} - us :: [ExprZ] - us = f formula1 - where - f :: QFFormula -> [ExprZ] - f T = [] - f F = [] - f (And a b) = f a ++ f b - f (Or a b) = f a ++ f b - f (Lit (Pos e)) = - case LA.extractMaybe x e of - Nothing -> [] - Just (1, _) -> [] -- Pos e <=> ( x + e' > 0) <=> -e' < x - Just (-1, e') -> [e'] -- Pos e <=> (-x + e' > 0) <=> x < e' - _ -> error "should not happen" - f (Lit (Divisible _ _ _)) = [] - - -- formula1を真にする最小のxが存在しない場合 - case2 :: [(QFFormula, Witness)] - case2 = [(subst1 x (LA.constant j) formula2, WCase2 c j delta us) | j <- [1..delta]] - -projectCasesN :: VarSet -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] -projectCasesN vs2 = f (IS.toList vs2) - where - f :: [Var] -> QFFormula -> [(QFFormula, Model Integer -> Model Integer)] - f [] formula = return (formula, id) - f (v:vs) formula = do - (formula2, mt1) <- projectCases v formula - (formula3, mt2) <- f vs formula2 - return (formula3, mt1 . mt2) - --- --------------------------------------------------------------------------- - -solveQFFormula :: VarSet -> QFFormula -> Maybe (Model Integer) -solveQFFormula vs formula = listToMaybe $ do - (formula2, mt) <- projectCasesN vs formula - case formula2 of - T -> return $ mt IM.empty - _ -> mzero - --- | solve a (open) quantifier-free formula -solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) -solve vs cs = solveQFFormula vs $ andB $ map fromLAAtom cs - --- | solve a (open) quantifier-free formula -solveQFLA :: VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) -solveQFLA vs cs ivs = listToMaybe $ do - (cs2, mt) <- FM.projectN rvs cs - m <- maybeToList $ solve ivs cs2 - return $ mt $ IM.map fromInteger m - where - rvs = vs `IS.difference` ivs - --- --------------------------------------------------------------------------- - -testHagiya :: QFFormula -testHagiya = fst $ project 1 $ andB [c1, c2, c3] - where - [x,y,z] = map LA.var [1..3] - c1 = x .<. (y ^+^ y) - c2 = z .<. x - c3 = 3 .|. x - -{- -∃ x. 0 < y+y ∧ z 0 ∧ 3|z+1) ∨ (2y-z > -2 ∧ 3|z+2) ∨ (2y-z > -3 ∧ 3|z+3) --} - -test3 :: QFFormula -test3 = fst $ project 1 $ andB [p1,p2,p3,p4] - where - x = LA.var 0 - y = LA.var 1 - p1 = LA.constant 0 .<. y - p2 = 2 *^ x .<. y - p3 = y .<. x ^+^ LA.constant 2 - p4 = 2 .|. y - -{- -∃ y. 0 < y ∧ 2x Maybe QFFormula -eliminateQuantifiers = f - where - f FOL.T = return T - f FOL.F = return F - f (FOL.Atom (Rel a op b)) = do - a' <- LAFOL.fromFOLExpr a - b' <- LAFOL.fromFOLExpr b - return $ fromLAAtom (Rel a' op b') - f (FOL.And a b) = liftM2 (.&&.) (f a) (f b) - f (FOL.Or a b) = liftM2 (.||.) (f a) (f b) - f (FOL.Not a) = f (FOL.pushNot a) - f (FOL.Imply a b) = f $ FOL.Or (FOL.Not a) b - f (FOL.Equiv a b) = f $ FOL.And (FOL.Imply a b) (FOL.Imply b a) - f (FOL.Forall x body) = liftM notB $ f $ FOL.Exists x $ FOL.Not body - f (FOL.Exists x body) = liftM (fst . project x) (f body) - -solveFormula :: VarSet -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Integer -solveFormula vs formula = - case eliminateQuantifiers formula of - Nothing -> FOL.Unknown - Just formula' -> - case solveQFFormula vs formula' of - Nothing -> FOL.Unsat - Just m -> FOL.Sat m diff --git a/src/ToySolver/Data/AlgebraicNumber/Complex.hs b/src/ToySolver/Data/AlgebraicNumber/Complex.hs --- a/src/ToySolver/Data/AlgebraicNumber/Complex.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Complex.hs @@ -31,7 +31,7 @@ import qualified Data.Map as Map import Data.Maybe -import qualified ToySolver.CAD as CAD +import qualified ToySolver.Arith.CAD as CAD import qualified ToySolver.Data.AlgebraicNumber.Real as AReal import ToySolver.Data.AlgebraicNumber.Real (AReal) import qualified ToySolver.Data.AlgebraicNumber.Root as Root @@ -113,9 +113,8 @@ roots :: UPolynomial Rational -> [AComplex] roots f = do let cs1 = [ (u, [Sign.Zero]), (v, [Sign.Zero]) ] - (cs2, cells2) <- CAD.project [(P.toUPolynomialOf p 0, ss) | (p,ss) <- cs1] - let tmp2 = CAD.project [(P.toUPolynomialOf p 1, ss) | (p,ss) <- cs2] - (cs3, cells3) <- tmp2 + (cs2, cells2) <- CAD.project' [(P.toUPolynomialOf p 0, ss) | (p,ss) <- cs1] + (cs3, cells3) <- CAD.project' [(P.toUPolynomialOf p 1, ss) | (p,ss) <- cs2] guard $ and [Sign.signOf v `elem` ss | (p,ss) <- cs3, let v = P.eval (\_ -> undefined) p] let m3 = Map.empty diff --git a/src/ToySolver/Data/AlgebraicNumber/Real.hs b/src/ToySolver/Data/AlgebraicNumber/Real.hs --- a/src/ToySolver/Data/AlgebraicNumber/Real.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Real.hs @@ -55,7 +55,7 @@ import qualified Text.PrettyPrint.HughesPJClass as PP import Text.PrettyPrint.HughesPJClass (Doc, PrettyLevel, Pretty (..), prettyParen) -import Data.Interval (Interval, EndPoint (..), (<=..<), (<..<=), (<..<), (!)) +import Data.Interval (Interval, Extended (..), (<=..<), (<..<=), (<..<), (!)) import qualified Data.Interval as Interval import ToySolver.Data.Polynomial (Polynomial, UPolynomial, X (..)) @@ -297,7 +297,7 @@ (Finite ub, inUB) = Interval.upperBound' i2 ceiling_lb = ceiling lb ceiling_ub = ceiling ub - i3 = NegInf <..<= Finite (fromInteger ceiling_lb) + i3 = NegInf <..<= fromInteger ceiling_lb -- | Same as 'floor'. floor' :: Integral b => AReal -> b @@ -312,7 +312,7 @@ (Finite ub, inUB) = Interval.upperBound' i2 floor_lb = floor lb floor_ub = floor ub - i3 = Finite (fromInteger floor_ub) <=..< PosInf + i3 = fromInteger floor_ub <=..< PosInf -- | The @n@th root of @a@ nthRoot :: Integer -> AReal -> AReal diff --git a/src/ToySolver/Data/AlgebraicNumber/Sturm.hs b/src/ToySolver/Data/AlgebraicNumber/Sturm.hs --- a/src/ToySolver/Data/AlgebraicNumber/Sturm.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Sturm.hs @@ -35,7 +35,7 @@ import Data.Maybe import qualified Data.Interval as Interval -import Data.Interval (Interval, EndPoint (..), (<..<=), (<=..<=)) +import Data.Interval (Interval, Extended (..), (<..<=), (<=..<=)) import ToySolver.Data.Polynomial (UPolynomial, X (..)) import qualified ToySolver.Data.Polynomial as P diff --git a/src/ToySolver/Data/ArithRel.hs b/src/ToySolver/Data/ArithRel.hs --- a/src/ToySolver/Data/ArithRel.hs +++ b/src/ToySolver/Data/ArithRel.hs @@ -22,10 +22,11 @@ , evalOp -- * Relation - , Rel (..) + , ArithRel (..) + , fromArithRel -- * DSL - , IsRel (..) + , IsArithRel (..) , (.<.), (.<=.), (.>=.), (.>.), (.==.), (./=.) ) where @@ -86,49 +87,52 @@ -- --------------------------------------------------------------------------- -- | type class for constructing relational formula -class IsRel e r | r -> e where - rel :: RelOp -> e -> e -> r +class IsArithRel e r | r -> e where + arithRel :: RelOp -> e -> e -> r -- | constructing relational formula -(.<.) :: IsRel e r => e -> e -> r -a .<. b = rel Lt a b +(.<.) :: IsArithRel e r => e -> e -> r +a .<. b = arithRel Lt a b -- | constructing relational formula -(.<=.) :: IsRel e r => e -> e -> r -a .<=. b = rel Le a b +(.<=.) :: IsArithRel e r => e -> e -> r +a .<=. b = arithRel Le a b -- | constructing relational formula -(.>.) :: IsRel e r => e -> e -> r -a .>. b = rel Gt a b +(.>.) :: IsArithRel e r => e -> e -> r +a .>. b = arithRel Gt a b -- | constructing relational formula -(.>=.) :: IsRel e r => e -> e -> r -a .>=. b = rel Ge a b +(.>=.) :: IsArithRel e r => e -> e -> r +a .>=. b = arithRel Ge a b -- | constructing relational formula -(.==.) :: IsRel e r => e -> e -> r -a .==. b = rel Eql a b +(.==.) :: IsArithRel e r => e -> e -> r +a .==. b = arithRel Eql a b -- | constructing relational formula -(./=.) :: IsRel e r => e -> e -> r -a ./=. b = rel NEq a b +(./=.) :: IsArithRel e r => e -> e -> r +a ./=. b = arithRel NEq a b -- --------------------------------------------------------------------------- -- | Atomic formula -data Rel e = Rel e RelOp e +data ArithRel e = ArithRel e RelOp e deriving (Show, Eq, Ord) -instance Complement (Rel c) where - notB (Rel lhs op rhs) = Rel lhs (negOp op) rhs +instance Complement (ArithRel c) where + notB (ArithRel lhs op rhs) = ArithRel lhs (negOp op) rhs -instance IsRel e (Rel e) where - rel op a b = Rel a op b +instance IsArithRel e (ArithRel e) where + arithRel op a b = ArithRel a op b -instance Variables e => Variables (Rel e) where - vars (Rel a _ b) = vars a `IS.union` vars b +instance Variables e => Variables (ArithRel e) where + vars (ArithRel a _ b) = vars a `IS.union` vars b -instance Functor Rel where - fmap f (Rel a op b) = Rel (f a) op (f b) +instance Functor ArithRel where + fmap f (ArithRel a op b) = ArithRel (f a) op (f b) + +fromArithRel :: IsArithRel e r => ArithRel e -> r +fromArithRel (ArithRel a op b) = arithRel op a b -- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Data/BoolExpr.hs b/src/ToySolver/Data/BoolExpr.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Data/BoolExpr.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.BoolExpr +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Boolean expression over a given type of atoms +-- +----------------------------------------------------------------------------- +module ToySolver.Data.BoolExpr + ( + -- * BoolExpr type + BoolExpr (..) + + -- * Operations + , fold + , simplify + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Data.Data +import Data.Foldable hiding (fold, concat, any) +import Data.Hashable +import Data.Traversable +import ToySolver.Data.Boolean +import ToySolver.Data.Var + +-- | Boolean expression over a given type of atoms +data BoolExpr a + = Atom a + | And [BoolExpr a] + | Or [BoolExpr a] + | Not (BoolExpr a) + | Imply (BoolExpr a) (BoolExpr a) + | Equiv (BoolExpr a) (BoolExpr a) + deriving (Eq, Ord, Show, Read, Typeable, Data) + +instance Functor BoolExpr where + fmap = fmapDefault + +instance Applicative BoolExpr where + pure = Atom + (<*>) = ap + +instance Monad BoolExpr where + return = pure + m >>= f = fold f m + +instance Foldable BoolExpr where + foldMap = foldMapDefault + +instance Traversable BoolExpr where + traverse f (Atom x) = Atom <$> f x + traverse f (And xs) = And <$> sequenceA (fmap (traverse f) xs) + traverse f (Or xs) = Or <$> sequenceA (fmap (traverse f) xs) + traverse f (Not x) = Not <$> traverse f x + traverse f (Imply x y) = Imply <$> traverse f x <*> traverse f y + traverse f (Equiv x y) = Equiv <$> traverse f x <*> traverse f y + +instance NFData a => NFData (BoolExpr a) where + rnf (Atom a) = rnf a + rnf (And xs) = rnf xs + rnf (Or xs) = rnf xs + rnf (Not x) = rnf x + rnf (Imply x y) = rnf x `seq` rnf y + rnf (Equiv x y) = rnf x `seq` rnf y + +instance Hashable a => Hashable (BoolExpr a) where + hashWithSalt s (Atom a) = s `hashWithSalt` (0::Int) `hashWithSalt` a + hashWithSalt s (And xs) = s `hashWithSalt` (1::Int) `hashWithSalt` xs + hashWithSalt s (Or xs) = s `hashWithSalt` (2::Int) `hashWithSalt` xs + hashWithSalt s (Not x) = s `hashWithSalt` (3::Int) `hashWithSalt` x + hashWithSalt s (Imply x y) = s `hashWithSalt` (4::Int) `hashWithSalt` x `hashWithSalt` y + hashWithSalt s (Equiv x y) = s `hashWithSalt` (5::Int) `hashWithSalt` x `hashWithSalt` y + +instance Complement (BoolExpr a) where + notB = Not + +instance MonotoneBoolean (BoolExpr a) where + andB = And + orB = Or + +instance Boolean (BoolExpr a) where + (.=>.) = Imply + (.<=>.) = Equiv + +instance Variables a => Variables (BoolExpr a) where + vars = foldMap vars + + +fold :: Boolean b => (atom -> b) -> BoolExpr atom -> b +fold f = g + where + g (Atom a) = f a + g (Or xs) = orB (map g xs) + g (And xs) = andB (map g xs) + g (Not x) = notB (g x) + g (Imply x y) = g x .=>. g y + g (Equiv x y) = g x .<=>. g y + +{-# RULES + "fold/fmap" forall f g e. fold f (fmap g e) = fold (f.g) e + #-} + +simplify :: BoolExpr a -> BoolExpr a +simplify = runSimplify . fold (Simplify . Atom) + +newtype Simplify a = Simplify{ runSimplify :: BoolExpr a } + +instance Complement (Simplify a) where + notB (Simplify (Not x)) = Simplify x + notB (Simplify x) = Simplify (Not x) + +instance MonotoneBoolean (Simplify a) where + orB xs + | any isTrue ys = Simplify true + | otherwise = Simplify $ Or ys + where + ys = concat [f x | Simplify x <- xs] + f (Or zs) = zs + f z = [z] + andB xs + | any isFalse ys = Simplify false + | otherwise = Simplify $ And ys + where + ys = concat [f x | Simplify x <- xs] + f (And zs) = zs + f z = [z] + +instance Boolean (Simplify a) where + Simplify x .=>. Simplify y + | isFalse x = true + | isTrue y = true + | isTrue x = Simplify y + | isFalse y = notB (Simplify x) + | otherwise = Simplify (x .=>. y) + +isTrue :: BoolExpr a -> Bool +isTrue (And []) = True +isTrue _ = False + +isFalse :: BoolExpr a -> Bool +isFalse (Or []) = True +isFalse _ = False diff --git a/src/ToySolver/Data/Boolean.hs b/src/ToySolver/Data/Boolean.hs --- a/src/ToySolver/Data/Boolean.hs +++ b/src/ToySolver/Data/Boolean.hs @@ -15,41 +15,90 @@ module ToySolver.Data.Boolean ( -- * Boolean algebra - Complement (..) + MonotoneBoolean (..) + , Complement (..) , Boolean (..) - , andB - , orB ) where +import Control.Arrow + infixr 3 .&&. infixr 2 .||. infix 1 .=>., .<=>. +class MonotoneBoolean a where + true, false :: a + (.&&.) :: a -> a -> a + (.||.) :: a -> a -> a + andB :: [a] -> a + orB :: [a] -> a + + true = andB [] + false = orB [] + a .&&. b = andB [a,b] + a .||. b = orB [a,b] + + andB [] = true + andB [a] = a + andB xs = foldr1 (.&&.) xs + + orB [] = false + orB [a] = a + orB xs = foldr1 (.||.) xs + + {-# MINIMAL ((true, (.&&.)) | andB), ((false, (.||.)) | orB) #-} + -- | types that can be negated. class Complement a where notB :: a -> a -- | types that can be combined with boolean operations. -class Complement a => Boolean a where - true, false :: a - (.&&.) :: a -> a -> a - (.||.) :: a -> a -> a - +class (MonotoneBoolean a, Complement a) => Boolean a where (.=>.), (.<=>.) :: a -> a -> a x .=>. y = notB x .||. y x .<=>. y = (x .=>. y) .&&. (y .=>. x) -andB :: Boolean a => [a] -> a -andB = foldr (.&&.) true -orB :: Boolean a => [a] -> a -orB = foldr (.||.) false +instance (Complement a, Complement b) => Complement (a, b) where + notB (a,b) = (notB a, notB b) +instance (MonotoneBoolean a, MonotoneBoolean b) => MonotoneBoolean (a, b) where + true = (true, true) + false = (false, false) + (xs1,ys1) .&&. (xs2,ys2) = (xs1 .&&. xs2, ys1 .&&. ys2) + (xs1,ys1) .||. (xs2,ys2) = (xs1 .||. xs2, ys1 .||. ys2) + andB = (andB *** andB) . unzip + orB = (orB *** orB) . unzip + +instance (Boolean a, Boolean b) => Boolean (a, b) where + (xs1,ys1) .=>. (xs2,ys2) = (xs1 .=>. xs2, ys1 .=>. ys2) + (xs1,ys1) .<=>. (xs2,ys2) = (xs1 .<=>. xs2, ys1 .<=>. ys2) + + +instance Complement a => Complement (b -> a) where + notB f = \x -> notB (f x) + +instance MonotoneBoolean a => MonotoneBoolean (b -> a) where + true = const true + false = const false + f .&&. g = \x -> f x .&&. g x + f .||. g = \x -> f x .||. g x + andB fs = \x -> andB [f x | f <- fs] + orB fs = \x -> orB [f x | f <- fs] + +instance (Boolean a) => Boolean (b -> a) where + f .=>. g = \x -> f x .=>. g x + f .<=>. g = \x -> f x .<=>. g x + + instance Complement Bool where notB = not -instance Boolean Bool where +instance MonotoneBoolean Bool where true = True false = False (.&&.) = (&&) (.||.) = (||) + +instance Boolean Bool where + (.<=>.) = (==) diff --git a/src/ToySolver/Data/DNF.hs b/src/ToySolver/Data/DNF.hs --- a/src/ToySolver/Data/DNF.hs +++ b/src/ToySolver/Data/DNF.hs @@ -26,8 +26,11 @@ instance Complement lit => Complement (DNF lit) where notB (DNF xs) = DNF . sequence . map (map notB) $ xs -instance Complement lit => Boolean (DNF lit) where +instance MonotoneBoolean (DNF lit) where true = DNF [[]] false = DNF [] DNF xs .||. DNF ys = DNF (xs++ys) DNF xs .&&. DNF ys = DNF [x++y | x<-xs, y<-ys] + +instance Complement lit => Boolean (DNF lit) + diff --git a/src/ToySolver/Data/FOL/Arith.hs b/src/ToySolver/Data/FOL/Arith.hs --- a/src/ToySolver/Data/FOL/Arith.hs +++ b/src/ToySolver/Data/FOL/Arith.hs @@ -96,13 +96,13 @@ -- --------------------------------------------------------------------------- -- | Atomic formula -type Atom c = Rel (Expr c) +type Atom c = ArithRel (Expr c) evalAtom :: (Real r, Fractional r) => Model r -> Atom r -> Bool -evalAtom m (Rel a op b) = evalOp op (evalExpr m a) (evalExpr m b) +evalAtom m (ArithRel a op b) = evalOp op (evalExpr m a) (evalExpr m b) -instance IsRel (Expr c) (Formula (Atom c)) where - rel op a b = Atom $ rel op a b +instance IsArithRel (Expr c) (Formula (Atom c)) where + arithRel op a b = Atom (arithRel op a b) -- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Data/FOL/Formula.hs b/src/ToySolver/Data/FOL/Formula.hs --- a/src/ToySolver/Data/FOL/Formula.hs +++ b/src/ToySolver/Data/FOL/Formula.hs @@ -57,11 +57,13 @@ instance Complement (Formula a) where notB = Not -instance Boolean (Formula c) where +instance MonotoneBoolean (Formula c) where true = T false = F (.&&.) = And (.||.) = Or + +instance Boolean (Formula c) where (.=>.) = Imply (.<=>.) = Equiv @@ -70,10 +72,10 @@ pushNot T = F pushNot F = T pushNot (Atom a) = Atom $ notB a -pushNot (And a b) = Or (pushNot a) (pushNot b) -pushNot (Or a b) = And (pushNot a) (pushNot b) +pushNot (And a b) = pushNot a .||. pushNot b +pushNot (Or a b) = pushNot a .&&. pushNot b pushNot (Not a) = a -pushNot (Imply a b) = And a (pushNot b) -pushNot (Equiv a b) = Or (And a (pushNot b)) (And b (pushNot a)) +pushNot (Imply a b) = a .&&. pushNot b +pushNot (Equiv a b) = a .&&. pushNot b .||. b .&&. pushNot a pushNot (Forall v a) = Exists v (pushNot a) pushNot (Exists v a) = Forall v (pushNot a) diff --git a/src/ToySolver/Data/LA.hs b/src/ToySolver/Data/LA.hs --- a/src/ToySolver/Data/LA.hs +++ b/src/ToySolver/Data/LA.hs @@ -47,6 +47,8 @@ , Atom (..) , showAtom , evalAtom + , applySubstAtom + , applySubst1Atom , solveFor , module ToySolver.Data.ArithRel @@ -251,21 +253,28 @@ ----------------------------------------------------------------------------- -- | Atomic Formula of Linear Arithmetics -type Atom r = Rel (Expr r) +type Atom r = ArithRel (Expr r) showAtom :: (Num r, Eq r, Show r) => Atom r -> String -showAtom (Rel lhs op rhs) = showExpr lhs ++ showOp op ++ showExpr rhs +showAtom (ArithRel lhs op rhs) = showExpr lhs ++ showOp op ++ showExpr rhs -- | evaluate the formula under the model. evalAtom :: (Num r, Ord r) => Model r -> Atom r -> Bool -evalAtom m (Rel lhs op rhs) = evalOp op (evalExpr m lhs) (evalExpr m rhs) +evalAtom m (ArithRel lhs op rhs) = evalOp op (evalExpr m lhs) (evalExpr m rhs) +applySubstAtom :: (Num r, Eq r) => VarMap (Expr r) -> Atom r -> Atom r +applySubstAtom s (ArithRel lhs op rhs) = ArithRel (applySubst s lhs) op (applySubst s rhs) + +-- | applySubst1 x e phi == phi[e/x] +applySubst1Atom :: (Num r, Eq r) => Var -> Expr r -> Atom r -> Atom r +applySubst1Atom x e (ArithRel lhs op rhs) = ArithRel (applySubst1 x e lhs) op (applySubst1 x e rhs) + -- | Solve linear (in)equation for the given variable. -- -- @solveFor a v@ returns @Just (op, e)@ such that @Atom v op e@ -- is equivalent to @a@. solveFor :: (Real r, Fractional r) => Atom r -> Var -> Maybe (RelOp, Expr r) -solveFor (Rel lhs op rhs) v = do +solveFor (ArithRel lhs op rhs) v = do (c,e) <- extractMaybe v (lhs ^-^ rhs) return ( if c < 0 then flipOp op else op , (1/c) *^ negateV e diff --git a/src/ToySolver/Data/LA/FOL.hs b/src/ToySolver/Data/LA/FOL.hs --- a/src/ToySolver/Data/LA/FOL.hs +++ b/src/ToySolver/Data/LA/FOL.hs @@ -16,10 +16,10 @@ -- --------------------------------------------------------------------------- fromFOLAtom :: (Real r, Fractional r) => Atom r -> Maybe (LA.Atom r) -fromFOLAtom (Rel a op b) = do +fromFOLAtom (ArithRel a op b) = do a' <- fromFOLExpr a b' <- fromFOLExpr b - return $ rel op a' b' + return $ arithRel op a' b' toFOLFormula :: (Real r, Fractional r) => LA.Atom r -> Formula (Atom r) toFOLFormula r = Atom $ fmap toFOLExpr r diff --git a/src/ToySolver/Data/MIP.hs b/src/ToySolver/Data/MIP.hs --- a/src/ToySolver/Data/MIP.hs +++ b/src/ToySolver/Data/MIP.hs @@ -13,210 +13,56 @@ -- ----------------------------------------------------------------------------- module ToySolver.Data.MIP - ( Problem (..) - , Expr - , Term (..) - , OptDir (..) - , ObjectiveFunction - , Constraint (..) - , Bounds - , Label - , Var - , VarType (..) - , VarInfo (..) - , BoundExpr (..) - , RelOp (..) - , SOSType (..) - , SOSConstraint (..) - , defaultBounds - , defaultLB - , defaultUB - , toVar - , fromVar - , getVarInfo - , getVarType - , getBounds - , variables - , integerVariables - , semiContinuousVariables - , semiIntegerVariables - - -- * Utilities - , Variables (..) - , intersectBounds + ( module ToySolver.Data.MIP.Base + , readFile + , readLPFile + , readMPSFile + , writeFile + , writeLPFile + , writeMPSFile ) where -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Interned (intern, unintern) -import Data.Interned.String -import Data.OptDir - --- --------------------------------------------------------------------------- - --- | Problem -data Problem - = Problem - { dir :: OptDir - , objectiveFunction :: ObjectiveFunction - , constraints :: [Constraint] - , sosConstraints :: [SOSConstraint] - , userCuts :: [Constraint] - , varInfo :: Map Var VarInfo - } - deriving (Show, Eq, Ord) - --- | expressions -type Expr = [Term] - --- | terms -data Term = Term Rational [Var] - deriving (Eq, Ord, Show) - --- | objective function -type ObjectiveFunction = (Maybe Label, Expr) - --- | constraint -data Constraint - = Constraint - { constrLabel :: Maybe Label - , constrIndicator :: Maybe (Var, Rational) - , constrBody :: (Expr, RelOp, Rational) - , constrIsLazy :: Bool - } - deriving (Eq, Ord, Show) - -data VarType - = ContinuousVariable - | IntegerVariable --- 'nothaddock' is inserted not to confuse haddock - -- nothaddock | BinaryVariable - | SemiContinuousVariable - | SemiIntegerVariable - deriving (Eq, Ord, Show) - -data VarInfo - = VarInfo - { varType :: VarType - , varBounds :: Bounds - } - deriving (Eq, Ord, Show) - -defaultVarInfo :: VarInfo -defaultVarInfo - = VarInfo - { varType = ContinuousVariable - , varBounds = defaultBounds - } - --- | type for representing lower/upper bound of variables -type Bounds = (BoundExpr, BoundExpr) - --- | label -type Label = String - --- | variable -type Var = InternedString - --- | type for representing lower/upper bound of variables -data BoundExpr = NegInf | Finite Rational | PosInf - deriving (Eq, Ord, Show) - --- | relational operators -data RelOp = Le | Ge | Eql - deriving (Eq, Ord, Enum, Show) - --- | types of SOS (special ordered sets) constraints -data SOSType - = S1 -- ^ Type 1 SOS constraint - | S2 -- ^ Type 2 SOS constraint - deriving (Eq, Ord, Enum, Show, Read) - --- | SOS (special ordered sets) constraints -data SOSConstraint - = SOSConstraint - { sosLabel :: Maybe Label - , sosType :: SOSType - , sosBody :: [(Var, Rational)] - } - deriving (Eq, Ord, Show) - -class Variables a where - vars :: a -> Set Var - -instance Variables a => Variables [a] where - vars = Set.unions . map vars - -instance (Variables a, Variables b) => Variables (Either a b) where - vars (Left a) = vars a - vars (Right b) = vars b - -instance Variables Problem where - vars = variables - -instance Variables Term where - vars (Term _ xs) = Set.fromList xs - -instance Variables Constraint where - vars Constraint{ constrIndicator = ind, constrBody = (lhs, _, _) } = - vars lhs `Set.union` vs2 - where - vs2 = maybe Set.empty (Set.singleton . fst) ind - -instance Variables SOSConstraint where - vars SOSConstraint{ sosBody = xs } = Set.fromList (map fst xs) - --- | default bounds -defaultBounds :: Bounds -defaultBounds = (defaultLB, defaultUB) - --- | default lower bound (0) -defaultLB :: BoundExpr -defaultLB = Finite 0 - --- | default upper bound (+∞) -defaultUB :: BoundExpr -defaultUB = PosInf - --- | convert a string into a variable -toVar :: String -> Var -toVar = intern - --- | convert a variable into a string -fromVar :: Var -> String -fromVar = unintern - --- | looking up attributes for a variable -getVarInfo :: Problem -> Var -> VarInfo -getVarInfo lp v = Map.findWithDefault defaultVarInfo v (varInfo lp) +import Prelude hiding (readFile, writeFile) +import qualified Prelude as P +import Data.Char +import System.FilePath (takeExtension) +import Text.Parsec --- | looking up bounds for a variable -getVarType :: Problem -> Var -> VarType -getVarType lp v = varType $ getVarInfo lp v +import ToySolver.Data.MIP.Base +import qualified ToySolver.Text.LPFile as LPFile +import qualified ToySolver.Text.MPSFile as MPSFile --- | looking up bounds for a variable -getBounds :: Problem -> Var -> Bounds -getBounds lp v = varBounds $ getVarInfo lp v +-- | Parse .lp or .mps file based on file extension +readFile :: FilePath -> IO (Either ParseError Problem) +readFile fname = + case map toLower (takeExtension fname) of + ".lp" -> readLPFile fname + ".mps" -> readMPSFile fname + ext -> ioError $ userError $ "unknown extension: " ++ ext -intersectBounds :: Bounds -> Bounds -> Bounds -intersectBounds (lb1,ub1) (lb2,ub2) = (max lb1 lb2, min ub1 ub2) +-- | Parse a file containing LP file data. +readLPFile :: FilePath -> IO (Either ParseError Problem) +readLPFile = LPFile.parseFile -variables :: Problem -> Set Var -variables lp = Map.keysSet $ varInfo lp +-- | Parse a file containing MPS file data. +readMPSFile :: FilePath -> IO (Either ParseError Problem) +readMPSFile = MPSFile.parseFile -integerVariables :: Problem -> Set Var -integerVariables lp = Map.keysSet $ Map.filter p (varInfo lp) - where - p VarInfo{ varType = vt } = vt == IntegerVariable +writeFile :: FilePath -> Problem -> IO () +writeFile fname prob = + case map toLower (takeExtension fname) of + ".lp" -> writeLPFile fname prob + ".mps" -> writeMPSFile fname prob + ext -> ioError $ userError $ "unknown extension: " ++ ext -semiContinuousVariables :: Problem -> Set Var -semiContinuousVariables lp = Map.keysSet $ Map.filter p (varInfo lp) - where - p VarInfo{ varType = vt } = vt == SemiContinuousVariable +writeLPFile :: FilePath -> Problem -> IO () +writeLPFile fname prob = + case LPFile.render prob of + Left err -> ioError $ userError err + Right s -> P.writeFile fname s -semiIntegerVariables :: Problem -> Set Var -semiIntegerVariables lp = Map.keysSet $ Map.filter p (varInfo lp) - where - p VarInfo{ varType = vt } = vt == SemiIntegerVariable +writeMPSFile :: FilePath -> Problem -> IO () +writeMPSFile fname prob = + case MPSFile.render prob of + Left err -> ioError $ userError err + Right s -> P.writeFile fname s diff --git a/src/ToySolver/Data/MIP/Base.hs b/src/ToySolver/Data/MIP/Base.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Data/MIP/Base.hs @@ -0,0 +1,248 @@ +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.MIP.Base +-- Copyright : (c) Masahiro Sakai 2011-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Mixed-Integer Programming Problems with some commmonly used extensions +-- +----------------------------------------------------------------------------- +module ToySolver.Data.MIP.Base + ( Problem (..) + , Expr + , Term (..) + , OptDir (..) + , ObjectiveFunction + , Constraint (..) + , Bounds + , Label + , Var + , VarType (..) + , VarInfo (..) + , BoundExpr + , Extended (..) + , RelOp (..) + , SOSType (..) + , SOSConstraint (..) + , defaultBounds + , defaultLB + , defaultUB + , toVar + , fromVar + , getVarInfo + , getVarType + , getBounds + , variables + , integerVariables + , semiContinuousVariables + , semiIntegerVariables + + -- * Utilities + , Variables (..) + , intersectBounds + ) where + +import Data.Default.Class +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Interned (intern, unintern) +import Data.Interned.String +import Data.ExtendedReal +import Data.OptDir + +-- --------------------------------------------------------------------------- + +-- | Problem +data Problem + = Problem + { dir :: OptDir + , objectiveFunction :: ObjectiveFunction + , constraints :: [Constraint] + , sosConstraints :: [SOSConstraint] + , userCuts :: [Constraint] + , varInfo :: Map Var VarInfo + } + deriving (Show, Eq, Ord) + +instance Default Problem where + def = Problem + { dir = OptMin + , objectiveFunction = (Nothing, []) + , constraints = [] + , sosConstraints = [] + , userCuts = [] + , varInfo = Map.empty + } + +-- | expressions +type Expr = [Term] + +-- | terms +data Term = Term Rational [Var] + deriving (Eq, Ord, Show) + +-- | objective function +type ObjectiveFunction = (Maybe Label, Expr) + +-- | constraint +data Constraint + = Constraint + { constrLabel :: Maybe Label + , constrIndicator :: Maybe (Var, Rational) + , constrBody :: (Expr, RelOp, Rational) + , constrIsLazy :: Bool + } + deriving (Eq, Ord, Show) + +instance Default Constraint where + def = Constraint + { constrLabel = Nothing + , constrIndicator = Nothing + , constrBody = ([], Le, 0) + , constrIsLazy = False + } + +data VarType + = ContinuousVariable + | IntegerVariable +-- 'nothaddock' is inserted not to confuse haddock + -- nothaddock | BinaryVariable + | SemiContinuousVariable + | SemiIntegerVariable + deriving (Eq, Ord, Show) + +instance Default VarType where + def = ContinuousVariable + +data VarInfo + = VarInfo + { varType :: VarType + , varBounds :: Bounds + } + deriving (Eq, Ord, Show) + +instance Default VarInfo where + def = defaultVarInfo + +defaultVarInfo :: VarInfo +defaultVarInfo + = VarInfo + { varType = ContinuousVariable + , varBounds = defaultBounds + } + +-- | type for representing lower/upper bound of variables +type Bounds = (BoundExpr, BoundExpr) + +-- | label +type Label = String + +-- | variable +type Var = InternedString + +-- | type for representing lower/upper bound of variables +type BoundExpr = Extended Rational + +-- | relational operators +data RelOp = Le | Ge | Eql + deriving (Eq, Ord, Enum, Show) + +-- | types of SOS (special ordered sets) constraints +data SOSType + = S1 -- ^ Type 1 SOS constraint + | S2 -- ^ Type 2 SOS constraint + deriving (Eq, Ord, Enum, Show, Read) + +-- | SOS (special ordered sets) constraints +data SOSConstraint + = SOSConstraint + { sosLabel :: Maybe Label + , sosType :: SOSType + , sosBody :: [(Var, Rational)] + } + deriving (Eq, Ord, Show) + +class Variables a where + vars :: a -> Set Var + +instance Variables a => Variables [a] where + vars = Set.unions . map vars + +instance (Variables a, Variables b) => Variables (Either a b) where + vars (Left a) = vars a + vars (Right b) = vars b + +instance Variables Problem where + vars = variables + +instance Variables Term where + vars (Term _ xs) = Set.fromList xs + +instance Variables Constraint where + vars Constraint{ constrIndicator = ind, constrBody = (lhs, _, _) } = + vars lhs `Set.union` vs2 + where + vs2 = maybe Set.empty (Set.singleton . fst) ind + +instance Variables SOSConstraint where + vars SOSConstraint{ sosBody = xs } = Set.fromList (map fst xs) + +-- | default bounds +defaultBounds :: Bounds +defaultBounds = (defaultLB, defaultUB) + +-- | default lower bound (0) +defaultLB :: BoundExpr +defaultLB = 0 + +-- | default upper bound (+∞) +defaultUB :: BoundExpr +defaultUB = PosInf + +-- | convert a string into a variable +toVar :: String -> Var +toVar = intern + +-- | convert a variable into a string +fromVar :: Var -> String +fromVar = unintern + +-- | looking up attributes for a variable +getVarInfo :: Problem -> Var -> VarInfo +getVarInfo lp v = Map.findWithDefault defaultVarInfo v (varInfo lp) + +-- | looking up bounds for a variable +getVarType :: Problem -> Var -> VarType +getVarType lp v = varType $ getVarInfo lp v + +-- | looking up bounds for a variable +getBounds :: Problem -> Var -> Bounds +getBounds lp v = varBounds $ getVarInfo lp v + +intersectBounds :: Bounds -> Bounds -> Bounds +intersectBounds (lb1,ub1) (lb2,ub2) = (max lb1 lb2, min ub1 ub2) + +variables :: Problem -> Set Var +variables lp = Map.keysSet $ varInfo lp + +integerVariables :: Problem -> Set Var +integerVariables lp = Map.keysSet $ Map.filter p (varInfo lp) + where + p VarInfo{ varType = vt } = vt == IntegerVariable + +semiContinuousVariables :: Problem -> Set Var +semiContinuousVariables lp = Map.keysSet $ Map.filter p (varInfo lp) + where + p VarInfo{ varType = vt } = vt == SemiContinuousVariable + +semiIntegerVariables :: Problem -> Set Var +semiIntegerVariables lp = Map.keysSet $ Map.filter p (varInfo lp) + where + p VarInfo{ varType = vt } = vt == SemiIntegerVariable diff --git a/src/ToySolver/Data/Polynomial.hs b/src/ToySolver/Data/Polynomial.hs --- a/src/ToySolver/Data/Polynomial.hs +++ b/src/ToySolver/Data/Polynomial.hs @@ -81,6 +81,7 @@ -- * Term , Term , tdeg + , tscale , tmult , tdivides , tdiv diff --git a/src/ToySolver/Data/Polynomial/Base.hs b/src/ToySolver/Data/Polynomial/Base.hs --- a/src/ToySolver/Data/Polynomial/Base.hs +++ b/src/ToySolver/Data/Polynomial/Base.hs @@ -82,6 +82,7 @@ -- * Term , Term , tdeg + , tscale , tmult , tdivides , tdiv @@ -125,6 +126,7 @@ import Control.DeepSeq import Control.Exception (assert) import Control.Monad +import Data.Default.Class import Data.Data import qualified Data.FiniteField as FF import Data.Function @@ -382,23 +384,37 @@ divModMP :: forall k v. (Eq k, Fractional k, Ord v) => MonomialOrder v -> Polynomial k v -> [Polynomial k v] -> ([Polynomial k v], Polynomial k v) -divModMP cmp p fs = go IntMap.empty p +divModMP cmp p fs = go IntMap.empty (terms' p) where - ls = [(lt cmp f, f) | f <- fs] + terms' :: Polynomial k v -> [Term k v] + terms' g = sortBy (flip cmp `on` snd) (terms g) - go :: IntMap (Polynomial k v) -> Polynomial k v -> ([Polynomial k v], Polynomial k v) + merge :: [Term k v] -> [Term k v] -> [Term k v] + merge [] ys = ys + merge xs [] = xs + merge xxs@(x:xs) yys@(y:ys) = + case cmp (snd x) (snd y) of + GT -> x : merge xs yys + LT -> y : merge xxs ys + EQ -> + case fst x + fst y of + 0 -> merge xs ys + c -> (c, snd x) : merge xs ys + + ls = zip [0..] [(lt cmp f, terms' f) | f <- fs] + + go :: IntMap (Polynomial k v) -> [Term k v] -> ([Polynomial k v], Polynomial k v) go qs g = case xs of - [] -> ([IntMap.findWithDefault 0 i qs | i <- [0 .. length fs - 1]], g) + [] -> ([IntMap.findWithDefault 0 i qs | i <- [0 .. length fs - 1]], fromTerms g) (i, b, g') : _ -> go (IntMap.insertWith (+) i b qs) g' where - ms = sortBy (flip cmp `on` snd) (terms g) xs = do - (i,(a,f)) <- zip [0..] ls - h <- ms + (i,(a,f)) <- ls + h <- g guard $ a `tdivides` h - let b = fromTerm $ tdiv h a - return (i, b, g - b * f) + let b = tdiv h a + return (i, fromTerm b, merge g [(tscale (-1) b `tmult` m) | m <- f]) -- | Multivariate division algorithm -- @@ -442,6 +458,9 @@ , pOptMonomialOrder :: MonomialOrder v } +instance (PrettyCoeff k, PrettyVar v, Ord v) => Default (PrintOptions k v) where + def = defaultPrintOptions + defaultPrintOptions :: (PrettyCoeff k, PrettyVar v, Ord v) => PrintOptions k v defaultPrintOptions = PrintOptions @@ -452,7 +471,7 @@ } instance (Ord k, Num k, Ord v, PrettyCoeff k, PrettyVar v) => Pretty (Polynomial k v) where - pPrintPrec = prettyPrint defaultPrintOptions + pPrintPrec = prettyPrint def prettyPrint :: (Ord k, Num k, Ord v) @@ -680,6 +699,9 @@ tdeg :: Term k v -> Integer tdeg (_,xs) = deg xs + +tscale :: (Num k, Ord v) => k -> Term k v -> Term k v +tscale a (c, xs) = (a*c, xs) tmult :: (Num k, Ord v) => Term k v -> Term k v -> Term k v tmult (c1,xs1) (c2,xs2) = (c1*c2, xs1 `mmult` xs2) diff --git a/src/ToySolver/Data/Polynomial/GroebnerBasis.hs b/src/ToySolver/Data/Polynomial/GroebnerBasis.hs --- a/src/ToySolver/Data/Polynomial/GroebnerBasis.hs +++ b/src/ToySolver/Data/Polynomial/GroebnerBasis.hs @@ -39,6 +39,7 @@ , reduceGBasis ) where +import Data.Default.Class import qualified Data.Set as Set import qualified Data.Heap as H -- http://hackage.haskell.org/package/heaps import ToySolver.Data.Polynomial.Base (Polynomial, Monomial, MonomialOrder) @@ -49,6 +50,9 @@ { optStrategy :: Strategy } +instance Default Options where + def = defaultOptions + defaultOptions :: Options defaultOptions = Options @@ -76,7 +80,7 @@ => MonomialOrder v -> [Polynomial k v] -> [Polynomial k v] -basis = basis' defaultOptions +basis = basis' def basis' :: forall k v. (Eq k, Fractional k, Ord k, Ord v) diff --git a/src/ToySolver/Data/Vec.hs b/src/ToySolver/Data/Vec.hs deleted file mode 100644 --- a/src/ToySolver/Data/Vec.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.Vec --- Copyright : (c) Masahiro Sakai 2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (BangPatterns, FlexibleContexts, ScopedTypeVariables) --- --- Simple 1-dimentional resizable array --- ------------------------------------------------------------------------------ -module ToySolver.Data.Vec - ( - -- * Vec type - GenericVec - , Vec - , UVec - , Index - - -- * Constructors - , new - , clone - - -- * Operators - , getSize - , read - , write - , unsafeRead - , unsafeWrite - , resize - , growTo - , push - , clear - , getElems - - -- * Low-level operators - , getArray - , getCapacity - , resizeCapacity - ) where - -import Prelude hiding (read) - -import Control.Loop -import Control.Monad -import Data.Ix -import qualified Data.Array.Base as A -import qualified Data.Array.IO as A -import Data.IORef - -newtype GenericVec a e = GenericVec (IORef (Int, a Index e)) - deriving Eq - -type Vec e = GenericVec A.IOArray e -type UVec e = GenericVec A.IOUArray e - -type Index = Int - -new :: A.MArray a e IO => IO (GenericVec a e) -new = do - a <- A.newArray_ (0,-1) - ref <- newIORef (0,a) - return $ GenericVec ref - -{- INLINE getSize #-} --- | Get the internal representation array -getSize :: A.MArray a e IO => GenericVec a e -> IO Int -getSize (GenericVec ref) = liftM fst $ readIORef ref - -{-# SPECIALIZE read :: Vec e -> Int -> IO e #-} -{-# SPECIALIZE read :: UVec Int -> Int -> IO Int #-} -{-# SPECIALIZE read :: UVec Double -> Int -> IO Double #-} -{-# SPECIALIZE read :: UVec Bool -> Int -> IO Bool #-} -read :: A.MArray a e IO => GenericVec a e -> Int -> IO e -read !v !i = do - a <- getArray v - s <- getSize v - if 0 <= i && i < s then - A.unsafeRead a i - else - error $ "ToySolver.Data.Vec.read: index " ++ show i ++ " out of bounds" - -{-# SPECIALIZE write :: Vec e -> Int -> e -> IO () #-} -{-# SPECIALIZE write :: UVec Int -> Int -> Int -> IO () #-} -{-# SPECIALIZE write :: UVec Double -> Int -> Double -> IO () #-} -{-# SPECIALIZE write :: UVec Bool -> Int -> Bool -> IO () #-} -write :: A.MArray a e IO => GenericVec a e -> Int -> e -> IO () -write !v !i e = do - a <- getArray v - s <- getSize v - if 0 <= i && i < s then - A.unsafeWrite a i e - else - error $ "ToySolver.Data.Vec.write: index " ++ show i ++ " out of bounds" - -{-# INLINE unsafeRead #-} -unsafeRead :: A.MArray a e IO => GenericVec a e -> Int -> IO e -unsafeRead !v !i = do - a <- getArray v - A.unsafeRead a i - -{-# INLINE unsafeWrite #-} -unsafeWrite :: A.MArray a e IO => GenericVec a e -> Int -> e -> IO () -unsafeWrite !v !i e = do - a <- getArray v - A.unsafeWrite a i e - -{-# SPECIALIZE resize :: Vec e -> Int -> IO () #-} -{-# SPECIALIZE resize :: UVec Int -> Int -> IO () #-} -{-# SPECIALIZE resize :: UVec Double -> Int -> IO () #-} -{-# SPECIALIZE resize :: UVec Bool -> Int -> IO () #-} -resize :: A.MArray a e IO => GenericVec a e -> Int -> IO () -resize v@(GenericVec ref) !n = do - a <- getArray v - capa <- getCapacity v - if n <= capa then do - writeIORef ref (n,a) - else do - let capa' = max 2 (capa * 3 `div` 2) - a' <- A.newArray_ (0, capa'-1) - copyTo a a' (0,capa-1) - writeIORef ref (n,a') - -{-# SPECIALIZE growTo :: Vec e -> Int -> IO () #-} -{-# SPECIALIZE growTo :: UVec Int -> Int -> IO () #-} -{-# SPECIALIZE growTo :: UVec Double -> Int -> IO () #-} -{-# SPECIALIZE growTo :: UVec Bool -> Int -> IO () #-} -growTo :: A.MArray a e IO => GenericVec a e -> Int -> IO () -growTo v !n = do - m <- getSize v - when (m < n) $ resize v n - -{-# SPECIALIZE push :: Vec e -> e -> IO () #-} -{-# SPECIALIZE push :: UVec Int -> Int -> IO () #-} -{-# SPECIALIZE push :: UVec Double -> Double -> IO () #-} -{-# SPECIALIZE push :: UVec Bool -> Bool -> IO () #-} -push :: A.MArray a e IO => GenericVec a e -> e -> IO () -push v e = do - s <- getSize v - resize v (s+1) - unsafeWrite v s e - -clear :: A.MArray a e IO => GenericVec a e -> IO () -clear v = resize v 0 - -getElems :: A.MArray a e IO => GenericVec a e -> IO [e] -getElems v = do - s <- getSize v - forM [0..s-1] $ \i -> unsafeRead v i - -{-# SPECIALIZE clone :: Vec e -> IO (Vec e) #-} -{-# SPECIALIZE clone :: UVec Int -> IO (UVec Int) #-} -{-# SPECIALIZE clone :: UVec Double -> IO (UVec Double) #-} -{-# SPECIALIZE clone :: UVec Bool -> IO (UVec Bool) #-} -clone :: A.MArray a e IO => GenericVec a e -> IO (GenericVec a e) -clone (GenericVec ref) = do - (n,a) <- readIORef ref - a' <- cloneArray a - liftM GenericVec $ newIORef (n,a') - -{-------------------------------------------------------------------- - ---------------------------------------------------------------------} - -{-# INLINE getArray #-} --- | Get the internal representation array -getArray :: GenericVec a e -> IO (a Index e) -getArray (GenericVec ref) = liftM snd $ readIORef ref - -{-# INLINE getCapacity #-} --- | Get the internal representation array -getCapacity :: A.MArray a e IO => GenericVec a e -> IO Int -getCapacity vec = liftM rangeSize $ A.getBounds =<< getArray vec - -{-# SPECIALIZE resizeCapacity :: Vec e -> Int -> IO () #-} -{-# SPECIALIZE resizeCapacity :: UVec Int -> Int -> IO () #-} -{-# SPECIALIZE resizeCapacity :: UVec Double -> Int -> IO () #-} -{-# SPECIALIZE resizeCapacity :: UVec Bool -> Int -> IO () #-} --- | Pre-allocate internal buffer for @n@ elements. -resizeCapacity :: A.MArray a e IO => GenericVec a e -> Int -> IO () -resizeCapacity (GenericVec ref) capa = do - (n,arr) <- readIORef ref - capa0 <- liftM rangeSize $ A.getBounds arr - when (capa0 < capa) $ do - arr' <- A.newArray_ (0, capa-1) - copyTo arr arr' (0, n-1) - writeIORef ref (n,arr') - -{-------------------------------------------------------------------- - utility ---------------------------------------------------------------------} - -{-# INLINE cloneArray #-} -cloneArray :: (A.MArray a e m) => a Index e -> m (a Index e) -cloneArray arr = do - b <- A.getBounds arr - arr' <- A.newArray_ b - copyTo arr arr' b - return arr' - -{-# INLINE copyTo #-} -copyTo :: (A.MArray a e m) => a Index e -> a Index e -> (Index,Index) -> m () -copyTo fromArr toArr (!lb,!ub) = do - forLoop lb (<=ub) (+1) $ \i -> do - val_i <- A.unsafeRead fromArr i - A.unsafeWrite toArr i val_i diff --git a/src/ToySolver/FOLModelFinder.hs b/src/ToySolver/FOLModelFinder.hs --- a/src/ToySolver/FOLModelFinder.hs +++ b/src/ToySolver/FOLModelFinder.hs @@ -56,6 +56,7 @@ import qualified Data.Set as Set import Text.Printf +import ToySolver.Data.Boolean import qualified ToySolver.SAT as SAT -- --------------------------------------------------------------------------- @@ -81,6 +82,10 @@ | Neg a deriving (Show, Eq, Ord) +instance Complement (GenLit a) where + notB (Pos a) = Neg a + notB (Neg a) = Pos a + instance Vars a => Vars (GenLit a) where vars (Pos a) = vars a vars (Neg a) = vars a @@ -126,6 +131,19 @@ | Exists Var (GenFormula a) deriving (Show, Eq, Ord) +instance MonotoneBoolean (GenFormula a) where + true = T + false = F + (.&&.) = And + (.||.) = Or + +instance Complement (GenFormula a) where + notB = Not + +instance Boolean (GenFormula a) where + (.=>.) = Imply + (.<=>.) = Equiv + instance Vars a => Vars (GenFormula a) where vars T = Set.empty vars F = Set.empty @@ -141,11 +159,11 @@ toNNF :: Formula -> Formula toNNF = f where - f (And phi psi) = f phi `And` f psi - f (Or phi psi) = f phi `Or` f psi + f (And phi psi) = f phi .&&. f psi + f (Or phi psi) = f phi .||. f psi f (Not phi) = g phi - f (Imply phi psi) = g phi `Or` f psi - f (Equiv phi psi) = f (And (Imply phi psi) (Imply psi phi)) + f (Imply phi psi) = g phi .||. f psi + f (Equiv phi psi) = f ((phi .=>. psi) .&&. (psi .=>. phi)) f (Forall v phi) = Forall v (f phi) f (Exists v phi) = Exists v (f phi) f phi = phi @@ -153,14 +171,14 @@ g :: Formula -> Formula g T = F g F = T - g (And phi psi) = g phi `Or` g psi - g (Or phi psi) = g phi `And` g psi + g (And phi psi) = g phi .||. g psi + g (Or phi psi) = g phi .&&. g psi g (Not phi) = f phi - g (Imply phi psi) = f phi `And` g psi - g (Equiv phi psi) = g (And (Imply phi psi) (Imply psi phi)) + g (Imply phi psi) = f phi .&&. g psi + g (Equiv phi psi) = g ((phi .=>. psi) .&&. (psi .=>. phi)) g (Forall v phi) = Exists v (g phi) g (Exists v phi) = Forall v (g phi) - g (Atom a) = Not (Atom a) + g (Atom a) = notB (Atom a) -- | normalize a formula into a skolem normal form. -- @@ -213,11 +231,10 @@ -- ∀x. animal(a) → (∃y. heart(y) ∧ has(x,y)) let phi = Forall "x" $ - Imply - (Atom (PApp "animal" [TmVar "x"])) + Atom (PApp "animal" [TmVar "x"]) .=>. (Exists "y" $ - And (Atom (PApp "heart" [TmVar "y"])) - (Atom (PApp "has" [TmVar "x", TmVar "y"]))) + Atom (PApp "heart" [TmVar "y"]) .&&. + Atom (PApp "has" [TmVar "x", TmVar "y"])) phi' <- toSkolemNF skolem phi @@ -493,7 +510,7 @@ ret <- SAT.solve solver if ret then do - bmodel <- SAT.model solver + bmodel <- SAT.getModel solver m <- readIORef ref let rels = Map.fromList $ do @@ -534,8 +551,8 @@ test2 = do let phi = Forall "x" $ Exists "y" $ - And (Not (Atom (PApp "=" [TmVar "x", TmVar "y"]))) - (Atom (PApp "=" [TmApp "f" [TmVar "y"], TmVar "x"])) + notB (Atom (PApp "=" [TmVar "x", TmVar "y"])) .&&. + Atom (PApp "=" [TmApp "f" [TmVar "y"], TmVar "x"]) ref <- newIORef 0 let skolem name _ = do diff --git a/src/ToySolver/FourierMotzkin.hs b/src/ToySolver/FourierMotzkin.hs deleted file mode 100644 --- a/src/ToySolver/FourierMotzkin.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.FourierMotzkin --- Copyright : (c) Masahiro Sakai 2011-2013 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- Naïve implementation of Fourier-Motzkin Variable Elimination --- --- Reference: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.FourierMotzkin - ( Lit (..) - , project - , projectN - , eliminateQuantifiers - , solveFormula - , solve - ) where - -import ToySolver.FourierMotzkin.Core -import ToySolver.FourierMotzkin.FOL diff --git a/src/ToySolver/FourierMotzkin/Core.hs b/src/ToySolver/FourierMotzkin/Core.hs deleted file mode 100644 --- a/src/ToySolver/FourierMotzkin/Core.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.FourierMotzkin.Core --- Copyright : (c) Masahiro Sakai 2011-2013 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- Naïve implementation of Fourier-Motzkin Variable Elimination --- --- Reference: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.FourierMotzkin.Core - ( ExprZ - , Rat - , toRat - , fromRat - - , Lit (..) - , leR, ltR, geR, gtR - , simplify - - , fromLAAtom - , toLAAtom - , constraintsToDNF - - , BoundsR - , collectBounds - , boundsToLits - , evalBounds - - , project - , project' - , projectN - , projectN' - , solve - , solve' - ) where - -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ratio -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.VectorSpace hiding (project) -import qualified Data.Interval as Interval -import Data.Interval (Interval, EndPoint (..), (<=..<), (<..<=), (<..<)) - -import ToySolver.Data.ArithRel -import ToySolver.Data.Boolean -import ToySolver.Data.DNF -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var - --- --------------------------------------------------------------------------- - -type ExprZ = LA.Expr Integer - -normalizeExprR :: ExprZ -> ExprZ -normalizeExprR e = LA.mapCoeff (`div` d) e - where d = abs $ gcd' $ map fst $ LA.terms e - --- --------------------------------------------------------------------------- - --- | (t,c) represents t/c, and c must be >0. -type Rat = (ExprZ, Integer) - -toRat :: LA.Expr Rational -> Rat -toRat e = seq m $ (LA.mapCoeff f e, m) - where - f x = numerator (fromInteger m * x) - m = foldl' lcm 1 [denominator c | (c,_) <- LA.terms e] - -fromRat :: Rat -> LA.Expr Rational -fromRat (e,c) = LA.mapCoeff (% c) e - -evalRat :: Model Rational -> Rat -> Rational -evalRat model (e, d) = LA.lift1 1 (model IM.!) (LA.mapCoeff fromIntegral e) / (fromIntegral d) - --- --------------------------------------------------------------------------- - --- | Literal -data Lit = Nonneg ExprZ | Pos ExprZ deriving (Show, Eq, Ord) - -instance Variables Lit where - vars (Pos t) = vars t - vars (Nonneg t) = vars t - -instance Complement Lit where - notB (Pos t) = Nonneg (negateV t) - notB (Nonneg t) = Pos (negateV t) - -leR, ltR, geR, gtR :: Rat -> Rat -> Lit -leR (e1,c) (e2,d) = Nonneg $ normalizeExprR $ c *^ e2 ^-^ d *^ e1 -ltR (e1,c) (e2,d) = Pos $ normalizeExprR $ c *^ e2 ^-^ d *^ e1 -geR = flip leR -gtR = flip gtR - --- 制約集合の単純化 --- It returns Nothing when a inconsistency is detected. -simplify :: [Lit] -> Maybe [Lit] -simplify = fmap concat . mapM f - where - f :: Lit -> Maybe [Lit] - f lit@(Pos e) = - case LA.asConst e of - Just x -> guard (x > 0) >> return [] - Nothing -> return [lit] - f lit@(Nonneg e) = - case LA.asConst e of - Just x -> guard (x >= 0) >> return [] - Nothing -> return [lit] - --- --------------------------------------------------------------------------- - -fromLAAtom :: LA.Atom Rational -> DNF Lit -fromLAAtom (Rel a op b) = atomR' op (toRat a) (toRat b) - -toLAAtom :: Lit -> LA.Atom Rational -toLAAtom (Nonneg e) = LA.mapCoeff fromInteger e .>=. LA.constant 0 -toLAAtom (Pos e) = LA.mapCoeff fromInteger e .>. LA.constant 0 - -constraintsToDNF :: [LA.Atom Rational] -> DNF Lit -constraintsToDNF = andB . map fromLAAtom - -atomR' :: RelOp -> Rat -> Rat -> DNF Lit -atomR' op a b = - case op of - Le -> DNF [[a `leR` b]] - Lt -> DNF [[a `ltR` b]] - Ge -> DNF [[a `geR` b]] - Gt -> DNF [[a `gtR` b]] - Eql -> DNF [[a `leR` b, a `geR` b]] - NEq -> DNF [[a `ltR` b], [a `gtR` b]] - --- --------------------------------------------------------------------------- - -{- -(ls1,ls2,us1,us2) represents -{ x | ∀(M,c)∈ls1. M/c≤x, ∀(M,c)∈ls2. M/c [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)] -project v xs = do - ys <- unDNF $ constraintsToDNF xs - (zs, mt) <- maybeToList $ project' v ys - return (map toLAAtom zs, mt) - -project' :: Var -> [Lit] -> Maybe ([Lit], Model Rational -> Model Rational) -project' v xs = do - case collectBounds v xs of - (bnd, rest) -> do - cond <- boundsToLits bnd - let mt m = - case Interval.pickup (evalBounds m bnd) of - Nothing -> error "ToySolver.FourierMotzkin.project': should not happen" - Just val -> IM.insert v val m - return (rest ++ cond, mt) - -projectN :: VarSet -> [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)] -projectN vs xs = do - ys <- unDNF $ constraintsToDNF xs - (zs, mt) <- maybeToList $ projectN' vs ys - return (map toLAAtom zs, mt) - -projectN' :: VarSet -> [Lit] -> Maybe ([Lit], Model Rational -> Model Rational) -projectN' vs2 xs2 = do - (zs, mt) <- f (IS.toList vs2) xs2 - return (zs, mt) - where - f [] xs = return (xs, id) - f (v:vs) xs = do - (ys, mt1) <- project' v xs - (zs, mt2) <- f vs ys - return (zs, mt1 . mt2) - -collectBounds :: Var -> [Lit] -> (BoundsR, [Lit]) -collectBounds v = foldr phi (([],[],[],[]),[]) - where - phi :: Lit -> (BoundsR, [Lit]) -> (BoundsR, [Lit]) - phi lit@(Nonneg t) x = f False lit t x - phi lit@(Pos t) x = f True lit t x - - f :: Bool -> Lit -> ExprZ -> (BoundsR, [Lit]) -> (BoundsR, [Lit]) - f strict lit t (bnd@(ls1,ls2,us1,us2), xs) = - case LA.extract v t of - (c,t') -> - case c `compare` 0 of - EQ -> (bnd, lit : xs) - GT -> - if strict - then ((ls1, (negateV t', c) : ls2, us1, us2), xs) -- 0 < cx + M ⇔ -M/c < x - else (((negateV t', c) : ls1, ls2, us1, us2), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x - LT -> - if strict - then ((ls1, ls2, us1, (t', negate c) : us2), xs) -- 0 < cx + M ⇔ x < M/-c - else ((ls1, ls2, (t', negate c) : us1, us2), xs) -- 0 ≤ cx + M ⇔ x ≤ M/-c - -boundsToLits :: BoundsR -> Maybe [Lit] -boundsToLits (ls1, ls2, us1, us2) = simplify $ - [ x `leR` y | x <- ls1, y <- us1 ] ++ - [ x `ltR` y | x <- ls1, y <- us2 ] ++ - [ x `ltR` y | x <- ls2, y <- us1 ] ++ - [ x `ltR` y | x <- ls2, y <- us2 ] - -solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Rational) -solve vs cs = msum [solve' vs cs2 | cs2 <- unDNF (constraintsToDNF cs)] - -solve' :: VarSet -> [Lit] -> Maybe (Model Rational) -solve' vs cs = do - (ys,mt) <- projectN' vs =<< simplify cs - guard $ Just [] == simplify ys - return $ mt IM.empty - -evalBounds :: Model Rational -> BoundsR -> Interval Rational -evalBounds model (ls1,ls2,us1,us2) = - Interval.intersections $ - [ Finite (evalRat model x) <=..< PosInf | x <- ls1 ] ++ - [ Finite (evalRat model x) <..< PosInf | x <- ls2 ] ++ - [ NegInf <..<= Finite (evalRat model x) | x <- us1 ] ++ - [ NegInf <..< Finite (evalRat model x) | x <- us2 ] - --- --------------------------------------------------------------------------- - -gcd' :: [Integer] -> Integer -gcd' [] = 1 -gcd' xs = foldl1' gcd xs - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/FourierMotzkin/FOL.hs b/src/ToySolver/FourierMotzkin/FOL.hs deleted file mode 100644 --- a/src/ToySolver/FourierMotzkin/FOL.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module ToySolver.FourierMotzkin.FOL - ( solveFormula - , eliminateQuantifiers - , eliminateQuantifiers' - ) - where - -import Control.Monad -import qualified Data.IntSet as IS -import Data.Maybe - -import ToySolver.Data.ArithRel -import ToySolver.Data.Boolean -import ToySolver.Data.DNF -import qualified ToySolver.Data.FOL.Arith as FOL -import qualified ToySolver.Data.LA.FOL as LAFOL -import ToySolver.Data.Var - -import ToySolver.FourierMotzkin.Core - --- --------------------------------------------------------------------------- - -solveFormula :: [Var] -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Rational -solveFormula vs formula = - case eliminateQuantifiers' formula of - Nothing -> FOL.Unknown - Just dnf -> - case msum [solve' (IS.fromList vs) xs | xs <- unDNF dnf] of - Nothing -> FOL.Unsat - Just m -> FOL.Sat m - -eliminateQuantifiers :: FOL.Formula (FOL.Atom Rational) -> Maybe (FOL.Formula (FOL.Atom Rational)) -eliminateQuantifiers phi = do - dnf <- eliminateQuantifiers' phi - return $ orB $ map (andB . map (LAFOL.toFOLFormula . toLAAtom)) $ unDNF dnf - -eliminateQuantifiers' :: FOL.Formula (FOL.Atom Rational) -> Maybe (DNF Lit) -eliminateQuantifiers' = f - where - f FOL.T = return true - f FOL.F = return false - f (FOL.Atom (Rel a op b)) = do - a' <- LAFOL.fromFOLExpr a - b' <- LAFOL.fromFOLExpr b - return $ fromLAAtom $ Rel a' op b' - f (FOL.And a b) = liftM2 (.&&.) (f a) (f b) - f (FOL.Or a b) = liftM2 (.||.) (f a) (f b) - f (FOL.Not a) = f (FOL.pushNot a) - f (FOL.Imply a b) = f (FOL.Or (FOL.Not a) b) - f (FOL.Equiv a b) = f (FOL.And (FOL.Imply a b) (FOL.Imply b a)) - f (FOL.Forall v a) = do - dnf <- f (FOL.Exists v (FOL.pushNot a)) - return (notB dnf) - f (FOL.Exists v a) = do - dnf <- f a - return $ orB [DNF $ maybeToList $ fmap fst $ project' v xs | xs <- unDNF dnf] - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/HittingSet.hs b/src/ToySolver/HittingSet.hs deleted file mode 100644 --- a/src/ToySolver/HittingSet.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.HittingSet --- Copyright : (c) Masahiro Sakai 2012-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- ------------------------------------------------------------------------------ -module ToySolver.HittingSet - ( minimalHittingSets - ) where - -import Control.Monad -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.List - -type Vertex = Int -type HyperEdge = [Int] -type HittingSet = [Int] - -type HyperEdge' = IntSet - --- FIXME: remove nub -minimalHittingSets :: [HyperEdge] -> [HittingSet] -minimalHittingSets es = nub $ f (map IntSet.fromList es) [] - where - f :: [HyperEdge'] -> HittingSet -> [HittingSet] - f [] hs = return hs - f es hs = do - v <- IntSet.toList $ IntSet.unions es - let hs' = v:hs - e <- es - guard $ v `IntSet.member` e - let es' = propagateChoice es v e - f es' hs' - -propagateChoice :: [HyperEdge'] -> Vertex -> HyperEdge' -> [HyperEdge'] -propagateChoice es v e = zs - where - xs = filter (v `IntSet.notMember`) es - ys = map (IntSet.filter (v <) . (`IntSet.difference` e)) xs - zs = maintainNoSupersets ys - -maintainNoSupersets :: [IntSet] -> [IntSet] -maintainNoSupersets xss = go [] xss - where - go yss [] = yss - go yss (xs:xss) = go (xs : filter p yss) (filter p xss) - where - p zs = not (xs `IntSet.isSubsetOf` zs) diff --git a/src/ToySolver/HittingSet/HTCBDD.hs b/src/ToySolver/HittingSet/HTCBDD.hs deleted file mode 100644 --- a/src/ToySolver/HittingSet/HTCBDD.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.HittingSet.HTCBDD --- Copyright : (c) Masahiro Sakai 2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (DeriveDataTypeable) --- --- Wrapper for htcbdd command. --- --- * HTC-BDD: Hypergraph Transversal Computation with Binary Decision Diagrams --- --- ------------------------------------------------------------------------------ -module ToySolver.HittingSet.HTCBDD - ( Options (..) - , Method (..) - , Failure (..) - , defaultOptions - , minimalHittingSets - ) where - -import Control.Exception (Exception, throwIO) -import Control.Monad -import Data.Array.Unboxed -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.List -import Data.Typeable -import System.Exit -import System.IO -import System.IO.Temp -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -type Vertex = Int -type HyperEdge = [Vertex] -type HittingSet = [Vertex] - -data Options - = Options - { optHTCBDDCommand :: FilePath - , optMethod :: Method - , optOnGetLine :: String -> IO () - , optOnGetErrorLine :: String -> IO () - } - -data Method - = MethodToda - | MethodKnuth - deriving (Eq, Ord, Show) - -defaultOptions :: Options -defaultOptions = - Options - { optHTCBDDCommand = "htcbdd" - , optMethod = MethodToda - , optOnGetLine = \_ -> return () - , optOnGetErrorLine = \_ -> return () - } - -data Failure = Failure !Int - deriving (Show, Typeable) - -instance Exception Failure - -minimalHittingSets :: Options -> [HyperEdge] -> IO [HittingSet] -minimalHittingSets opt es = do - withSystemTempFile "htcbdd-input.dat" $ \fname1 h1 -> do - forM_ es' $ \e -> do - hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] - hClose h1 - withSystemTempFile "htcbdd-out.dat" $ \fname2 h2 -> do - hClose h2 - execHTCBDD opt fname1 fname2 - s <- readFile fname2 - return $ map (map ((decTable !) . read) . words) $ lines s - where - es' :: [IntSet] - es' = map IntSet.fromList es - - vs :: IntSet - vs = IntSet.unions es' - - nv :: Int - nv = IntSet.size vs - - encTable :: IntMap Int - encTable = IntMap.fromList (zip (IntSet.toList vs) [1..nv]) - - decTable :: UArray Int Int - decTable = array (1,nv) (zip [1..nv] (IntSet.toList vs)) - -execHTCBDD :: Options -> FilePath -> FilePath -> IO () -execHTCBDD opt inputFile outputFile = do - let args = ["-k" | optMethod opt == MethodKnuth] ++ [inputFile, outputFile] - exitcode <- runProcessWithOutputCallback (optHTCBDDCommand opt) args "" (optOnGetLine opt) (optOnGetErrorLine opt) - case exitcode of - ExitFailure n -> throwIO $ Failure n - ExitSuccess -> return () diff --git a/src/ToySolver/HittingSet/SHD.hs b/src/ToySolver/HittingSet/SHD.hs deleted file mode 100644 --- a/src/ToySolver/HittingSet/SHD.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.HittingSet.SHD --- Copyright : (c) Masahiro Sakai 2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (DeriveDataTypeable) --- --- Wrapper for shd command. --- --- * Hypergraph Dualization Repository --- --- ------------------------------------------------------------------------------ -module ToySolver.HittingSet.SHD - ( Options (..) - , Failure (..) - , defaultOptions - , minimalHittingSets - ) where - -import Control.Exception (Exception, throwIO) -import Control.Monad -import Data.Array.Unboxed -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.List -import Data.Typeable -import System.Exit -import System.IO -import System.IO.Temp -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -type Vertex = Int -type HyperEdge = [Vertex] -type HittingSet = [Vertex] - -data Options - = Options - { optSHDCommand :: FilePath - , optSHDArgs :: [String] - , optOnGetLine :: String -> IO () - , optOnGetErrorLine :: String -> IO () - } - -defaultOptions :: Options -defaultOptions = - Options - { optSHDCommand = "shd" - , optSHDArgs = ["0"] - , optOnGetLine = \_ -> return () - , optOnGetErrorLine = \_ -> return () - } - -data Failure = Failure !Int - deriving (Show, Typeable) - -instance Exception Failure - -minimalHittingSets :: Options -> [HyperEdge] -> IO [HittingSet] -minimalHittingSets opt es = do - withSystemTempFile "shd-input.dat" $ \fname1 h1 -> do - forM_ es' $ \e -> do - hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] - hClose h1 - withSystemTempFile "shd-out.dat" $ \fname2 h2 -> do - hClose h2 - execSHD opt fname1 fname2 - s <- readFile fname2 - return $ map (map ((decTable !) . read) . words) $ lines s - where - es' :: [IntSet] - es' = map IntSet.fromList es - - vs :: IntSet - vs = IntSet.unions es' - - nv :: Int - nv = IntSet.size vs - - encTable :: IntMap Int - encTable = IntMap.fromList (zip (IntSet.toList vs) [0..nv-1]) - - decTable :: UArray Int Int - decTable = array (0,nv-1) (zip [0..nv-1] (IntSet.toList vs)) - -execSHD :: Options -> FilePath -> FilePath -> IO () -execSHD opt inputFile outputFile = do - let args = optSHDArgs opt ++ [inputFile, outputFile] - exitcode <- runProcessWithOutputCallback (optSHDCommand opt) args "" (optOnGetLine opt) (optOnGetErrorLine opt) - case exitcode of - ExitFailure n -> throwIO $ Failure n - ExitSuccess -> return () diff --git a/src/ToySolver/Internal/Data/IOURef.hs b/src/ToySolver/Internal/Data/IOURef.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Internal/Data/IOURef.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Internal.Data.IOURef +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (FlexibleContexts) +-- +-- Simple unboxed IORef-like type based on IOUArray +-- +----------------------------------------------------------------------------- +module ToySolver.Internal.Data.IOURef + ( IOURef + , newIOURef + , readIOURef + , writeIOURef + , modifyIOURef + ) where + +import Data.Array.Base +import Data.Array.IO + +newtype IOURef a = IOURef (IOUArray Int a) + +{-# INLINEABLE newIOURef #-} +newIOURef :: (MArray IOUArray a IO) => a -> IO (IOURef a) +newIOURef x = do + a <- newArray (0,0) x + return $ IOURef a + +{-# INLINEABLE readIOURef #-} +readIOURef :: (MArray IOUArray a IO) => IOURef a -> IO a +readIOURef (IOURef a) = unsafeRead a 0 + +{-# INLINEABLE writeIOURef #-} +writeIOURef :: (MArray IOUArray a IO) => IOURef a -> a -> IO () +writeIOURef (IOURef a) x = unsafeWrite a 0 x + +{-# INLINEABLE modifyIOURef #-} +modifyIOURef :: (MArray IOUArray a IO) => IOURef a -> (a -> a) -> IO () +modifyIOURef ref f = do + x <- readIOURef ref + writeIOURef ref (f x) diff --git a/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs b/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs --- a/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs +++ b/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs @@ -1,4 +1,10 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeSynonymInstances, CPP #-} +#ifdef __GLASGOW_HASKELL__ +#define UNBOXED_COMPARISON_ARGUMENTS +#endif +#ifdef UNBOXED_COMPARISON_ARGUMENTS +{-# LANGUAGE MagicHash #-} +#endif {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- | @@ -45,7 +51,10 @@ import Control.Monad import qualified Data.Array.IO as A import Data.Queue.Classes -import qualified ToySolver.Data.Vec as Vec +import qualified ToySolver.Internal.Data.Vec as Vec +#ifdef UNBOXED_COMPARISON_ARGUMENTS +import GHC.Exts +#endif type Index = Int type Value = Int @@ -53,7 +62,11 @@ -- | Priority queue implemented as array-based binary heap. data PriorityQueue = PriorityQueue +#ifdef UNBOXED_COMPARISON_ARGUMENTS + { lt# :: !(Int# -> Int# -> IO Bool) +#else { lt :: !(Value -> Value -> IO Bool) +#endif , heap :: !(Vec.UVec Value) , table :: !(Vec.UVec Index) } @@ -62,13 +75,37 @@ newPriorityQueue :: IO PriorityQueue newPriorityQueue = newPriorityQueueBy (\a b -> return (a < b)) +#ifdef UNBOXED_COMPARISON_ARGUMENTS + +{-# INLINE newPriorityQueueBy #-} -- | Build a priority queue with a given /less than/ operator. newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue +newPriorityQueueBy cmp = newPriorityQueueBy# cmp# + where + cmp# a b = cmp (I# a) (I# b) + +-- | Build a priority queue with a given /less than/ operator. +newPriorityQueueBy# :: (Int# -> Int# -> IO Bool) -> IO PriorityQueue +newPriorityQueueBy# cmp# = do + vec <- Vec.new + idx <- Vec.new + return $ PriorityQueue{ lt# = cmp#, heap = vec, table = idx } + +{-# INLINE lt #-} +lt :: PriorityQueue -> Value -> Value -> IO Bool +lt q (I# a) (I# b) = lt# q a b + +#else + +-- | Build a priority queue with a given /less than/ operator. +newPriorityQueueBy :: (Value -> Value -> IO Bool) -> IO PriorityQueue newPriorityQueueBy cmp = do vec <- Vec.new idx <- Vec.new return $ PriorityQueue{ lt = cmp, heap = vec, table = idx } +#endif + -- | Return a list of all the elements of a priority queue. (not sorted) getElems :: PriorityQueue -> IO [Value] getElems q = Vec.getElems (heap q) @@ -84,7 +121,7 @@ clone q = do h2 <- Vec.clone (heap q) t2 <- Vec.clone (table q) - return $ PriorityQueue{ lt = lt q, heap = h2, table = t2 } + return $ q{ heap = h2, table = t2 } instance NewFifo PriorityQueue IO where newFifo = newPriorityQueue @@ -111,10 +148,9 @@ if n == 1 then do Vec.resize (heap q) (n-1) else do - val1 <- Vec.unsafeRead (heap q) (n-1) + val1 <- Vec.unsafePop (heap q) Vec.unsafeWrite (heap q) 0 val1 Vec.unsafeWrite (table q) val1 0 - Vec.resize (heap q) (n-1) down q 0 return (Just val) diff --git a/src/ToySolver/Internal/Data/PriorityQueue.hs b/src/ToySolver/Internal/Data/PriorityQueue.hs --- a/src/ToySolver/Internal/Data/PriorityQueue.hs +++ b/src/ToySolver/Internal/Data/PriorityQueue.hs @@ -41,7 +41,7 @@ import Control.Monad import qualified Data.Array.IO as A import Data.Queue.Classes -import qualified ToySolver.Data.Vec as Vec +import qualified ToySolver.Internal.Data.Vec as Vec type Index = Int @@ -96,9 +96,8 @@ if n == 1 then do Vec.resize (heap q) (n-1) else do - val1 <- Vec.unsafeRead (heap q) (n-1) + val1 <- Vec.unsafePop (heap q) Vec.unsafeWrite (heap q) 0 val1 - Vec.resize (heap q) (n-1) down q 0 return (Just val) diff --git a/src/ToySolver/Internal/Data/Vec.hs b/src/ToySolver/Internal/Data/Vec.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Internal/Data/Vec.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Internal.Data.Vec +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable (BangPatterns, FlexibleContexts, ScopedTypeVariables) +-- +-- Simple 1-dimentional resizable array +-- +----------------------------------------------------------------------------- +module ToySolver.Internal.Data.Vec + ( + -- * Vec type + GenericVec + , Vec + , UVec + , Index + + -- * Constructors + , new + , clone + + -- * Operators + , getSize + , read + , write + , unsafeRead + , unsafeWrite + , resize + , growTo + , push + , unsafePop + , clear + , getElems + + -- * Low-level operators + , getArray + , getCapacity + , resizeCapacity + ) where + +import Prelude hiding (read) + +import Control.Loop +import Control.Monad +import Data.Ix +import qualified Data.Array.Base as A +import qualified Data.Array.IO as A +import Data.IORef + +newtype GenericVec a e = GenericVec (IORef (Int, a Index e)) + deriving Eq + +type Vec e = GenericVec A.IOArray e +type UVec e = GenericVec A.IOUArray e + +type Index = Int + +new :: A.MArray a e IO => IO (GenericVec a e) +new = do + a <- A.newArray_ (0,-1) + ref <- newIORef (0,a) + return $ GenericVec ref + +{- INLINE getSize #-} +-- | Get the internal representation array +getSize :: A.MArray a e IO => GenericVec a e -> IO Int +getSize (GenericVec ref) = liftM fst $ readIORef ref + +{-# SPECIALIZE read :: Vec e -> Int -> IO e #-} +{-# SPECIALIZE read :: UVec Int -> Int -> IO Int #-} +{-# SPECIALIZE read :: UVec Double -> Int -> IO Double #-} +{-# SPECIALIZE read :: UVec Bool -> Int -> IO Bool #-} +read :: A.MArray a e IO => GenericVec a e -> Int -> IO e +read !v !i = do + a <- getArray v + s <- getSize v + if 0 <= i && i < s then + A.unsafeRead a i + else + error $ "ToySolver.Data.Vec.read: index " ++ show i ++ " out of bounds" + +{-# SPECIALIZE write :: Vec e -> Int -> e -> IO () #-} +{-# SPECIALIZE write :: UVec Int -> Int -> Int -> IO () #-} +{-# SPECIALIZE write :: UVec Double -> Int -> Double -> IO () #-} +{-# SPECIALIZE write :: UVec Bool -> Int -> Bool -> IO () #-} +write :: A.MArray a e IO => GenericVec a e -> Int -> e -> IO () +write !v !i e = do + a <- getArray v + s <- getSize v + if 0 <= i && i < s then + A.unsafeWrite a i e + else + error $ "ToySolver.Data.Vec.write: index " ++ show i ++ " out of bounds" + +{-# INLINE unsafeRead #-} +unsafeRead :: A.MArray a e IO => GenericVec a e -> Int -> IO e +unsafeRead !v !i = do + a <- getArray v + A.unsafeRead a i + +{-# INLINE unsafeWrite #-} +unsafeWrite :: A.MArray a e IO => GenericVec a e -> Int -> e -> IO () +unsafeWrite !v !i e = do + a <- getArray v + A.unsafeWrite a i e + +{-# SPECIALIZE resize :: Vec e -> Int -> IO () #-} +{-# SPECIALIZE resize :: UVec Int -> Int -> IO () #-} +{-# SPECIALIZE resize :: UVec Double -> Int -> IO () #-} +{-# SPECIALIZE resize :: UVec Bool -> Int -> IO () #-} +resize :: A.MArray a e IO => GenericVec a e -> Int -> IO () +resize v@(GenericVec ref) !n = do + a <- getArray v + capa <- getCapacity v + if n <= capa then do + writeIORef ref (n,a) + else do + let capa' = max 2 (capa * 3 `div` 2) + a' <- A.newArray_ (0, capa'-1) + copyTo a a' (0,capa-1) + writeIORef ref (n,a') + +{-# SPECIALIZE growTo :: Vec e -> Int -> IO () #-} +{-# SPECIALIZE growTo :: UVec Int -> Int -> IO () #-} +{-# SPECIALIZE growTo :: UVec Double -> Int -> IO () #-} +{-# SPECIALIZE growTo :: UVec Bool -> Int -> IO () #-} +growTo :: A.MArray a e IO => GenericVec a e -> Int -> IO () +growTo v !n = do + m <- getSize v + when (m < n) $ resize v n + +{-# SPECIALIZE push :: Vec e -> e -> IO () #-} +{-# SPECIALIZE push :: UVec Int -> Int -> IO () #-} +{-# SPECIALIZE push :: UVec Double -> Double -> IO () #-} +{-# SPECIALIZE push :: UVec Bool -> Bool -> IO () #-} +push :: A.MArray a e IO => GenericVec a e -> e -> IO () +push v e = do + s <- getSize v + resize v (s+1) + unsafeWrite v s e + +{-# SPECIALIZE unsafePop :: Vec e -> IO e #-} +{-# SPECIALIZE unsafePop :: UVec Int -> IO Int #-} +{-# SPECIALIZE unsafePop :: UVec Double -> IO Double #-} +{-# SPECIALIZE unsafePop :: UVec Bool -> IO Bool #-} +unsafePop :: A.MArray a e IO => GenericVec a e -> IO e +unsafePop v = do + s <- getSize v + e <- unsafeRead v (s-1) + resize v (s-1) + return e + +clear :: A.MArray a e IO => GenericVec a e -> IO () +clear v = resize v 0 + +getElems :: A.MArray a e IO => GenericVec a e -> IO [e] +getElems v = do + s <- getSize v + forM [0..s-1] $ \i -> unsafeRead v i + +{-# SPECIALIZE clone :: Vec e -> IO (Vec e) #-} +{-# SPECIALIZE clone :: UVec Int -> IO (UVec Int) #-} +{-# SPECIALIZE clone :: UVec Double -> IO (UVec Double) #-} +{-# SPECIALIZE clone :: UVec Bool -> IO (UVec Bool) #-} +clone :: A.MArray a e IO => GenericVec a e -> IO (GenericVec a e) +clone (GenericVec ref) = do + (n,a) <- readIORef ref + a' <- cloneArray a + liftM GenericVec $ newIORef (n,a') + +{-------------------------------------------------------------------- + +--------------------------------------------------------------------} + +{-# INLINE getArray #-} +-- | Get the internal representation array +getArray :: GenericVec a e -> IO (a Index e) +getArray (GenericVec ref) = liftM snd $ readIORef ref + +{-# INLINE getCapacity #-} +-- | Get the internal representation array +getCapacity :: A.MArray a e IO => GenericVec a e -> IO Int +getCapacity vec = liftM rangeSize $ A.getBounds =<< getArray vec + +{-# SPECIALIZE resizeCapacity :: Vec e -> Int -> IO () #-} +{-# SPECIALIZE resizeCapacity :: UVec Int -> Int -> IO () #-} +{-# SPECIALIZE resizeCapacity :: UVec Double -> Int -> IO () #-} +{-# SPECIALIZE resizeCapacity :: UVec Bool -> Int -> IO () #-} +-- | Pre-allocate internal buffer for @n@ elements. +resizeCapacity :: A.MArray a e IO => GenericVec a e -> Int -> IO () +resizeCapacity (GenericVec ref) capa = do + (n,arr) <- readIORef ref + capa0 <- liftM rangeSize $ A.getBounds arr + when (capa0 < capa) $ do + arr' <- A.newArray_ (0, capa-1) + copyTo arr arr' (0, n-1) + writeIORef ref (n,arr') + +{-------------------------------------------------------------------- + utility +--------------------------------------------------------------------} + +{-# INLINE cloneArray #-} +cloneArray :: (A.MArray a e m) => a Index e -> m (a Index e) +cloneArray arr = do + b <- A.getBounds arr + arr' <- A.newArray_ b + copyTo arr arr' b + return arr' + +{-# INLINE copyTo #-} +copyTo :: (A.MArray a e m) => a Index e -> a Index e -> (Index,Index) -> m () +copyTo fromArr toArr (!lb,!ub) = do + forLoop lb (<=ub) (+1) $ \i -> do + val_i <- A.unsafeRead fromArr i + A.unsafeWrite toArr i val_i diff --git a/src/ToySolver/Knapsack.hs b/src/ToySolver/Knapsack.hs deleted file mode 100644 --- a/src/ToySolver/Knapsack.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Knapsack --- Copyright : (c) Masahiro Sakai 2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- Simple 0-1 knapsack problem solver that uses branch-and-bound with LP-relaxation based upper bound. --- ------------------------------------------------------------------------------ -module ToySolver.Knapsack - ( Weight - , Value - , solve - ) where - -import Control.Monad.State -import Data.Function (on) -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet -import Data.List - -type Weight = Rational -type Value = Rational - -solve - :: [(Value, Weight)] - -> Weight - -> (Value, Weight, [Bool]) -solve items limit = - ( sum [v | (n,(v,_)) <- zip [0..] items, n `IntSet.member` sol] - , sum [w | (n,(_,w)) <- zip [0..] items, n `IntSet.member` sol] - , [n `IntSet.member` sol | (n,_) <- zip [0..] items] - ) - where - items' :: [(Value, Weight, Int)] - items' = map fst $ sortBy (flip compare `on` snd) [((v, w, n), (v / w, v)) | (n, (v, w)) <- zip [0..] items] - - sol :: IntSet - sol = IntSet.fromList $ fst $ execState (f items' limit ([],0)) ([],0) - - f :: [(Value, Weight, Int)] -> Weight -> ([Int],Value) -> State ([Int],Value) () - f items !slack (is, !value) = do - (_, bestVal) <- get - when (computeUB items slack value > bestVal) $ do - case items of - [] -> put (is,value) - (v,w,i):items -> do - when (slack >= w) $ f items (slack - w) (i : is, v + value) - f items slack (is, value) - - computeUB :: [(Value, Weight, Int)] -> Weight -> Value -> Value - computeUB items slack value = go items slack value - where - go _ 0 val = val - go [] _ val = val - go ((v,w,_):items) slack val - | slack >= w = go items (slack - w) (val + v) - | otherwise = val + (v / w) * slack diff --git a/src/ToySolver/LPSolver.hs b/src/ToySolver/LPSolver.hs deleted file mode 100644 --- a/src/ToySolver/LPSolver.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.LPSolver --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) --- --- Naïve implementation of Simplex method --- --- Reference: --- --- * --- ------------------------------------------------------------------------------ - -module ToySolver.LPSolver - ( - -- * Solver type - Solver - , emptySolver - - -- * LP monad - , LP - , getTableau - , putTableau - - -- * Problem specification - , newVar - , addConstraint - , addConstraintWithArtificialVariable - , tableau - , define - - -- * Solving - , phaseI - , simplex - , dualSimplex - , OptResult (..) - , twoPhaseSimplex - , primalDualSimplex - - -- * Extract results - , getModel - - -- * Utilities - , collectNonnegVars - ) where - -import Control.Exception (assert) -import Control.Monad -import Control.Monad.State -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.OptDir -import Data.VectorSpace - -import qualified Data.Interval as Interval - -import ToySolver.Data.ArithRel -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import qualified ToySolver.Simplex as Simplex -import qualified ToySolver.BoundsInference as BI - --- --------------------------------------------------------------------------- --- Solver type - -type Solver r = (Var, Simplex.Tableau r, VarSet, VarMap (LA.Expr r)) - -emptySolver :: VarSet -> Solver r -emptySolver vs = (1 + maximum ((-1) : IS.toList vs), Simplex.emptyTableau, IS.empty, IM.empty) - --- --------------------------------------------------------------------------- --- LP Monad - -type LP r = State (Solver r) - --- | Allocate a new /non-negative/ variable. -newVar :: LP r Var -newVar = do - (x,tbl,avs,defs) <- get - put (x+1,tbl,avs,defs) - return x - -getTableau :: LP r (Simplex.Tableau r) -getTableau = do - (_,tbl,_,_) <- get - return tbl - -putTableau :: Simplex.Tableau r -> LP r () -putTableau tbl = do - (x,_,avs,defs) <- get - put (x,tbl,avs,defs) - -addArtificialVariable :: Var -> LP r () -addArtificialVariable v = do - (x,tbl,avs,defs) <- get - put (x, tbl, IS.insert v avs, defs) - -getArtificialVariables :: LP r VarSet -getArtificialVariables = do - (_,_,avs,_) <- get - return avs - -clearArtificialVariables :: LP r () -clearArtificialVariables = do - (x,tbl,_,defs) <- get - put (x, tbl, IS.empty, defs) - -define :: Var -> LA.Expr r -> LP r () -define v e = do - (x,tbl,avs,defs) <- get - put (x,tbl,avs, IM.insert v e defs) - -getDefs :: LP r (VarMap (LA.Expr r)) -getDefs = do - (_,_,_,defs) <- get - return defs - --- --------------------------------------------------------------------------- - --- | Add a contraint and maintain feasibility condition by introducing artificial variable (if necessary). --- --- * Disequality is not supported. --- --- * Unlike 'addConstraint', an equality contstraint becomes one row with an artificial variable. --- -addConstraintWithArtificialVariable :: Real r => LA.Atom r -> LP r () -addConstraintWithArtificialVariable c = do - c2 <- expandDefs' c - let (e, rop, b) = normalizeConstraint c2 - assert (b >= 0) $ return () - tbl <- getTableau - case rop of - -- x≥0 is trivially true, since x is non-negative. - Ge | b==0 && isSingleVar e -> return () - -- -x≤0 is trivially true, since x is non-negative. - Le | b==0 && isSingleNegatedVar e -> return () - - Le -> do - v <- newVar -- slack variable - putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) - Ge -> do - v1 <- newVar -- surplus variable - v2 <- newVar -- artificial variable - putTableau $ Simplex.addRow tbl v2 (LA.coeffMap (e ^-^ LA.var v1), b) - addArtificialVariable v2 - Eql -> do - v <- newVar -- artificial variable - putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) - addArtificialVariable v - _ -> error $ "ToySolver.LPSolver.addConstraintWithArtificialVariable does not support " ++ show rop - --- | Add a contraint, without maintaining feasibilty condition of tableaus. --- --- * Disequality is not supported. --- --- * Unlike 'addConstraintWithArtificialVariable', an equality constraint becomes two rows. --- -addConstraint :: Real r => LA.Atom r -> LP r () -addConstraint c = do - Rel lhs rop rhs <- expandDefs' c - let - (b', e) = LA.extract LA.unitVar (lhs ^-^ rhs) - b = - b' - case rop of - Le -> f e b - Ge -> f (negateV e) (negate b) - Eql -> do - -- Unlike addConstraintWithArtificialVariable, an equality constraint becomes two rows. - f e b - f (negateV e) (negate b) - _ -> error $ "ToySolver.LPSolver.addConstraint does not support " ++ show rop - where - -- -x≤b with b≥0 is trivially true. - f e b | isSingleNegatedVar e && 0 <= b = return () - f e b = do - tbl <- getTableau - v <- newVar -- slack variable - putTableau $ Simplex.addRow tbl v (LA.coeffMap e, b) - -isSingleVar :: Real r => LA.Expr r -> Bool -isSingleVar e = - case LA.terms e of - [(1,_)] -> True - _ -> False - -isSingleNegatedVar :: Real r => LA.Expr r -> Bool -isSingleNegatedVar e = - case LA.terms e of - [(-1,_)] -> True - _ -> False - -expandDefs :: (Num r, Eq r) => LA.Expr r -> LP r (LA.Expr r) -expandDefs e = do - defs <- getDefs - return $ LA.applySubst defs e - -expandDefs' :: (Num r, Eq r) => LA.Atom r -> LP r (LA.Atom r) -expandDefs' (Rel lhs op rhs) = do - lhs' <- expandDefs lhs - rhs' <- expandDefs rhs - return $ Rel lhs' op rhs' - -tableau :: (RealFrac r) => [LA.Atom r] -> LP r () -tableau cs = do - let (nonnegVars, cs') = collectNonnegVars cs IS.empty - fvs = vars cs `IS.difference` nonnegVars - forM_ (IS.toList fvs) $ \v -> do - v1 <- newVar - v2 <- newVar - define v (LA.var v1 ^-^ LA.var v2) - mapM_ addConstraint cs' - -getModel :: Fractional r => VarSet -> LP r (Model r) -getModel vs = do - tbl <- getTableau - defs <- getDefs - let vs' = (vs `IS.difference` IM.keysSet defs) `IS.union` IS.unions [vars e | e <- IM.elems defs] - m0 = IM.fromAscList [(v, Simplex.currentValue tbl v) | v <- IS.toAscList vs'] - return $ IM.filterWithKey (\k _ -> k `IS.member` vs) $ IM.map (LA.evalExpr m0) defs `IM.union` m0 - -phaseI :: (Fractional r, Real r) => LP r Bool -phaseI = do - introduceArtificialVariables - tbl <- getTableau - avs <- getArtificialVariables - let (ret, tbl') = Simplex.phaseI tbl avs - putTableau tbl' - when ret clearArtificialVariables - return ret - -introduceArtificialVariables :: (Real r) => LP r () -introduceArtificialVariables = do - tbl <- getTableau - tbl' <- liftM IM.fromList $ forM (IM.toList tbl) $ \(v,(e,rhs)) -> do - if rhs >= 0 then do - return (v,(e,rhs)) -- v + e == rhs - else do - a <- newVar - addArtificialVariable a - return (a, (IM.insert v (-1) (IM.map negate e), -rhs)) -- a - (v + e) == -rhs - putTableau tbl' - -simplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r Bool -simplex optdir obj = do - tbl <- getTableau - defs <- getDefs - let (ret, tbl') = Simplex.simplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) - putTableau tbl' - return ret - -dualSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r Bool -dualSimplex optdir obj = do - tbl <- getTableau - defs <- getDefs - let (ret, tbl') = Simplex.dualSimplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) - putTableau tbl' - return ret - --- | results of optimization -data OptResult = Optimum | Unsat | Unbounded - deriving (Show, Eq, Ord) - -twoPhaseSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r OptResult -twoPhaseSimplex optdir obj = do - ret <- phaseI - if not ret then - return Unsat - else do - ret <- simplex optdir obj - if ret then - return Optimum - else - return Unbounded - -primalDualSimplex :: (Fractional r, Real r) => OptDir -> LA.Expr r -> LP r OptResult -primalDualSimplex optdir obj = do - tbl <- getTableau - defs <- getDefs - let (ret, tbl') = Simplex.primalDualSimplex optdir (Simplex.setObjFun tbl (LA.applySubst defs obj)) - putTableau tbl' - if ret then - return Optimum - else if not (Simplex.isFeasible tbl') then - return Unsat - else - return Unbounded - --- --------------------------------------------------------------------------- - --- convert right hand side to be non-negative -normalizeConstraint :: forall r. Real r => LA.Atom r -> (LA.Expr r, RelOp, r) -normalizeConstraint (Rel a op b) - | rhs < 0 = (negateV lhs, flipOp op, negate rhs) - | otherwise = (lhs, op, rhs) - where - (c, lhs) = LA.extract LA.unitVar (a ^-^ b) - rhs = - c - -collectNonnegVars :: forall r. (RealFrac r) => [LA.Atom r] -> VarSet -> (VarSet, [LA.Atom r]) -collectNonnegVars cs ivs = (nonnegVars, cs) - where - vs = vars cs - bounds = BI.inferBounds initialBounds cs ivs 1000 - where - initialBounds = IM.fromList [(v, Interval.whole) | v <- IS.toList vs] - nonnegVars = IS.filter f vs - where - f v = case Interval.lowerBound (bounds IM.! v) of - Interval.Finite lb | 0 <= lb -> True - _ -> False - - isTriviallyTrue :: LA.Atom r -> Bool - isTriviallyTrue (Rel a op b) = - case op of - Le -> - case ub of - Interval.PosInf -> False - Interval.Finite val -> val <= 0 - Interval.NegInf -> True -- should not happen - Ge -> - case lb of - Interval.NegInf -> False - Interval.Finite val -> val >= 0 - Interval.PosInf -> True -- should not happen - Lt -> - case ub of - Interval.PosInf -> False - Interval.Finite val -> val < 0 || (not inUB && val <= 0) - Interval.NegInf -> True -- should not happen - Gt -> - case lb of - Interval.NegInf -> False - Interval.Finite val -> val > 0 || (not inLB && val >= 0) - Interval.PosInf -> True -- should not happen - Eql -> isTriviallyTrue (c .<=. zeroV) && isTriviallyTrue (c .>=. zeroV) - NEq -> isTriviallyTrue (c .<. zeroV) || isTriviallyTrue (c .>. zeroV) - where - c = a ^-^ b - i = LA.computeInterval bounds c - (lb, inLB) = Interval.lowerBound' i - (ub, inUB) = Interval.upperBound' i - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/LPSolverHL.hs b/src/ToySolver/LPSolverHL.hs deleted file mode 100644 --- a/src/ToySolver/LPSolverHL.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.LPSolverHL --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) --- --- High-Level API for LPSolver.hs --- ------------------------------------------------------------------------------ - -module ToySolver.LPSolverHL - ( OptResult (..) - , minimize - , maximize - , optimize - , solve - ) where - -import Control.Monad.State -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.OptDir -import Data.VectorSpace - -import ToySolver.Data.ArithRel -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import qualified ToySolver.Simplex as Simplex -import qualified ToySolver.LPSolver as LPSolver -import ToySolver.LPSolver hiding (OptResult (..)) - --- --------------------------------------------------------------------------- - --- | results of optimization -data OptResult r = OptUnsat | Unbounded | Optimum r (Model r) - deriving (Show, Eq, Ord) - -maximize :: (RealFrac r) => LA.Expr r -> [LA.Atom r] -> OptResult r -maximize = optimize OptMax - -minimize :: (RealFrac r) => LA.Expr r -> [LA.Atom r] -> OptResult r -minimize = optimize OptMin - -solve :: (RealFrac r) => [LA.Atom r] -> Maybe (Model r) -solve cs = - flip evalState (emptySolver vs) $ do - tableau cs - ret <- phaseI - if not ret - then return Nothing - else do - m <- getModel vs - return (Just m) - where - vs = vars cs - -optimize :: (RealFrac r) => OptDir -> LA.Expr r -> [LA.Atom r] -> OptResult r -optimize optdir obj cs = - flip evalState (emptySolver vs) $ do - tableau cs - ret <- LPSolver.twoPhaseSimplex optdir obj - case ret of - LPSolver.Unsat -> return OptUnsat - LPSolver.Unbounded -> return Unbounded - LPSolver.Optimum -> do - m <- getModel vs - tbl <- getTableau - return $ Optimum (Simplex.currentObjValue tbl) m - where - vs = vars cs `IS.union` vars obj - --- --------------------------------------------------------------------------- --- Test cases - -example_3_2 :: (LA.Expr Rational, [LA.Atom Rational]) -example_3_2 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - obj = 3*^x1 ^+^ 2*^x2 ^+^ 3*^x3 - cond = [ 2*^x1 ^+^ x2 ^+^ x3 .<=. LA.constant 2 - , x1 ^+^ 2*^x2 ^+^ 3*^x3 .<=. LA.constant 5 - , 2*^x1 ^+^ 2*^x2 ^+^ x3 .<=. LA.constant 6 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - , x3 .>=. LA.constant 0 - ] - -test_3_2 :: Bool -test_3_2 = - uncurry maximize example_3_2 == - Optimum (27/5) (IM.fromList [(1,1/5),(2,0),(3,8/5)]) - -example_3_5 :: (LA.Expr Rational, [LA.Atom Rational]) -example_3_5 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - x4 = LA.var 4 - x5 = LA.var 5 - obj = (-2)*^x1 ^+^ 4*^x2 ^+^ 7*^x3 ^+^ x4 ^+^ 5*^x5 - cond = [ (-1)*^x1 ^+^ x2 ^+^ 2*^x3 ^+^ x4 ^+^ 2*^x5 .==. LA.constant 7 - , (-1)*^x1 ^+^ 2*^x2 ^+^ 3*^x3 ^+^ x4 ^+^ x5 .==. LA.constant 6 - , (-1)*^x1 ^+^ x2 ^+^ x3 ^+^ 2*^x4 ^+^ x5 .==. LA.constant 4 - , x2 .>=. LA.constant 0 - , x3 .>=. LA.constant 0 - , x4 .>=. LA.constant 0 - , x5 .>=. LA.constant 0 - ] - -test_3_5 :: Bool -test_3_5 = - uncurry minimize example_3_5 == - Optimum 19 (IM.fromList [(1,-1),(2,0),(3,1),(4,0),(5,2)]) - -example_4_1 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_1 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - obj = 2*^x1 ^+^ x2 - cond = [ (-1)*^x1 ^+^ x2 .>=. LA.constant 2 - , x1 ^+^ x2 .<=. LA.constant 1 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - ] - -test_4_1 :: Bool -test_4_1 = - uncurry maximize example_4_1 == - OptUnsat - -example_4_2 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_2 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - obj = 2*^x1 ^+^ x2 - cond = [ (-1)*^x1 ^-^ x2 .<=. LA.constant 10 - , 2*^x1 ^-^ x2 .<=. LA.constant 40 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - ] - -test_4_2 :: Bool -test_4_2 = - uncurry maximize example_4_2 == - Unbounded - -example_4_3 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_3 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - obj = 6*^x1 ^-^ 2*^x2 - cond = [ 2*^x1 ^-^ x2 .<=. LA.constant 2 - , x1 .<=. LA.constant 4 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - ] - -test_4_3 :: Bool -test_4_3 = - uncurry maximize example_4_3 == - Optimum 12 (IM.fromList [(1,4),(2,6)]) - -example_4_5 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_5 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - obj = 2*^x1 ^+^ x2 - cond = [ 4*^x1 ^+^ 3*^x2 .<=. LA.constant 12 - , 4*^x1 ^+^ x2 .<=. LA.constant 8 - , 4*^x1 ^-^ x2 .<=. LA.constant 8 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - ] - -test_4_5 :: Bool -test_4_5 = - uncurry maximize example_4_5 == - Optimum 5 (IM.fromList [(1,3/2),(2,2)]) - -example_4_6 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_6 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - x4 = LA.var 4 - obj = 20*^x1 ^+^ (1/2)*^x2 ^-^ 6*^x3 ^+^ (3/4)*^x4 - cond = [ x1 .<=. LA.constant 2 - , 8*^x1 ^-^ x2 ^+^ 9*^x3 ^+^ (1/4)*^x4 .<=. LA.constant 16 - , 12*^x1 ^-^ (1/2)*^x2 ^+^ 3*^x3 ^+^ (1/2)*^x4 .<=. LA.constant 24 - , x2 .<=. LA.constant 1 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - , x3 .>=. LA.constant 0 - , x4 .>=. LA.constant 0 - ] - -test_4_6 :: Bool -test_4_6 = - uncurry maximize example_4_6 == - Optimum (165/4) (IM.fromList [(1,2),(2,1),(3,0),(4,1)]) - -example_4_7 :: (LA.Expr Rational, [LA.Atom Rational]) -example_4_7 = (obj, cond) - where - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - x4 = LA.var 4 - obj = x1 ^+^ 1.5*^x2 ^+^ 5*^x3 ^+^ 2*^x4 - cond = [ 3*^x1 ^+^ 2*^x2 ^+^ x3 ^+^ 4*^x4 .<=. LA.constant 6 - , 2*^x1 ^+^ x2 ^+^ 5*^x3 ^+^ x4 .<=. LA.constant 4 - , 2*^x1 ^+^ 6*^x2 ^-^ 4*^x3 ^+^ 8*^x4 .==. LA.constant 0 - , x1 ^+^ 3*^x2 ^-^ 2*^x3 ^+^ 4*^x4 .==. LA.constant 0 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - , x3 .>=. LA.constant 0 - , x4 .>=. LA.constant 0 - ] - -test_4_7 :: Bool -test_4_7 = - uncurry maximize example_4_7 == - Optimum (48/11) (IM.fromList [(1,0),(2,0),(3,81),(4,41)]) - --- 退化して巡回の起こるKuhnの7変数3制約の例 -kuhn_7_3 :: (LA.Expr Rational, [LA.Atom Rational]) -kuhn_7_3 = (obj, cond) - where - [x1,x2,x3,x4,x5,x6,x7] = map LA.var [1..7] - obj = (-2)*^x4 ^+^ (-3)*^x5 ^+^ x6 ^+^ 12*^x7 - cond = [ x1 ^-^ 2*^x4 ^-^ 9*^x5 ^+^ x6 ^+^ 9*^x7 .==. LA.constant 0 - , x2 ^+^ (1/3)*^x4 ^+^ x5 ^-^ (1/3)*^x6 ^-^ 2*^x7 .==. LA.constant 0 - , x3 ^+^ 2*^x4 ^+^ 3*^x5 ^-^ x6 ^-^ 12*^x7 .==. LA.constant 2 - , x1 .>=. LA.constant 0 - , x2 .>=. LA.constant 0 - , x3 .>=. LA.constant 0 - , x4 .>=. LA.constant 0 - , x5 .>=. LA.constant 0 - , x6 .>=. LA.constant 0 - , x7 .>=. LA.constant 0 - ] - -test_kuhn_7_3 :: Bool -test_kuhn_7_3 = - uncurry minimize kuhn_7_3 == - Optimum (-2) (IM.fromList [(1,2),(2,0),(3,0),(4,2),(5,0),(6,2),(7,0)]) - -testAll :: Bool -testAll = and - [ test_3_2 - , test_3_5 - , test_4_1 - , test_4_2 - , test_4_3 - , test_4_5 - , test_4_6 - , test_4_7 - , test_kuhn_7_3 - ] - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/LPUtil.hs b/src/ToySolver/LPUtil.hs deleted file mode 100644 --- a/src/ToySolver/LPUtil.hs +++ /dev/null @@ -1,92 +0,0 @@ -module ToySolver.LPUtil - ( toStandardForm - , toStandardForm' - ) where - -import Control.Exception -import Control.Monad -import Control.Monad.State -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.Maybe -import Data.VectorSpace - -import qualified Data.Interval as Interval - -import ToySolver.Data.ArithRel -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import qualified ToySolver.BoundsInference as BI - -toStandardForm - :: (LA.Expr Rational, [Rel (LA.Expr Rational)]) - -> ( (LA.Expr Rational, [(LA.Expr Rational, Rational)]) - , Model Rational -> Model Rational - ) -toStandardForm prob1@(obj, cs) = (prob2, mt) - where - vs = vars obj `IS.union` vars cs - (prob2,s) = toStandardForm' prob1 - mt m = IM.fromAscList $ do - v <- IS.toAscList vs - case IM.lookup v s of - Just def -> return (v, LA.evalExpr m def) - Nothing -> return (v, m IM.! v) - -type M = State Var - -toStandardForm' - :: (LA.Expr Rational, [Rel (LA.Expr Rational)]) - -> ( (LA.Expr Rational, [(LA.Expr Rational, Rational)]) - , VarMap (LA.Expr Rational) - ) -toStandardForm' (obj, cs) = m - where - vs = vars obj `IS.union` vars cs - v1 = if IS.null vs then 0 else IS.findMax vs + 1 - initialBounds = IM.fromList [(v, Interval.whole) | v <- IS.toList vs] - bounds = BI.inferBounds initialBounds cs IS.empty 10 - - gensym :: M Var - gensym = do - v <- get - put $ v+1 - return v - - m = flip evalState v1 $ do - s <- liftM IM.unions $ forM (IM.toList bounds) $ \(v,i) -> do - case Interval.lowerBound i of - Interval.NegInf -> do - v1 <- gensym - v2 <- gensym - return $ IM.singleton v (LA.var v1 ^-^ LA.var v2) - Interval.Finite lb - | lb >= 0 -> return IM.empty - | otherwise -> do - v1 <- gensym - return $ IM.singleton v (LA.var v1 ^-^ LA.constant lb) - let obj2 = LA.applySubst s obj - - cs2 <- liftM concat $ forM cs $ \(Rel lhs op rhs) -> do - case LA.extract LA.unitVar (LA.applySubst s (lhs ^-^ rhs)) of - (c,e) -> do - let (lhs2,op2,rhs2) = - if -c >= 0 - then (e,op,-c) - else (negateV e, flipOp op, c) - case op2 of - Eql -> return [(lhs2,rhs2)] - Le -> do - v <- gensym - return [(lhs2 ^+^ LA.var v, rhs2)] - Ge -> do - case LA.terms lhs2 of - [(1,_)] | rhs2<=0 -> return [] - _ -> do - v <- gensym - return [(lhs2 ^-^ LA.var v, rhs2)] - _ -> error $ "ToySolver.LPUtil.toStandardForm: " ++ show op2 ++ " is not supported" - - assert (and [isNothing $ LA.lookupCoeff LA.unitVar c | (c,_) <- cs2]) $ return () - - return ((obj2,cs2),s) diff --git a/src/ToySolver/MIPSolver2.hs b/src/ToySolver/MIPSolver2.hs deleted file mode 100644 --- a/src/ToySolver/MIPSolver2.hs +++ /dev/null @@ -1,501 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.MIPSolver2 --- Copyright : (c) Masahiro Sakai 2012 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, Rank2Types) --- --- Naïve implementation of MIP solver based on Simplex2 module --- --- Reference: --- --- * --- --- * Ralph E. Gomory. --- \"An Algorithm for the Mixed Integer Problem\", Technical Report --- RM-2597, 1960, The Rand Corporation, Santa Monica, CA. --- --- --- * Ralph E. Gomory. --- \"Outline of an algorithm for integer solutions to linear programs\". --- Bull. Amer. Math. Soc., Vol. 64, No. 5. (1958), pp. 275-278. --- --- --- * R. C. Daniel and Martyn Jeffreys. --- \"Unboundedness in Integer and Discrete Programming L.P. Relaxations\" --- The Journal of the Operational Research Society, Vol. 30, No. 12. (1979) --- --- ------------------------------------------------------------------------------ -module ToySolver.MIPSolver2 - ( - -- * The @Solver@ type - Solver - , newSolver - - -- * Solving - , optimize - - -- * Extract results - , getBestSolution - , getBestValue - , getBestModel - - -- * Configulation - , setNThread - , setLogger - , setOnUpdateBestSolution - , setShowRational - ) where - -import Prelude hiding (log) - -import Control.Monad -import Control.Exception -import Control.Concurrent -import Control.Concurrent.STM -import Data.List -import Data.OptDir -import Data.Ord -import Data.IORef -import Data.Maybe -import qualified Data.IntSet as IS -import qualified Data.IntMap as IM -import qualified Data.Map as Map -import qualified Data.Sequence as Seq -import qualified Data.Foldable as F -import Data.VectorSpace -import Data.Time -import System.CPUTime -import System.Timeout -import Text.Printf - -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.ArithRel ((.<=.), (.>=.)) -import qualified ToySolver.Simplex2 as Simplex2 -import ToySolver.Simplex2 (OptResult (..), Var, Model) -import ToySolver.Internal.Util (isInteger, fracPart) - -data Solver - = MIP - { mipRootLP :: Simplex2.Solver - , mipIVs :: IS.IntSet - , mipBest :: TVar (Maybe Node) - - , mipNThread :: IORef Int - , mipLogger :: IORef (Maybe (String -> IO ())) - , mipOnUpdateBestSolution :: IORef (Model -> Rational -> IO ()) - , mipShowRational :: IORef Bool - } - -data Node = - Node - { ndLP :: Simplex2.Solver - , ndDepth :: {-# UNPACK #-} !Int - , ndValue :: Rational - } - -newSolver :: Simplex2.Solver -> IS.IntSet -> IO Solver -newSolver lp ivs = do - lp2 <- Simplex2.cloneSolver lp - - forM_ (IS.toList ivs) $ \v -> do - lb <- Simplex2.getLB lp2 v - case lb of - Just l | not (isInteger l) -> - Simplex2.assertLower lp2 v (fromInteger (ceiling l)) - _ -> return () - ub <- Simplex2.getUB lp2 v - case ub of - Just u | not (isInteger u) -> - Simplex2.assertLower lp2 v (fromInteger (floor u)) - _ -> return () - - bestRef <- newTVarIO Nothing - - nthreadRef <- newIORef 0 - logRef <- newIORef Nothing - showRef <- newIORef False - updateRef <- newIORef (\_ _ -> return ()) - - return $ - MIP - { mipRootLP = lp2 - , mipIVs = ivs - , mipBest = bestRef - - , mipNThread = nthreadRef - , mipLogger = logRef - , mipOnUpdateBestSolution = updateRef - , mipShowRational = showRef - } - -optimize :: Solver -> IO OptResult -optimize solver = do - let lp = mipRootLP solver - update <- readIORef (mipOnUpdateBestSolution solver) - log solver "MIP: Solving LP relaxation..." - ret <- Simplex2.check lp - if not ret - then return Unsat - else do - s0 <- showValue solver =<< Simplex2.getObjValue lp - log solver (printf "MIP: LP relaxation is satisfiable with obj = %s" s0) - log solver "MIP: Optimizing LP relaxation" - ret2 <- Simplex2.optimize lp Simplex2.defaultOptions - case ret2 of - Unsat -> error "should not happen" - ObjLimit -> error "should not happen" - Unbounded -> do - log solver "MIP: LP relaxation is unbounded" - let ivs = mipIVs solver - if IS.null ivs - then return Unbounded - else do - {- - * In general, original problem may have optimal - solution even though LP relaxiation is unbounded. - * But if restricted to rational numbers, the - original problem is unbounded or unsatisfiable - when LP relaxation is unbounded. - -} - origObj <- Simplex2.getObj lp - lp2 <- Simplex2.cloneSolver lp - Simplex2.clearLogger lp2 - Simplex2.setObj lp2 (LA.constant 0) - branchAndBound solver lp2 $ \m _ -> do - update m (LA.evalExpr m origObj) - best <- readTVarIO (mipBest solver) - case best of - Just nd -> do - m <- Simplex2.model (ndLP nd) - atomically $ writeTVar (mipBest solver) $ Just nd{ ndValue = LA.evalExpr m origObj } - return Unbounded - Nothing -> return Unsat - Optimum -> do - s1 <- showValue solver =<< Simplex2.getObjValue lp - log solver $ "MIP: LP relaxation optimum is " ++ s1 - log solver "MIP: Integer optimization begins..." - Simplex2.clearLogger lp - branchAndBound solver lp update - m <- readTVarIO (mipBest solver) - case m of - Nothing -> return Unsat - Just _ -> return Optimum - -branchAndBound :: Solver -> Simplex2.Solver -> (Model -> Rational -> IO ()) -> IO () -branchAndBound solver rootLP update = do - dir <- Simplex2.getOptDir rootLP - rootVal <- Simplex2.getObjValue rootLP - let root = Node{ ndLP = rootLP, ndDepth = 0, ndValue = rootVal } - - pool <- newTVarIO (Seq.singleton root) - activeThreads <- newTVarIO (Map.empty) - visitedNodes <- newTVarIO 0 - solchan <- newTChanIO - - let addNode :: Node -> STM () - addNode nd = do - modifyTVar pool (Seq.|> nd) - - pickNode :: IO (Maybe Node) - pickNode = do - self <- myThreadId - atomically $ modifyTVar activeThreads (Map.delete self) - atomically $ do - s <- readTVar pool - case Seq.viewl s of - nd Seq.:< s2 -> do - writeTVar pool s2 - modifyTVar activeThreads (Map.insert self nd) - return (Just nd) - Seq.EmptyL -> do - ths <- readTVar activeThreads - if Map.null ths - then return Nothing - else retry - - processNode :: Node -> IO () - processNode node = do - let lp = ndLP node - lim <- liftM (fmap ndValue) $ readTVarIO (mipBest solver) - ret <- Simplex2.dualSimplex lp Simplex2.defaultOptions{ Simplex2.objLimit = lim } - - case ret of - Unbounded -> error "should not happen" - Unsat -> return () - ObjLimit -> return () - Optimum -> do - val <- Simplex2.getObjValue lp - p <- prune solver val - unless p $ do - xs <- violated node (mipIVs solver) - case xs of - [] -> atomically $ writeTChan solchan $ node { ndValue = val } - _ -> do - r <- if ndDepth node `mod` 100 /= 0 - then return Nothing - else liftM listToMaybe $ filterM (canDeriveGomoryCut lp) $ map fst xs - case r of - Nothing -> do -- branch - let (v0,val0) = fst $ maximumBy (comparing snd) - [((v,vval), abs (fromInteger (round vval) - vval)) | (v,vval) <- xs] - let lp1 = lp - lp2 <- Simplex2.cloneSolver lp - Simplex2.assertAtom lp1 (LA.var v0 .<=. LA.constant (fromInteger (floor val0))) - Simplex2.assertAtom lp2 (LA.var v0 .>=. LA.constant (fromInteger (ceiling val0))) - atomically $ do - addNode $ Node lp1 (ndDepth node + 1) val - addNode $ Node lp2 (ndDepth node + 1) val - modifyTVar visitedNodes (+1) - Just v -> do -- cut - atom <- deriveGomoryCut lp (mipIVs solver) v - Simplex2.assertAtom lp atom - atomically $ do - addNode $ Node lp (ndDepth node + 1) val - - let isCompleted = do - nodes <- readTVar pool - threads <- readTVar activeThreads - return $ Seq.null nodes && Map.null threads - - -- fork worker threads - nthreads <- liftM (max 1) $ readIORef (mipNThread solver) - - log solver $ printf "MIP: forking %d worker threads..." nthreads - - startCPU <- getCPUTime - startWC <- getCurrentTime - ex <- newEmptyTMVarIO - - let printStatus :: Seq.Seq Node -> Int -> IO () - printStatus nodes visited - | Seq.null nodes = return () -- should not happen - | otherwise = do - nowCPU <- getCPUTime - nowWC <- getCurrentTime - let spentCPU = (nowCPU - startCPU) `div` 10^(12::Int) - let spentWC = round (nowWC `diffUTCTime` startWC) :: Int - - let vs = map ndValue (F.toList nodes) - dualBound = - case dir of - OptMin -> minimum vs - OptMax -> maximum vs - - primalBound <- do - x <- readTVarIO (mipBest solver) -- TODO: 引数にするようにした方が良い? - return $ case x of - Nothing -> Nothing - Just node -> Just (ndValue node) - - (p,g) <- case primalBound of - Nothing -> return ("not yet found", "--") - Just val -> do - p <- showValue solver val - let g = if val == 0 - then "inf" - else printf "%.2f%%" (fromRational (abs (dualBound - val) * 100 / abs val) :: Double) - return (p, g) - d <- showValue solver dualBound - - let range = - case dir of - OptMin -> p ++ " >= " ++ d - OptMax -> p ++ " <= " ++ d - - log solver $ printf "cpu time = %d sec; wc time = %d sec; active nodes = %d; visited nodes = %d; %s; gap = %s" - spentCPU spentWC (Seq.length nodes) visited range g - - mask $ \(restore :: forall a. IO a -> IO a) -> do - threads <- replicateM nthreads $ do - forkIO $ do - let loop = do - m <- pickNode - case m of - Nothing -> return () - Just node -> processNode node >> loop - ret <- try $ restore loop - case ret of - Left e -> atomically (putTMVar ex e) - Right _ -> return () - - let propagateException :: SomeException -> IO () - propagateException e = do - mapM_ (\t -> throwTo t e) threads - throwIO e - - let loop = do - ret <- try $ timeout (2*1000*1000) $ restore $ atomically $ msum - [ do node <- readTChan solchan - ret <- do - old <- readTVar (mipBest solver) - case old of - Nothing -> do - writeTVar (mipBest solver) (Just node) - return True - Just best -> do - let isBetter = if dir==OptMin then ndValue node < ndValue best else ndValue node > ndValue best - when isBetter $ writeTVar (mipBest solver) (Just node) - return isBetter - return $ do - when ret $ do - let lp = ndLP node - m <- Simplex2.model lp - update m (ndValue node) - loop - , do b <- isCompleted - guard b - return $ return () - , do e <- readTMVar ex - return $ propagateException e - ] - - case ret of - Left (e::SomeException) -> propagateException e - Right (Just m) -> m - Right Nothing -> do -- timeout - (nodes, visited) <- atomically $ do - nodes <- readTVar pool - athreads <- readTVar activeThreads - visited <- readTVar visitedNodes - return (Seq.fromList (Map.elems athreads) Seq.>< nodes, visited) - printStatus nodes visited - loop - - loop - -getBestSolution :: Solver -> IO (Maybe (Model, Rational)) -getBestSolution solver = do - ret <- readTVarIO (mipBest solver) - case ret of - Nothing -> return Nothing - Just node -> do - m <- Simplex2.model (ndLP node) - return $ Just (m, ndValue node) - -getBestModel :: Solver -> IO (Maybe Model) -getBestModel solver = liftM (fmap fst) $ getBestSolution solver - -getBestValue :: Solver -> IO (Maybe Rational) -getBestValue solver = liftM (fmap snd) $ getBestSolution solver - -violated :: Node -> IS.IntSet -> IO [(Var, Rational)] -violated node ivs = do - m <- Simplex2.model (ndLP node) - let p (v,val) = v `IS.member` ivs && not (isInteger val) - return $ filter p (IM.toList m) - -prune :: Solver -> Rational -> IO Bool -prune solver lb = do - b <- readTVarIO (mipBest solver) - case b of - Nothing -> return False - Just node -> do - dir <- Simplex2.getOptDir (mipRootLP solver) - return $ if dir==OptMin then ndValue node <= lb else ndValue node >= lb - -showValue :: Solver -> Rational -> IO String -showValue solver v = do - printRat <- readIORef (mipShowRational solver) - return $ Simplex2.showValue printRat v - -setShowRational :: Solver -> Bool -> IO () -setShowRational solver = writeIORef (mipShowRational solver) - -setNThread :: Solver -> Int -> IO () -setNThread solver = writeIORef (mipNThread solver) - -{-------------------------------------------------------------------- - Logging ---------------------------------------------------------------------} - --- | set callback function for receiving messages. -setLogger :: Solver -> (String -> IO ()) -> IO () -setLogger solver logger = do - writeIORef (mipLogger solver) (Just logger) - -setOnUpdateBestSolution :: Solver -> (Model -> Rational -> IO ()) -> IO () -setOnUpdateBestSolution solver cb = do - writeIORef (mipOnUpdateBestSolution solver) cb - -log :: Solver -> String -> IO () -log solver msg = logIO solver (return msg) - -logIO :: Solver -> IO String -> IO () -logIO solver action = do - m <- readIORef (mipLogger solver) - case m of - Nothing -> return () - Just logger -> action >>= logger - -{-------------------------------------------------------------------- - GomoryCut ---------------------------------------------------------------------} - -deriveGomoryCut :: Simplex2.Solver -> IS.IntSet -> Var -> IO (LA.Atom Rational) -deriveGomoryCut lp ivs xi = do - v0 <- Simplex2.getValue lp xi - let f0 = fracPart v0 - assert (0 < f0 && f0 < 1) $ return () - - row <- Simplex2.getRow lp xi - - -- remove fixed variables - let p (_,xj) = do - lb <- Simplex2.getLB lp xj - ub <- Simplex2.getUB lp xj - case (lb,ub) of - (Just l, Just u) -> return (l < u) - _ -> return True - ns <- filterM p $ LA.terms row - - js <- flip filterM ns $ \(_, xj) -> do - vj <- Simplex2.getValue lp xj - lb <- Simplex2.getLB lp xj - return $ Just vj == lb - ks <- flip filterM ns $ \(_, xj) -> do - vj <- Simplex2.getValue lp xj - ub <- Simplex2.getUB lp xj - return $ Just vj == ub - - xs1 <- forM js $ \(aij, xj) -> do - let fj = fracPart aij - Just lj <- Simplex2.getLB lp xj - let c = if xj `IS.member` ivs - then (if fj <= 1 - f0 then fj / (1 - f0) else ((1 - fj) / f0)) - else (if aij > 0 then aij / (1 - f0) else (-aij / f0)) - return $ c *^ (LA.var xj ^-^ LA.constant lj) - xs2 <- forM ks $ \(aij, xj) -> do - let fj = fracPart aij - Just uj <- Simplex2.getUB lp xj - let c = if xj `IS.member` ivs - then (if fj <= f0 then fj / f0 else ((1 - fj) / (1 - f0))) - else (if aij > 0 then aij / f0 else (-aij / (1 - f0))) - return $ c *^ (LA.constant uj ^-^ LA.var xj) - - return $ sumV xs1 ^+^ sumV xs2 .>=. LA.constant 1 - --- TODO: Simplex2をδに対応させたら、xi, xj がδを含まない有理数であるという条件も必要 -canDeriveGomoryCut :: Simplex2.Solver -> Var -> IO Bool -canDeriveGomoryCut lp xi = do - b <- Simplex2.isBasicVariable lp xi - if not b - then return False - else do - val <- Simplex2.getValue lp xi - if isInteger val - then return False - else do - row <- Simplex2.getRow lp xi - ys <- forM (LA.terms row) $ \(_,xj) -> do - vj <- Simplex2.getValue lp xj - lb <- Simplex2.getLB lp xj - ub <- Simplex2.getUB lp xj - return $ Just vj == lb || Just vj == ub - return (and ys) diff --git a/src/ToySolver/MIPSolverHL.hs b/src/ToySolver/MIPSolverHL.hs deleted file mode 100644 --- a/src/ToySolver/MIPSolverHL.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.MIPSolverHL --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) --- --- References: --- --- * [Gomory1960] --- Ralph E. Gomory. --- An Algorithm for the Mixed Integer Problem, Technical Report --- RM-2597, 1960, The Rand Corporation, Santa Monica, CA. --- --- --- * [Gomory1958] --- Ralph E. Gomory. --- Outline of an algorithm for integer solutions to linear programs. --- Bull. Amer. Math. Soc., Vol. 64, No. 5. (1958), pp. 275-278. --- ------------------------------------------------------------------------------ - -module ToySolver.MIPSolverHL - ( module Data.OptDir - , OptResult (..) - , minimize - , maximize - , optimize - ) where - -import Control.Exception -import Control.Monad.State -import Data.Ord -import Data.Maybe -import Data.List (maximumBy) -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.OptDir -import Data.VectorSpace - -import ToySolver.Data.ArithRel -import ToySolver.Data.Var -import qualified ToySolver.Data.LA as LA -import qualified ToySolver.Simplex as Simplex -import qualified ToySolver.LPSolver as LPSolver -import ToySolver.LPSolver hiding (OptResult (..)) -import ToySolver.LPSolverHL (OptResult (..)) -import qualified ToySolver.OmegaTest as OmegaTest -import ToySolver.Internal.Util (isInteger, fracPart) - --- --------------------------------------------------------------------------- - -data Node r - = Node - { ndSolver :: LPSolver.Solver r - , ndDepth :: {-# UNPACK #-} !Int --- , ndCutSlackVariables :: VarSet - } - -ndTableau :: Node r -> Simplex.Tableau r -ndTableau node = evalState getTableau (ndSolver node) - -ndLowerBound :: (Num r, Eq r) => Node r -> r -ndLowerBound node = evalState (liftM Simplex.currentObjValue getTableau) (ndSolver node) - -data Err = ErrUnbounded | ErrUnsat deriving (Ord, Eq, Show, Enum, Bounded) - -maximize :: RealFrac r => LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r -maximize = optimize OptMax - -minimize :: RealFrac r => LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r -minimize = optimize OptMin - -optimize :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r -optimize optdir obj cs ivs = - case mkInitialNode optdir obj cs ivs of - Left err -> - case err of - ErrUnsat -> OptUnsat - ErrUnbounded -> - if IS.null ivs - then Unbounded - else - {- - Fallback to Fourier-Motzkin + OmegaTest - * In general, original problem may have optimal - solution even though LP relaxiation is unbounded. - * But if restricted to rational numbers, the - original problem is unbounded or unsatisfiable - when LP relaxation is unbounded. - -} - case OmegaTest.solveQFLA OmegaTest.defaultOptions (vars cs `IS.union` ivs) (map conv cs) ivs of - Nothing -> OptUnsat - Just _ -> Unbounded - Right (node0, ivs2) -> - case traverse optdir obj ivs2 node0 of - Left ErrUnbounded -> error "shoud not happen" - Left ErrUnsat -> OptUnsat - Right node -> flip evalState (ndSolver node) $ do - tbl <- getTableau - model <- getModel vs - return $ Optimum (Simplex.currentObjValue tbl) model - where - vs = vars cs `IS.union` vars obj - -tableau' :: (RealFrac r) => [LA.Atom r] -> VarSet -> LP r VarSet -tableau' cs ivs = do - let (nonnegVars, cs') = collectNonnegVars cs ivs - fvs = vars cs `IS.difference` nonnegVars - ivs2 <- liftM IS.unions $ forM (IS.toList fvs) $ \v -> do - v1 <- newVar - v2 <- newVar - define v (LA.var v1 ^-^ LA.var v2) - return $ if v `IS.member` ivs then IS.fromList [v1,v2] else IS.empty - mapM_ addConstraint cs' - return ivs2 - -conv :: RealFrac r => LA.Atom r -> LA.Atom Rational -conv (Rel a op b) = Rel (f a) op (f b) - where - f = LA.mapCoeff toRational - -mkInitialNode :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> Either Err (Node r, VarSet) -mkInitialNode optdir obj cs ivs = - flip evalState (emptySolver vs) $ do - ivs2 <- tableau' cs ivs - ret <- LPSolver.twoPhaseSimplex optdir obj - case ret of - LPSolver.Unsat -> return (Left ErrUnsat) - LPSolver.Unbounded -> return (Left ErrUnbounded) - LPSolver.Optimum -> do - solver <- get - return $ Right $ - ( Node{ ndSolver = solver - , ndDepth = 0 --- , ndCutSlackVariables = IS.empty - } - , ivs `IS.union` ivs2 - ) - where - vs = vars cs `IS.union` vars obj - -isStrictlyBetter :: RealFrac r => OptDir -> r -> r -> Bool -isStrictlyBetter optdir = if optdir==OptMin then (<) else (>) - -traverse :: forall r. RealFrac r => OptDir -> LA.Expr r -> VarSet -> Node r -> Either Err (Node r) -traverse optdir obj ivs node0 = loop [node0] Nothing - where - loop :: [Node r] -> Maybe (Node r) -> Either Err (Node r) - loop [] (Just best) = Right best - loop [] Nothing = Left ErrUnsat - loop (n:ns) Nothing = - case children n of - Nothing -> loop ns (Just n) - Just cs -> loop (cs++ns) Nothing - loop (n:ns) (Just best) - | isStrictlyBetter optdir (ndLowerBound n) (ndLowerBound best) = - case children n of - Nothing -> loop ns (Just n) - Just cs -> loop (cs++ns) (Just best) - | otherwise = loop ns (Just best) - - reopt :: Solver r -> Maybe (Solver r) - reopt s = flip evalState s $ do - ret <- dualSimplex optdir obj - if ret - then liftM Just get - else return Nothing - - children :: Node r -> Maybe [Node r] - children node - | null xs = Nothing -- no violation - | ndDepth node `mod` 100 == 0 = -- cut - let - (f0, m0) = maximumBy (comparing fst) [(fracPart val, m) | (_,m,val) <- xs] - sv = flip execState (ndSolver node) $ do - s <- newVar - let g j x = assert (a >= 0) a - where - a | j `IS.member` ivs = - if fracPart x <= f0 - then fracPart x - else (f0 / (f0 - 1)) * (fracPart x - 1) - -- [Gomory1960] では (f0 / (1 - f0)) * (fracPart x - 1) としているが、 - -- これは誤り - | otherwise = - if x >= 0 - then x - else (f0 / (f0 - 1)) * x - putTableau $ IM.insert s (IM.mapWithKey (\j x -> negate (g j x)) m0, negate f0) tbl - in Just $ [node{ ndSolver = sv2, ndDepth = ndDepth node + 1 } | sv2 <- maybeToList (reopt sv)] - | otherwise = -- branch - let (v0, val0) = snd $ maximumBy (comparing fst) [(fracPart val, (v, val)) | (v,_,val) <- xs] - cs = [ LA.var v0 .>=. LA.constant (fromIntegral (ceiling val0 :: Integer)) - , LA.var v0 .<=. LA.constant (fromIntegral (floor val0 :: Integer)) - ] - svs = [execState (addConstraint c) (ndSolver node) | c <- cs] - in Just $ [node{ ndSolver = sv, ndDepth = ndDepth node + 1 } | Just sv <- map reopt svs] - - where - tbl :: Simplex.Tableau r - tbl = ndTableau node - - xs :: [(Var, VarMap r, r)] - xs = [ (v, m, val) - | v <- IS.toList ivs - , Just (m, val) <- return (IM.lookup v tbl) - , not (isInteger val) - ] - --- --------------------------------------------------------------------------- - -example1 :: (Fractional r, Eq r) => (OptDir, LA.Expr r, [LA.Atom r], VarSet) -example1 = (optdir, obj, cs, ivs) - where - optdir = OptMax - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - x4 = LA.var 4 - obj = x1 ^+^ 2 *^ x2 ^+^ 3 *^ x3 ^+^ x4 - cs = - [ (-1) *^ x1 ^+^ x2 ^+^ x3 ^+^ 10*^x4 .<=. LA.constant 20 - , x1 ^-^ 3 *^ x2 ^+^ x3 .<=. LA.constant 30 - , x2 ^-^ 3.5 *^ x4 .==. LA.constant 0 - , LA.constant 0 .<=. x1 - , x1 .<=. LA.constant 40 - , LA.constant 0 .<=. x2 - , LA.constant 0 .<=. x3 - , LA.constant 2 .<=. x4 - , x4 .<=. LA.constant 3 - ] - ivs = IS.singleton 4 - -test1 :: Bool -test1 = result==expected - where - (optdir, obj, cs, ivs) = example1 - result, expected :: OptResult Rational - result = optimize optdir obj cs ivs - expected = Optimum (245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) - -test1' :: Bool -test1' = result==expected - where - (optdir, obj, cs, ivs) = example1 - f OptMin = OptMax - f OptMax = OptMin - result, expected :: OptResult Rational - result = optimize (f optdir) (negateV obj) cs ivs - expected = Optimum (-245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) - --- 『数理計画法の基礎』(坂和 正敏) p.109 例 3.8 -example2 :: (Fractional r, Eq r) => (OptDir, LA.Expr r, [LA.Atom r], VarSet) -example2 = (optdir, obj, cs, ivs) - where - optdir = OptMin - [x1,x2,x3] = map LA.var [1..3] - obj = (-1) *^ x1 ^-^ 3 *^ x2 ^-^ 5 *^ x3 - cs = - [ 3 *^ x1 ^+^ 4 *^ x2 .<=. LA.constant 10 - , 2 *^ x1 ^+^ x2 ^+^ x3 .<=. LA.constant 7 - , 3*^x1 ^+^ x2 ^+^ 4 *^ x3 .==. LA.constant 12 - , LA.constant 0 .<=. x1 - , LA.constant 0 .<=. x2 - , LA.constant 0 .<=. x3 - ] - ivs = IS.fromList [1,2] - -test2 :: Bool -test2 = result == expected - where - result, expected :: OptResult Rational - result = optimize optdir obj cs ivs - expected = Optimum (-37/2) (IM.fromList [(1,0),(2,2),(3,5/2)]) - (optdir, obj, cs, ivs) = example2 - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/OmegaTest.hs b/src/ToySolver/OmegaTest.hs deleted file mode 100644 --- a/src/ToySolver/OmegaTest.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.OmegaTest --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- (incomplete) implementation of Omega Test --- --- References: --- --- * William Pugh. The Omega test: a fast and practical integer --- programming algorithm for dependence analysis. In Proceedings of --- the 1991 ACM/IEEE conference on Supercomputing (1991), pp. 4-13. --- --- * --- --- See also: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.OmegaTest - ( Model - , solve - , solveQFLA - , Options (..) - , defaultOptions - , checkRealNoCheck - , checkRealByFM - ) where - -import Control.Monad -import Data.List -import Data.Maybe -import Data.Ord -import Data.Ratio -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.VectorSpace - -import ToySolver.Data.ArithRel -import ToySolver.Data.Boolean -import ToySolver.Data.DNF -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var -import ToySolver.Internal.Util (combineMaybe) -import qualified ToySolver.FourierMotzkin as FM -import ToySolver.FourierMotzkin.Core (Lit (..), Rat, toLAAtom) - --- --------------------------------------------------------------------------- - -data Options - = Options - { optCheckReal :: VarSet -> [LA.Atom Rational] -> Bool - } - -defaultOptions :: Options -defaultOptions = - Options - { optCheckReal = - -- checkRealNoCheck - checkRealByFM - } - -checkRealNoCheck :: VarSet -> [LA.Atom Rational] -> Bool -checkRealNoCheck _ _ = True - -checkRealByFM :: VarSet -> [LA.Atom Rational] -> Bool -checkRealByFM vs as = isJust $ FM.solve vs as - --- --------------------------------------------------------------------------- - -type ExprZ = LA.Expr Integer - --- 制約集合の単純化 --- It returns Nothing when a inconsistency is detected. -simplify :: [Lit] -> Maybe [Lit] -simplify = fmap concat . mapM f - where - f :: Lit -> Maybe [Lit] - f lit@(Pos e) = - case LA.asConst e of - Just x -> guard (x > 0) >> return [] - Nothing -> return [lit] - f lit@(Nonneg e) = - case LA.asConst e of - Just x -> guard (x >= 0) >> return [] - Nothing -> return [lit] - --- --------------------------------------------------------------------------- - -leZ, ltZ, geZ, gtZ :: ExprZ -> ExprZ -> Lit --- Note that constants may be floored by division -leZ e1 e2 = Nonneg (LA.mapCoeff (`div` d) e) - where - e = e2 ^-^ e1 - d = abs $ gcd' [c | (c,v) <- LA.terms e, v /= LA.unitVar] -ltZ e1 e2 = (e1 ^+^ LA.constant 1) `leZ` e2 -geZ = flip leZ -gtZ = flip gtZ - -eqZ :: ExprZ -> ExprZ -> (DNF Lit) -eqZ e1 e2 - = if LA.coeff LA.unitVar e3 `mod` d == 0 - then DNF [[Nonneg e, Nonneg (negateV e)]] - else false - where - e = LA.mapCoeff (`div` d) e3 - e3 = e1 ^-^ e2 - d = abs $ gcd' [c | (c,v) <- LA.terms e3, v /= LA.unitVar] - --- --------------------------------------------------------------------------- - -{- -(ls,us) represents -{ x | ∀(M,c)∈ls. M/c≤x, ∀(M,c)∈us. x≤M/c } --} -type BoundsZ = ([Rat],[Rat]) - -collectBoundsZ :: Var -> [Lit] -> (BoundsZ,[Lit]) -collectBoundsZ v = foldr phi (([],[]),[]) - where - phi :: Lit -> (BoundsZ,[Lit]) -> (BoundsZ,[Lit]) - phi (Pos t) x = phi (Nonneg (t ^-^ LA.constant 1)) x - phi lit@(Nonneg t) ((ls,us),xs) = - case LA.extract v t of - (c,t') -> - case c `compare` 0 of - EQ -> ((ls, us), lit : xs) - GT -> (((negateV t', c) : ls, us), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x - LT -> ((ls, (t', negate c) : us), xs) -- 0 ≤ cx + M ⇔ x ≤ M/-c - -isExact :: BoundsZ -> Bool -isExact (ls,us) = and [a==1 || b==1 | (_,a)<-ls , (_,b)<-us] - -solve' :: Options -> [Var] -> [Lit] -> Maybe (Model Integer) -solve' opt vs2 xs = simplify xs >>= go vs2 - where - go :: [Var] -> [Lit] -> Maybe (Model Integer) - go [] [] = return IM.empty - go [] _ = mzero - go vs ys | not (optCheckReal opt (IS.fromList vs) (map toLAAtom ys)) = mzero - go vs ys = - if isExact bnd - then case1 - else case1 `mplus` case2 - where - (v,vs',bnd@(ls,us),rest) = chooseVariable vs ys - - case1 = do - let zs = [ LA.constant ((a-1)*(b-1)) `leZ` (a *^ d ^-^ b *^ c) - | (c,a)<-ls , (d,b)<-us ] - model <- go vs' =<< simplify (zs ++ rest) - case pickupZ (evalBoundsZ model bnd) of - Nothing -> error "ToySolver.OmegaTest.solve': should not happen" - Just val -> return $ IM.insert v val model - - case2 = msum - [ do eq <- isZero $ a' *^ LA.var v ^-^ (c' ^+^ LA.constant k) - let (vs'', lits'', mt) = elimEq eq (v:vs') ys - model <- go vs'' =<< simplify lits'' - return $ mt model - | let m = maximum [b | (_,b)<-us] - , (c',a') <- ls - , k <- [0 .. (m*a'-a'-m) `div` m] - ] - -chooseVariable :: [Var] -> [Lit] -> (Var, [Var], BoundsZ, [Lit]) -chooseVariable vs xs = head $ [e | e@(_,_,bnd,_) <- table, isExact bnd] ++ table - where - table = [ (v, vs', bnd, rest) - | (v,vs') <- pickup vs, let (bnd, rest) = collectBoundsZ v xs - ] - -evalBoundsZ :: Model Integer -> BoundsZ -> IntervalZ -evalBoundsZ model (ls,us) = - foldl' intersectZ univZ $ - [ (Just (ceiling (LA.evalExpr model x % c)), Nothing) | (x,c) <- ls ] ++ - [ (Nothing, Just (floor (LA.evalExpr model x % c))) | (x,c) <- us ] - -elimEq :: ExprZ -> [Var] -> [Lit] -> ([Var], [Lit], Model Integer -> Model Integer) -elimEq e vs lits = - if abs ak == 1 - then - case LA.extract xk e of - (_, e') -> - let xk_def = signum ak *^ negateV e' - in ( vs - , [applySubst1Lit xk xk_def lit | lit <- lits] - , \model -> IM.insert xk (LA.evalExpr model xk_def) model - ) - else - let m = abs ak + 1 - xk_def = (- signum ak * m) *^ LA.var sigma ^+^ - LA.fromTerms [(signum ak * (a `zmod` m), x) | (a,x) <- LA.terms e, x /= xk] - e2 = (- abs ak) *^ LA.var sigma ^+^ - LA.fromTerms [((floor (a%m + 1/2) + (a `zmod` m)), x) | (a,x) <- LA.terms e, x /= xk] - -- LA.applySubst1 xk xk_def e を normalize したもの - in case elimEq e2 (sigma : vs) [applySubst1Lit xk xk_def lit | lit <- lits] of - (vs2, lits2, mt) -> - ( vs2 - , lits2 - , \model -> - let model2 = mt model - in IM.delete sigma $ IM.insert xk (LA.evalExpr model2 xk_def) model2 - ) - where - (ak,xk) = minimumBy (comparing (abs . fst)) [(a,x) | (a,x) <- LA.terms e, x /= LA.unitVar] - sigma = maximum (-1 : vs) + 1 - -applySubst1Lit :: Var -> ExprZ -> Lit -> Lit -applySubst1Lit v e (Nonneg e2) = LA.applySubst1 v e e2 `geZ` LA.constant 0 - --- --------------------------------------------------------------------------- - -isZero :: ExprZ -> Maybe ExprZ -isZero e - = if LA.coeff LA.unitVar e `mod` d == 0 - then Just $ e2 - else Nothing - where - e2 = LA.mapCoeff (`div` d) e - d = abs $ gcd' [c | (c,v) <- LA.terms e, v /= LA.unitVar] - --- --------------------------------------------------------------------------- - -type IntervalZ = (Maybe Integer, Maybe Integer) - -univZ :: IntervalZ -univZ = (Nothing, Nothing) - -intersectZ :: IntervalZ -> IntervalZ -> IntervalZ -intersectZ (l1,u1) (l2,u2) = (combineMaybe max l1 l2, combineMaybe min u1 u2) - -pickupZ :: IntervalZ -> Maybe Integer -pickupZ (Nothing,Nothing) = return 0 -pickupZ (Just x, Nothing) = return x -pickupZ (Nothing, Just x) = return x -pickupZ (Just x, Just y) = if x <= y then return x else mzero - --- --------------------------------------------------------------------------- - -solve :: Options -> VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) -solve opt vs cs = msum [solve' opt (IS.toList vs) lits | lits <- unDNF dnf] - where - dnf = andB (map f cs) - f (Rel lhs op rhs) = - case op of - Lt -> DNF [[a `ltZ` b]] - Le -> DNF [[a `leZ` b]] - Gt -> DNF [[a `gtZ` b]] - Ge -> DNF [[a `geZ` b]] - Eql -> eqZ a b - NEq -> DNF [[a `ltZ` b], [a `gtZ` b]] - where - (e1,c1) = g lhs - (e2,c2) = g rhs - a = c2 *^ e1 - b = c1 *^ e2 - g :: LA.Expr Rational -> (ExprZ, Integer) - g a = (LA.mapCoeff (\c -> floor (c * fromInteger d)) a, d) - where - d = foldl' lcm 1 [denominator c | (c,_) <- LA.terms a] - -solveQFLA :: Options -> VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) -solveQFLA opt vs cs ivs = listToMaybe $ do - (cs2, mt) <- FM.projectN rvs cs - m <- maybeToList $ solve opt ivs cs2 - return $ mt $ IM.map fromInteger m - where - rvs = vs `IS.difference` ivs - --- --------------------------------------------------------------------------- - -zmod :: Integer -> Integer -> Integer -a `zmod` b = a - b * floor (a % b + 1 / 2) - -gcd' :: [Integer] -> Integer -gcd' [] = 1 -gcd' xs = foldl1' gcd xs - -pickup :: [a] -> [(a,[a])] -pickup [] = [] -pickup (x:xs) = (x,xs) : [(y,x:ys) | (y,ys) <- pickup xs] - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/OmegaTest/Misc.hs b/src/ToySolver/OmegaTest/Misc.hs deleted file mode 100644 --- a/src/ToySolver/OmegaTest/Misc.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module ToySolver.OmegaTest.Misc - ( checkRealByCAD - , checkRealBySimplex - ) where - -import Control.Monad -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.Maybe -import qualified Data.Set as Set -import System.IO.Unsafe - -import qualified ToySolver.Data.LA as LA -import qualified ToySolver.Data.Polynomial as P -import ToySolver.Data.Var -import qualified ToySolver.CAD as CAD -import qualified ToySolver.Simplex2 as Simplex2 - -checkRealByCAD :: VarSet -> [LA.Atom Rational] -> Bool -checkRealByCAD vs as = isJust $ CAD.solve vs2 (map (fmap f) as) - where - vs2 = Set.fromAscList $ IS.toAscList vs - - f :: LA.Expr Rational -> P.Polynomial Rational Int - f t = sum [ if x == LA.unitVar - then P.constant c - else P.constant c * P.var x - | (c,x) <- LA.terms t ] - -checkRealBySimplex :: VarSet -> [LA.Atom Rational] -> Bool -checkRealBySimplex vs as = unsafePerformIO $ do - solver <- Simplex2.newSolver - s <- liftM IM.fromList $ forM (IS.toList vs) $ \v -> do - v2 <- Simplex2.newVar solver - return (v, LA.var v2) - forM_ as $ \a -> do - Simplex2.assertAtomEx solver (fmap (LA.applySubst s) a) - Simplex2.check solver diff --git a/src/ToySolver/SAT.hs b/src/ToySolver/SAT.hs --- a/src/ToySolver/SAT.hs +++ b/src/ToySolver/SAT.hs @@ -59,3044 +59,3433 @@ , addPBAtLeastSoft , addPBAtMostSoft , addPBExactlySoft - - -- * Solving - , solve - , solveWith - , BudgetExceeded (..) - - -- * Extract results - , Model - , model - , failedAssumptions - - -- * Solver configulation - , RestartStrategy (..) - , setRestartStrategy - , defaultRestartStrategy - , setRestartFirst - , defaultRestartFirst - , setRestartInc - , defaultRestartInc - , setLearntSizeFirst - , defaultLearntSizeFirst - , setLearntSizeInc - , defaultLearntSizeInc - , setCCMin - , defaultCCMin - , LearningStrategy (..) - , setLearningStrategy - , defaultLearningStrategy - , setEnablePhaseSaving - , getEnablePhaseSaving - , defaultEnablePhaseSaving - , setEnableForwardSubsumptionRemoval - , getEnableForwardSubsumptionRemoval - , defaultEnableForwardSubsumptionRemoval - , setEnableBackwardSubsumptionRemoval - , getEnableBackwardSubsumptionRemoval - , defaultEnableBackwardSubsumptionRemoval - , setVarPolarity - , setLogger - , setCheckModel - , setRandomFreq - , defaultRandomFreq - , setRandomGen - , getRandomGen - , setConfBudget - , PBHandlerType (..) - , setPBHandlerType - , defaultPBHandlerType - - -- * Read state - , nVars - , nAssigns - , nConstraints - , nLearnt - - -- * Internal API - , varBumpActivity - , varDecayActivity - ) where - -import Prelude hiding (log) -import Control.Loop -import Control.Monad -import Control.Exception -#if MIN_VERSION_array(0,5,0) -import Data.Array.IO -import Data.Array.Unsafe (unsafeFreeze) -#elif MIN_VERSION_array(0,4,0) -import Data.Array.IO hiding (unsafeFreeze) -import Data.Array.Unsafe (unsafeFreeze) -#else -import Data.Array.IO -#endif -import Data.Array.Base (unsafeRead, unsafeWrite) -#if MIN_VERSION_hashable(1,2,0) -import Data.Bits (xor) -- for defining 'combine' function -#endif -import Data.Function (on) -import Data.Hashable -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.IORef -import Data.List -import Data.Maybe -import Data.Ord -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Set as Set -import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ -import qualified ToySolver.Internal.Data.SeqQueue as SQ -import Data.Time -import Data.Typeable -import System.CPUTime -import qualified System.Random as Rand -import Text.Printf - -#ifdef __GLASGOW_HASKELL__ -import GHC.Types (IO (..)) -import GHC.Exts hiding (Constraint) -#endif - -import ToySolver.Data.LBool -import ToySolver.SAT.Types - -{-------------------------------------------------------------------- - internal data structures ---------------------------------------------------------------------} - -type Level = Int - -levelRoot :: Level -levelRoot = -1 - -data Assignment - = Assignment - { aValue :: !Bool - , aIndex :: {-# UNPACK #-} !Int - , aLevel :: {-# UNPACK #-} !Level - , aReason :: !(Maybe SomeConstraintHandler) - , aBacktrackCBs :: !(IORef [IO ()]) - } - -data VarData - = VarData - { vdAssignment :: !(IORef (Maybe Assignment)) - , vdPolarity :: !(IORef Bool) - , vdPosLitData :: !LitData - , vdNegLitData :: !LitData - , vdActivity :: !(IORef VarActivity) - } - -data LitData - = LitData - { -- | will be invoked when this literal is falsified - ldWatches :: !(IORef [SomeConstraintHandler]) - , ldOccurList :: !(IORef (HashSet SomeConstraintHandler)) - } - -newVarData :: IO VarData -newVarData = do - ainfo <- newIORef Nothing - polarity <- newIORef True - pos <- newLitData - neg <- newLitData - activity <- newIORef 0 - return $ VarData ainfo polarity pos neg activity - -newLitData :: IO LitData -newLitData = do - ws <- newIORef [] - occ <- newIORef HashSet.empty - return $ LitData ws occ - -varData :: Solver -> Var -> IO VarData -varData solver !v = do - a <- readIORef (svVarData solver) - unsafeRead a (v-1) - -litData :: Solver -> Lit -> IO LitData -litData solver !l = - -- litVar による heap allocation を避けるために、 - -- litPolarityによる分岐後にvarDataを呼ぶ。 - if litPolarity l - then do - vd <- varData solver l - return $ vdPosLitData vd - else do - vd <- varData solver (negate l) - return $ vdNegLitData vd - -{-# INLINE varValue #-} -varValue :: Solver -> Var -> IO LBool -varValue solver !v = do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> return lUndef - Just x -> return $! (liftBool $! aValue x) - -{-# INLINE litValue #-} -litValue :: Solver -> Lit -> IO LBool -litValue solver !l = do - -- litVar による heap allocation を避けるために、 - -- litPolarityによる分岐後にvarDataを呼ぶ。 - if litPolarity l - then varValue solver l - else do - m <- varValue solver (negate l) - return $! lnot m - -varLevel :: Solver -> Var -> IO Level -varLevel solver !v = do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> error ("ToySolver.SAT.varLevel: unassigned var " ++ show v) - Just a -> return (aLevel a) - -litLevel :: Solver -> Lit -> IO Level -litLevel solver l = varLevel solver (litVar l) - -varReason :: Solver -> Var -> IO (Maybe SomeConstraintHandler) -varReason solver !v = do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> error ("ToySolver.SAT.varReason: unassigned var " ++ show v) - Just a -> return (aReason a) - -varAssignNo :: Solver -> Var -> IO Int -varAssignNo solver !v = do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> error ("ToySolver.SAT.varAssignNo: unassigned var " ++ show v) - Just a -> return (aIndex a) - --- | Solver instance -data Solver - = Solver - { svOk :: !(IORef Bool) - , svVarQueue :: !PQ.PriorityQueue - , svTrail :: !(IORef [Lit]) - , svVarCounter :: !(IORef Int) - , svVarData :: !(IORef (IOArray Int VarData)) - , svConstrDB :: !(IORef [SomeConstraintHandler]) - , svLearntDB :: !(IORef (Int,[SomeConstraintHandler])) - , svAssumptions :: !(IORef (IOUArray Int Lit)) - , svLevel :: !(IORef Level) - , svBCPQueue :: !(SQ.SeqQueue Lit) - , svModel :: !(IORef (Maybe Model)) - , svNDecision :: !(IORef Int) - , svNRandomDecision :: !(IORef Int) - , svNConflict :: !(IORef Int) - , svNRestart :: !(IORef Int) - , svNAssigns :: !(IORef Int) - , svNFixed :: !(IORef Int) - , svNLearntGC :: !(IORef Int) - , svNRemovedConstr :: !(IORef Int) - - -- | Inverse of the variable activity decay factor. (default 1 / 0.95) - , svVarDecay :: !(IORef Double) - - -- | Amount to bump next variable with. - , svVarInc :: !(IORef Double) - - -- | Inverse of the constraint activity decay factor. (1 / 0.999) - , svConstrDecay :: !(IORef Double) - - -- | Amount to bump next constraint with. - , svConstrInc :: !(IORef Double) - - , svRestartStrategy :: !(IORef RestartStrategy) - - -- | The initial restart limit. (default 100) - , svRestartFirst :: !(IORef Int) - - -- | The factor with which the restart limit is multiplied in each restart. (default 1.5) - , svRestartInc :: !(IORef Double) - - -- | The initial limit for learnt constraints. - , svLearntSizeFirst :: !(IORef Int) - - -- | The limit for learnt constraints is multiplied with this factor periodically. (default 1.1) - , svLearntSizeInc :: !(IORef Double) - - , svLearntLim :: !(IORef Int) - , svLearntLimAdjCnt :: !(IORef Int) - , svLearntLimSeq :: !(IORef [(Int,Int)]) - - -- | Controls conflict constraint minimization (0=none, 1=local, 2=recursive) - , svCCMin :: !(IORef Int) - - , svEnablePhaseSaving :: !(IORef Bool) - , svEnableForwardSubsumptionRemoval :: !(IORef Bool) - - , svLearningStrategy :: !(IORef LearningStrategy) - - , svPBHandlerType :: !(IORef PBHandlerType) - - , svEnableBackwardSubsumptionRemoval :: !(IORef Bool) - - , svLogger :: !(IORef (Maybe (String -> IO ()))) - , svStartWC :: !(IORef UTCTime) - , svLastStatWC :: !(IORef UTCTime) - - , svCheckModel :: !(IORef Bool) - - , svRandomFreq :: !(IORef Double) - , svRandomGen :: !(IORef Rand.StdGen) - - , svFailedAssumptions :: !(IORef [Lit]) - - , svConfBudget :: !(IORef Int) - } - -markBad :: Solver -> IO () -markBad solver = do - writeIORef (svOk solver) False - SQ.clear (svBCPQueue solver) - -bcpEnqueue :: Solver -> Lit -> IO () -bcpEnqueue solver l = SQ.enqueue (svBCPQueue solver) l - -bcpDequeue :: Solver -> IO (Maybe Lit) -bcpDequeue solver = SQ.dequeue (svBCPQueue solver) - -bcpCheckEmpty :: Solver -> IO () -bcpCheckEmpty solver = do - size <- SQ.queueSize (svBCPQueue solver) - unless (size == 0) $ - error "BUG: BCP Queue should be empty at this point" - -assignBy :: ConstraintHandler c => Solver -> Lit -> c -> IO Bool -assignBy solver lit c = do - lv <- readIORef (svLevel solver) - let !c2 = if lv == levelRoot - then Nothing - else Just $! toConstraintHandler c - assign_ solver lit c2 - -assign :: Solver -> Lit -> IO Bool -assign solver lit = assign_ solver lit Nothing - -assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool -assign_ solver !lit reason = assert (validLit lit) $ do - vd <- varData solver (litVar lit) - m <- readIORef (vdAssignment vd) - case m of - Just a -> return $ litPolarity lit == aValue a - Nothing -> do - idx <- readIORef (svNAssigns solver) - lv <- readIORef (svLevel solver) - bt <- newIORef [] - - writeIORef (vdAssignment vd) $ Just $! - Assignment - { aValue = litPolarity lit - , aIndex = idx - , aLevel = lv - , aReason = reason - , aBacktrackCBs = bt - } - - modifyIORef (svTrail solver) (lit:) - modifyIORef' (svNAssigns solver) (+1) - when (lv == levelRoot) $ modifyIORef' (svNFixed solver) (+1) - bcpEnqueue solver lit - - when debugMode $ logIO solver $ do - let r = case reason of - Nothing -> "" - Just _ -> " by propagation" - return $ printf "assign(level=%d): %d%s" lv lit r - - return True - -unassign :: Solver -> Var -> IO () -unassign solver !v = assert (validVar v) $ do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> error "unassign: should not happen" - Just a -> do - flag <- getEnablePhaseSaving solver - when flag $ writeIORef (vdPolarity vd) (aValue a) - readIORef (aBacktrackCBs a) >>= sequence_ - writeIORef (vdAssignment vd) Nothing - modifyIORef' (svNAssigns solver) (subtract 1) - PQ.enqueue (svVarQueue solver) v - -addBacktrackCB :: Solver -> Var -> IO () -> IO () -addBacktrackCB solver !v callback = do - vd <- varData solver v - m <- readIORef (vdAssignment vd) - case m of - Nothing -> error "addBacktrackCB: should not happen" - Just a -> modifyIORef (aBacktrackCBs a) (callback :) - --- | Register the constraint to be notified when the literal becames false. -watch :: ConstraintHandler c => Solver -> Lit -> c -> IO () -watch solver !lit c = do - when debugMode $ do - lits <- watchedLiterals solver c - unless (lit `elem` lits) $ error "watch: should not happen" - ld <- litData solver lit - modifyIORef (ldWatches ld) (toConstraintHandler c : ) - --- | Returns list of constraints that are watching the literal. -watches :: Solver -> Lit -> IO [SomeConstraintHandler] -watches solver !lit = do - ld <- litData solver lit - readIORef (ldWatches ld) - -addToDB :: ConstraintHandler c => Solver -> c -> IO () -addToDB solver c = do - let c2 = toConstraintHandler c - modifyIORef (svConstrDB solver) (c2 : ) - when debugMode $ logIO solver $ do - str <- showConstraintHandler solver c - return $ printf "constraint %s is added" str - - (lhs,_) <- toPBAtLeast solver c - forM_ lhs $ \(_,lit) -> do - ld <- litData solver lit - modifyIORef' (ldOccurList ld) (HashSet.insert c2) - - sanityCheck solver - -addToLearntDB :: ConstraintHandler c => Solver -> c -> IO () -addToLearntDB solver c = do - modifyIORef (svLearntDB solver) $ \(n,xs) -> (n+1, toConstraintHandler c : xs) - when debugMode $ logIO solver $ do - str <- showConstraintHandler solver c - return $ printf "constraint %s is added" str - sanityCheck solver - -reduceDB :: Solver -> IO () -reduceDB solver = do - (_,cs) <- readIORef (svLearntDB solver) - - xs <- forM cs $ \c -> do - p <- constrIsProtected solver c - w <- constrWeight solver c - actval <- constrReadActivity c - return (c, (p, w*actval)) - - -- Note that False <= True - let ys = sortBy (comparing snd) xs - (zs,ws) = splitAt (length ys `div` 2) ys - - let loop [] ret = return ret - loop ((c,(isShort,_)) : rest) ret = do - flag <- if isShort - then return True - else isLocked solver c - if flag - then loop rest (c:ret) - else do - detach solver c - loop rest ret - zs2 <- loop zs [] - - let cs2 = zs2 ++ map fst ws - n2 = length cs2 - - -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2 - writeIORef (svLearntDB solver) (n2,cs2) - -type VarActivity = Double - -varActivity :: Solver -> Var -> IO VarActivity -varActivity solver !v = do - vd <- varData solver v - readIORef (vdActivity vd) - -varDecayActivity :: Solver -> IO () -varDecayActivity solver = do - d <- readIORef (svVarDecay solver) - modifyIORef' (svVarInc solver) (d*) - -varBumpActivity :: Solver -> Var -> IO () -varBumpActivity solver !v = do - inc <- readIORef (svVarInc solver) - vd <- varData solver v - modifyIORef' (vdActivity vd) (+inc) - PQ.update (svVarQueue solver) v - aval <- readIORef (vdActivity vd) - when (aval > 1e20) $ - -- Rescale - varRescaleAllActivity solver - -varRescaleAllActivity :: Solver -> IO () -varRescaleAllActivity solver = do - vs <- variables solver - forM_ vs $ \v -> do - vd <- varData solver v - modifyIORef' (vdActivity vd) (* 1e-20) - modifyIORef' (svVarInc solver) (* 1e-20) - -variables :: Solver -> IO [Var] -variables solver = do - n <- nVars solver - return [1 .. n] - --- | number of variables of the problem. -nVars :: Solver -> IO Int -nVars solver = do - vcnt <- readIORef (svVarCounter solver) - return $! (vcnt-1) - --- | number of assigned variables. -nAssigns :: Solver -> IO Int -nAssigns solver = readIORef (svNAssigns solver) - --- | number of constraints. -nConstraints :: Solver -> IO Int -nConstraints solver = do - xs <- readIORef (svConstrDB solver) - return $ length xs - --- | number of learnt constrints. -nLearnt :: Solver -> IO Int -nLearnt solver = do - (n,_) <- readIORef (svLearntDB solver) - return n - -learntConstraints :: Solver -> IO [SomeConstraintHandler] -learntConstraints solver = do - (_,cs) <- readIORef (svLearntDB solver) - return cs - -{-------------------------------------------------------------------- - Solver ---------------------------------------------------------------------} - --- | Create a new Solver instance. -newSolver :: IO Solver -newSolver = do - rec - ok <- newIORef True - vcnt <- newIORef 1 - trail <- newIORef [] - vars <- newIORef =<< newArray_ (1,0) - vqueue <- PQ.newPriorityQueueBy (ltVar solver) - db <- newIORef [] - db2 <- newIORef (0,[]) - as <- newIORef =<< newArray_ (0,-1) - lv <- newIORef levelRoot - q <- SQ.newFifo - m <- newIORef Nothing - ndecision <- newIORef 0 - nranddec <- newIORef 0 - nconflict <- newIORef 0 - nrestart <- newIORef 0 - nassigns <- newIORef 0 - nfixed <- newIORef 0 - nlearntgc <- newIORef 0 - nremoved <- newIORef 0 - - constrDecay <- newIORef (1 / 0.999) - constrInc <- newIORef 1 - varDecay <- newIORef (1 / 0.95) - varInc <- newIORef 1 - restartStrat <- newIORef defaultRestartStrategy - restartFirst <- newIORef defaultRestartFirst - restartInc <- newIORef defaultRestartInc - learning <- newIORef defaultLearningStrategy - learntSizeFirst <- newIORef defaultLearntSizeFirst - learntSizeInc <- newIORef defaultLearntSizeInc - ccMin <- newIORef defaultCCMin - checkModel <- newIORef False - pbHandlerType <- newIORef defaultPBHandlerType - enablePhaseSaving <- newIORef defaultEnablePhaseSaving - enableForwardSubsumptionRemoval <- newIORef defaultEnableForwardSubsumptionRemoval - enableBackwardSubsumptionRemoval <- newIORef defaultEnableBackwardSubsumptionRemoval - - learntLim <- newIORef undefined - learntLimAdjCnt <- newIORef (-1) - learntLimSeq <- newIORef undefined - - logger <- newIORef Nothing - startWC <- newIORef undefined - lastStatWC <- newIORef undefined - - randfreq <- newIORef defaultRandomFreq - randgen <- newIORef =<< Rand.newStdGen - - failed <- newIORef [] - - confBudget <- newIORef (-1) - - let solver = - Solver - { svOk = ok - , svVarCounter = vcnt - , svVarQueue = vqueue - , svTrail = trail - , svVarData = vars - , svConstrDB = db - , svLearntDB = db2 - , svAssumptions = as - , svLevel = lv - , svBCPQueue = q - , svModel = m - , svNDecision = ndecision - , svNRandomDecision = nranddec - , svNConflict = nconflict - , svNRestart = nrestart - , svNAssigns = nassigns - , svNFixed = nfixed - , svNLearntGC = nlearntgc - , svNRemovedConstr = nremoved - , svVarDecay = varDecay - , svVarInc = varInc - , svConstrDecay = constrDecay - , svConstrInc = constrInc - , svRestartStrategy = restartStrat - , svRestartFirst = restartFirst - , svRestartInc = restartInc - , svLearningStrategy = learning - , svLearntSizeFirst = learntSizeFirst - , svLearntSizeInc = learntSizeInc - , svCCMin = ccMin - , svEnablePhaseSaving = enablePhaseSaving - , svEnableForwardSubsumptionRemoval = enableForwardSubsumptionRemoval - , svPBHandlerType = pbHandlerType - , svEnableBackwardSubsumptionRemoval = enableBackwardSubsumptionRemoval - , svLearntLim = learntLim - , svLearntLimAdjCnt = learntLimAdjCnt - , svLearntLimSeq = learntLimSeq - , svLogger = logger - , svStartWC = startWC - , svLastStatWC = lastStatWC - , svCheckModel = checkModel - , svRandomFreq = randfreq - , svRandomGen = randgen - , svFailedAssumptions = failed - , svConfBudget = confBudget - } - return solver - -ltVar :: Solver -> Var -> Var -> IO Bool -ltVar solver v1 v2 = do - a1 <- varActivity solver v1 - a2 <- varActivity solver v2 - return $! a1 > a2 - -{-------------------------------------------------------------------- - Problem specification ---------------------------------------------------------------------} - --- |Add a new variable -newVar :: Solver -> IO Var -newVar solver = do - v <- readIORef (svVarCounter solver) - writeIORef (svVarCounter solver) (v+1) - vd <- newVarData - - a <- readIORef (svVarData solver) - (_,ub) <- getBounds a - if v <= ub - then writeArray a v vd - else do - let ub' = max 2 (ub * 3 `div` 2) - a' <- newArray_ (1,ub') - forLoop 1 (<=ub) (+1) $ \v2 -> do - vd2 <- readArray a v2 - writeArray a' v2 vd2 - writeArray a' v vd - writeIORef (svVarData solver) a' - - PQ.enqueue (svVarQueue solver) v - return v - --- |Add variables. @newVars solver n = replicateM n (newVar solver)@ -newVars :: Solver -> Int -> IO [Var] -newVars solver n = do - nv <- nVars solver - resizeVarCapacity solver (nv+n) - replicateM n (newVar solver) - --- |Add variables. @newVars_ solver n = newVars solver n >> return ()@ -newVars_ :: Solver -> Int -> IO () -newVars_ solver n = do - nv <- nVars solver - resizeVarCapacity solver (nv+n) - replicateM_ n (newVar solver) - --- |Pre-allocate internal buffer for @n@ variables. -resizeVarCapacity :: Solver -> Int -> IO () -resizeVarCapacity solver n = do - PQ.resizeHeapCapacity (svVarQueue solver) n - PQ.resizeTableCapacity (svVarQueue solver) (n+1) - a <- readIORef (svVarData solver) - (_,ub) <- getBounds a - when (ub < n) $ do - a' <- newArray_ (1,n) - forLoop 1 (<=ub) (+1) $ \v -> do - vd <- readArray a v - writeArray a' v vd - writeIORef (svVarData solver) a' - --- |Add a clause to the solver. -addClause :: Solver -> Clause -> IO () -addClause solver lits = do - d <- readIORef (svLevel solver) - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - lits2 <- instantiateClause solver lits - case normalizeClause =<< lits2 of - Nothing -> return () - Just [] -> markBad solver - Just [lit] -> do - {- We do not call 'removeBackwardSubsumedBy' here, - because subsumed constraints will be removed by 'simplify'. -} - ret <- assign solver lit - assert ret $ return () - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - Just lits3 -> do - subsumed <- checkForwardSubsumption solver lits - unless subsumed $ do - removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits3], 1) - clause <- newClauseHandler lits3 False - addToDB solver clause - _ <- basicAttachClauseHandler solver clause - return () - --- | Add a cardinality constraints /atleast({l1,l2,..},n)/. -addAtLeast :: Solver -- ^ The 'Solver' argument. - -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) - -> Int -- ^ /n/. - -> IO () -addAtLeast solver lits n = do - d <- readIORef (svLevel solver) - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - (lits',n') <- liftM normalizeAtLeast $ instantiateAtLeast solver (lits,n) - let len = length lits' - - if n' <= 0 then return () - else if n' > len then markBad solver - else if n' == 1 then addClause solver lits' - else if n' == len then do - {- We do not call 'removeBackwardSubsumedBy' here, - because subsumed constraints will be removed by 'simplify'. -} - forM_ lits' $ \l -> do - ret <- assign solver l - assert ret $ return () - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - else do - removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits'], fromIntegral n') - c <- newAtLeastHandler lits' n' False - addToDB solver c - _ <- basicAttachAtLeastHandler solver c - return () - --- | Add a cardinality constraints /atmost({l1,l2,..},n)/. -addAtMost :: Solver -- ^ The 'Solver' argument - -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) - -> Int -- ^ /n/ - -> IO () -addAtMost solver lits n = addAtLeast solver lits' (len-n) - where - len = length lits - lits' = map litNot lits - --- | Add a cardinality constraints /exactly({l1,l2,..},n)/. -addExactly :: Solver -- ^ The 'Solver' argument - -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) - -> Int -- ^ /n/ - -> IO () -addExactly solver lits n = do - addAtLeast solver lits n - addAtMost solver lits n - --- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … ≥ n/. -addPBAtLeast :: Solver -- ^ The 'Solver' argument. - -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBAtLeast solver ts n = do - d <- readIORef (svLevel solver) - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - (ts',degree) <- liftM normalizePBLinAtLeast $ instantiatePB solver (ts,n) - - case pbToAtLeast (ts',degree) of - Just (lhs',rhs') -> addAtLeast solver lhs' rhs' - Nothing -> do - let cs = map fst ts' - slack = sum cs - degree - if degree <= 0 then return () - else if slack < 0 then markBad solver - else do - removeBackwardSubsumedBy solver (ts', degree) - c <- newPBHandler solver ts' degree False - addToDB solver c - ret <- attach solver c - if not ret - then do - markBad solver - else do - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - --- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … ≤ n/. -addPBAtMost :: Solver -- ^ The 'Solver' argument. - -> [(Integer,Lit)] -- ^ list of @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBAtMost solver ts n = addPBAtLeast solver [(-c,l) | (c,l) <- ts] (negate n) - --- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … = n/. -addPBExactly :: Solver -- ^ The 'Solver' argument. - -> [(Integer,Lit)] -- ^ list of terms @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBExactly solver ts n = do - (ts2,n2) <- liftM normalizePBLinExactly $ instantiatePB solver (ts,n) - addPBAtLeast solver ts2 n2 - addPBAtMost solver ts2 n2 - --- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … ≥ n/. -addPBAtLeastSoft - :: Solver -- ^ The 'Solver' argument. - -> Lit -- ^ indicator @lit@ - -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBAtLeastSoft solver sel lhs rhs = do - (lhs', rhs') <- liftM normalizePBLinAtLeast $ instantiatePB solver (lhs,rhs) - addPBAtLeast solver ((rhs', litNot sel) : lhs') rhs' - --- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … ≤ n/. -addPBAtMostSoft - :: Solver -- ^ The 'Solver' argument. - -> Lit -- ^ indicator @lit@ - -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBAtMostSoft solver sel lhs rhs = - addPBAtLeastSoft solver sel [(negate c, lit) | (c,lit) <- lhs] (negate rhs) - --- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … = n/. -addPBExactlySoft - :: Solver -- ^ The 'Solver' argument. - -> Lit -- ^ indicator @lit@ - -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ - -> Integer -- ^ /n/ - -> IO () -addPBExactlySoft solver sel lhs rhs = do - (lhs2, rhs2) <- liftM normalizePBLinExactly $ instantiatePB solver (lhs,rhs) - addPBAtLeastSoft solver sel lhs2 rhs2 - addPBAtMostSoft solver sel lhs2 rhs2 - -{-------------------------------------------------------------------- - Problem solving ---------------------------------------------------------------------} - --- | Solve constraints. --- Returns 'True' if the problem is SATISFIABLE. --- Returns 'False' if the problem is UNSATISFIABLE. -solve :: Solver -> IO Bool -solve solver = do - as <- newArray_ (0,-1) - writeIORef (svAssumptions solver) as - solve_ solver - --- | Solve constraints under assuptions. --- Returns 'True' if the problem is SATISFIABLE. --- Returns 'False' if the problem is UNSATISFIABLE. -solveWith :: Solver - -> [Lit] -- ^ Assumptions - -> IO Bool -solveWith solver ls = do - as <- newListArray (0, length ls -1) ls - writeIORef (svAssumptions solver) as - solve_ solver - -solve_ :: Solver -> IO Bool -solve_ solver = do - log solver "Solving starts ..." - resetStat solver - writeIORef (svModel solver) Nothing - writeIORef (svFailedAssumptions solver) [] - - ok <- readIORef (svOk solver) - if not ok - then return False - else do - when debugMode $ dumpVarActivity solver - d <- readIORef (svLevel solver) - assert (d == levelRoot) $ return () - - restartStrategy <- readIORef (svRestartStrategy solver) - restartFirst <- readIORef (svRestartFirst solver) - restartInc <- readIORef (svRestartInc solver) - let restartSeq = mkRestartSeq restartStrategy restartFirst restartInc - - let learntSizeAdj = do - (size,adj) <- shift (svLearntLimSeq solver) - writeIORef (svLearntLim solver) size - writeIORef (svLearntLimAdjCnt solver) adj - onConflict = do - cnt <- readIORef (svLearntLimAdjCnt solver) - if (cnt==0) - then learntSizeAdj - else writeIORef (svLearntLimAdjCnt solver) $! cnt-1 - - cnt <- readIORef (svLearntLimAdjCnt solver) - when (cnt == -1) $ do - learntSizeFirst <- readIORef (svLearntSizeFirst solver) - learntSizeInc <- readIORef (svLearntSizeInc solver) - nc <- nConstraints solver - nv <- nVars solver - let initialLearntLim = if learntSizeFirst > 0 then learntSizeFirst else max ((nc + nv) `div` 3) 16 - learntSizeSeq = iterate (ceiling . (learntSizeInc*) . fromIntegral) initialLearntLim - learntSizeAdjSeq = iterate (\x -> (x * 3) `div` 2) (100::Int) - writeIORef (svLearntLimSeq solver) (zip learntSizeSeq learntSizeAdjSeq) - learntSizeAdj - - let loop [] = error "solve_: should not happen" - loop (conflict_lim:rs) = do - printStat solver True - ret <- search solver conflict_lim onConflict - case ret of - SRFinished x -> return $ Just x - SRBudgetExceeded -> return Nothing - SRRestart -> do - modifyIORef' (svNRestart solver) (+1) - backtrackTo solver levelRoot - loop rs - - printStatHeader solver - - startCPU <- getCPUTime - startWC <- getCurrentTime - writeIORef (svStartWC solver) startWC - result <- loop restartSeq - endCPU <- getCPUTime - endWC <- getCurrentTime - - when (result == Just True) $ do - checkModel <- readIORef (svCheckModel solver) - when checkModel $ checkSatisfied solver - constructModel solver - - backtrackTo solver levelRoot - - when debugMode $ dumpVarActivity solver - when debugMode $ dumpConstrActivity solver - printStat solver True - (log solver . printf "#cpu_time = %.3fs") (fromIntegral (endCPU - startCPU) / 10^(12::Int) :: Double) - (log solver . printf "#wall_clock_time = %.3fs") (realToFrac (endWC `diffUTCTime` startWC) :: Double) - (log solver . printf "#decision = %d") =<< readIORef (svNDecision solver) - (log solver . printf "#random_decision = %d") =<< readIORef (svNRandomDecision solver) - (log solver . printf "#conflict = %d") =<< readIORef (svNConflict solver) - (log solver . printf "#restart = %d") =<< readIORef (svNRestart solver) - - case result of - Just x -> return x - Nothing -> throw BudgetExceeded - -data BudgetExceeded = BudgetExceeded - deriving (Show, Typeable) - -instance Exception BudgetExceeded - -data SearchResult - = SRFinished Bool - | SRRestart - | SRBudgetExceeded - -search :: Solver -> Int -> IO () -> IO SearchResult -search solver !conflict_lim onConflict = do - conflictCounter <- newIORef 0 - let - loop :: IO SearchResult - loop = do - sanityCheck solver - conflict <- deduce solver - sanityCheck solver - case conflict of - Just constr -> do - ret <- handleConflict conflictCounter constr - case ret of - Just sr -> return sr - Nothing -> loop - Nothing -> do - lv <- readIORef (svLevel solver) - when (lv == levelRoot) $ simplify solver - checkGC - r <- pickAssumption - case r of - Nothing -> return (SRFinished False) - Just lit - | lit /= litUndef -> decide solver lit >> loop - | otherwise -> do - lit2 <- pickBranchLit solver - if lit2 == litUndef - then return (SRFinished True) - else decide solver lit2 >> loop - loop - - where - checkGC :: IO () - checkGC = do - n <- nLearnt solver - m <- nAssigns solver - learnt_lim <- readIORef (svLearntLim solver) - when (learnt_lim >= 0 && n - m > learnt_lim) $ do - modifyIORef' (svNLearntGC solver) (+1) - reduceDB solver - - pickAssumption :: IO (Maybe Lit) - pickAssumption = do - !as <- readIORef (svAssumptions solver) - !b <- getBounds as - let go = do - d <- readIORef (svLevel solver) - if not (inRange b (d+1)) - then return (Just litUndef) - else do - l <- readArray as (d+1) - val <- litValue solver l - if val == lTrue then do - -- dummy decision level - modifyIORef' (svLevel solver) (+1) - go - else if val == lFalse then do - -- conflict with assumption - core <- analyzeFinal solver l - writeIORef (svFailedAssumptions solver) core - return Nothing - else - return (Just l) - go - - handleConflict :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) - handleConflict conflictCounter constr = do - varDecayActivity solver - constrDecayActivity solver - onConflict - - modifyIORef' (svNConflict solver) (+1) - d <- readIORef (svLevel solver) - - when debugMode $ logIO solver $ do - str <- showConstraintHandler solver constr - return $ printf "conflict(level=%d): %s" d str - - modifyIORef' conflictCounter (+1) - c <- readIORef conflictCounter - - modifyIORef' (svConfBudget solver) $ \confBudget -> - if confBudget > 0 then confBudget - 1 else confBudget - confBudget <- readIORef (svConfBudget solver) - - when (c `mod` 100 == 0) $ do - printStat solver False - - if d == levelRoot then do - markBad solver - return $ Just (SRFinished False) - else if confBudget==0 then - return $ Just SRBudgetExceeded - else if conflict_lim >= 0 && c >= conflict_lim then - return $ Just SRRestart - else do - strat <- readIORef (svLearningStrategy solver) - case strat of - LearningClause -> learnClause constr >> return Nothing - LearningHybrid -> learnHybrid conflictCounter constr - - learnClause :: SomeConstraintHandler -> IO () - learnClause constr = do - (learntClause, level) <- analyzeConflict solver constr - backtrackTo solver level - case learntClause of - [] -> error "search(LearningClause): should not happen" - [lit] -> do - ret <- assign solver lit - assert ret $ return () - return () - lit:_ -> do - cl <- newClauseHandler learntClause True - addToLearntDB solver cl - basicAttachClauseHandler solver cl - assignBy solver lit cl - constrBumpActivity solver cl - - learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) - learnHybrid conflictCounter constr = do - ((learntClause, clauseLevel), (pb, pbLevel)) <- analyzeConflictHybrid solver constr - let minLevel = min clauseLevel pbLevel - backtrackTo solver minLevel - - case learntClause of - [] -> error "search(LearningHybrid): should not happen" - [lit] -> do - _ <- assign solver lit -- This should always succeed. - return () - lit:_ -> do - cl <- newClauseHandler learntClause True - addToLearntDB solver cl - basicAttachClauseHandler solver cl - constrBumpActivity solver cl - when (minLevel == clauseLevel) $ do - _ <- assignBy solver lit cl -- This should always succeed. - return () - - ret <- deduce solver - case ret of - Just conflicted -> do - handleConflict conflictCounter conflicted - -- TODO: should also learn the PB constraint? - Nothing -> do - let (lhs,rhs) = pb - h <- newPBHandlerPromoted solver lhs rhs True - case h of - CHClause _ -> do - {- We don't want to add additional clause, - since it would be subsumed by already added one. -} - return Nothing - _ -> do - addToLearntDB solver h - ret2 <- attach solver h - constrBumpActivity solver h - if ret2 then - return Nothing - else - handleConflict conflictCounter h - --- | After 'solve' returns True, it returns the model. -model :: Solver -> IO Model -model solver = do - m <- readIORef (svModel solver) - return (fromJust m) - --- | After 'solveWith' returns False, it returns a set of assumptions --- that leads to contradiction. In particular, if it returns an empty --- set, the problem is unsatisiable without any assumptions. -failedAssumptions :: Solver -> IO [Lit] -failedAssumptions solver = readIORef (svFailedAssumptions solver) - -{-------------------------------------------------------------------- - Simplification ---------------------------------------------------------------------} - --- | Simplify the constraint database according to the current top-level assigment. -simplify :: Solver -> IO () -simplify solver = do - let loop [] rs !n = return (rs,n) - loop (y:ys) rs !n = do - b1 <- isSatisfied solver y - b2 <- isLocked solver y - if b1 && not b2 - then do - detach solver y - loop ys rs (n+1) - else loop ys (y:rs) n - - -- simplify original constraint DB - do - xs <- readIORef (svConstrDB solver) - (ys,n) <- loop xs [] (0::Int) - modifyIORef' (svNRemovedConstr solver) (+n) - writeIORef (svConstrDB solver) ys - - -- simplify learnt constraint DB - do - (m,xs) <- readIORef (svLearntDB solver) - (ys,n) <- loop xs [] (0::Int) - writeIORef (svLearntDB solver) (m-n, ys) - -{- -References: -L. Zhang, "On subsumption removal and On-the-Fly CNF simplification," -Theory and Applications of Satisfiability Testing (2005), pp. 482-489. --} - -checkForwardSubsumption :: Solver -> Clause -> IO Bool -checkForwardSubsumption solver lits = do - flag <- getEnableForwardSubsumptionRemoval solver - if not flag then - return False - else do - withEnablePhaseSaving solver False $ do - bracket_ - (modifyIORef' (svLevel solver) (+1)) - (backtrackTo solver levelRoot) $ do - b <- allM (\lit -> assign solver (litNot lit)) lits - if b then - liftM isJust (deduce solver) - else do - when debugMode $ log solver ("forward subsumption: " ++ show lits) - return True - where - withEnablePhaseSaving solver flag m = - bracket - (getEnablePhaseSaving solver) - (setEnablePhaseSaving solver) - (\_ -> setEnablePhaseSaving solver flag >> m) - -removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO () -removeBackwardSubsumedBy solver pb = do - flag <- getEnableBackwardSubsumptionRemoval solver - when flag $ do - xs <- backwardSubsumedBy solver pb - when debugMode $ do - forM_ (HashSet.toList xs) $ \c -> do - s <- showConstraintHandler solver c - log solver (printf "backward subsumption: %s is subsumed by %s\n" s (show pb)) - removeConstraintHandlers solver xs - -backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler) -backwardSubsumedBy solver pb@(lhs,_) = do - xs <- forM lhs $ \(_,lit) -> do - ld <- litData solver lit - readIORef (ldOccurList ld) - case xs of - [] -> return HashSet.empty - s:ss -> do - let p c = do - pb2 <- instantiatePB solver =<< toPBAtLeast solver c - return $ pbSubsume pb pb2 - liftM HashSet.fromList - $ filterM p - $ HashSet.toList - $ foldl' HashSet.intersection s ss - -removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO () -removeConstraintHandlers _ zs | HashSet.null zs = return () -removeConstraintHandlers solver zs = do - let loop [] rs !n = return (rs,n) - loop (c:cs) rs !n = do - if c `HashSet.member` zs - then do - detach solver c - loop cs rs (n+1) - else loop cs (c:rs) n - xs <- readIORef (svConstrDB solver) - (ys,n) <- loop xs [] (0::Int) - modifyIORef' (svNRemovedConstr solver) (+n) - writeIORef (svConstrDB solver) ys - -{-------------------------------------------------------------------- - Parameter settings. ---------------------------------------------------------------------} - -setRestartStrategy :: Solver -> RestartStrategy -> IO () -setRestartStrategy solver s = writeIORef (svRestartStrategy solver) s - --- | default value for @RestartStrategy@. -defaultRestartStrategy :: RestartStrategy -defaultRestartStrategy = MiniSATRestarts - --- | The initial restart limit. (default 100) --- Negative value is used to disable restart. -setRestartFirst :: Solver -> Int -> IO () -setRestartFirst solver !n = writeIORef (svRestartFirst solver) n - --- | default value for @RestartFirst@. -defaultRestartFirst :: Int -defaultRestartFirst = 100 - --- | The factor with which the restart limit is multiplied in each restart. (default 1.5) -setRestartInc :: Solver -> Double -> IO () -setRestartInc solver !r = writeIORef (svRestartInc solver) r - --- | default value for @RestartInc@. -defaultRestartInc :: Double -defaultRestartInc = 1.5 - -data LearningStrategy - = LearningClause - | LearningHybrid - -setLearningStrategy :: Solver -> LearningStrategy -> IO () -setLearningStrategy solver l = writeIORef (svLearningStrategy solver) $! l - -defaultLearningStrategy :: LearningStrategy -defaultLearningStrategy = LearningClause - --- | The initial limit for learnt clauses. -setLearntSizeFirst :: Solver -> Int -> IO () -setLearntSizeFirst solver !x = writeIORef (svLearntSizeFirst solver) x - --- | default value for @LearntSizeFirst@. -defaultLearntSizeFirst :: Int -defaultLearntSizeFirst = -1 - --- | The limit for learnt clauses is multiplied with this factor each restart. (default 1.1) -setLearntSizeInc :: Solver -> Double -> IO () -setLearntSizeInc solver !r = writeIORef (svLearntSizeInc solver) r - --- | default value for @LearntSizeInc@. -defaultLearntSizeInc :: Double -defaultLearntSizeInc = 1.1 - --- | The limit for learnt clauses is multiplied with this factor each restart. (default 1.1) -setCCMin :: Solver -> Int -> IO () -setCCMin solver !v = writeIORef (svCCMin solver) v - --- | default value for @CCMin@. -defaultCCMin :: Int -defaultCCMin = 2 - --- | The default polarity of a variable. -setVarPolarity :: Solver -> Var -> Bool -> IO () -setVarPolarity solver v val = do - vd <- varData solver v - writeIORef (vdPolarity vd) val - -setCheckModel :: Solver -> Bool -> IO () -setCheckModel solver flag = do - writeIORef (svCheckModel solver) flag - --- | The frequency with which the decision heuristic tries to choose a random variable -setRandomFreq :: Solver -> Double -> IO () -setRandomFreq solver r = do - writeIORef (svRandomFreq solver) r - -defaultRandomFreq :: Double -defaultRandomFreq = 0.005 - --- | Set random generator used by the random variable selection -setRandomGen :: Solver -> Rand.StdGen -> IO () -setRandomGen solver = writeIORef (svRandomGen solver) - --- | Get random generator used by the random variable selection -getRandomGen :: Solver -> IO Rand.StdGen -getRandomGen solver = readIORef (svRandomGen solver) - -setConfBudget :: Solver -> Maybe Int -> IO () -setConfBudget solver (Just b) | b >= 0 = writeIORef (svConfBudget solver) b -setConfBudget solver _ = writeIORef (svConfBudget solver) (-1) - -data PBHandlerType = PBHandlerTypeCounter | PBHandlerTypePueblo - deriving (Show, Eq, Ord) - -defaultPBHandlerType :: PBHandlerType -defaultPBHandlerType = PBHandlerTypeCounter - -setPBHandlerType :: Solver -> PBHandlerType -> IO () -setPBHandlerType solver ht = do - writeIORef (svPBHandlerType solver) ht - -setEnablePhaseSaving :: Solver -> Bool -> IO () -setEnablePhaseSaving solver flag = do - writeIORef (svEnablePhaseSaving solver) flag - -getEnablePhaseSaving :: Solver -> IO Bool -getEnablePhaseSaving solver = do - readIORef (svEnablePhaseSaving solver) - -defaultEnablePhaseSaving :: Bool -defaultEnablePhaseSaving = True - -setEnableForwardSubsumptionRemoval :: Solver -> Bool -> IO () -setEnableForwardSubsumptionRemoval solver flag = do - writeIORef (svEnableForwardSubsumptionRemoval solver) flag - -getEnableForwardSubsumptionRemoval :: Solver -> IO Bool -getEnableForwardSubsumptionRemoval solver = do - readIORef (svEnableForwardSubsumptionRemoval solver) - -defaultEnableForwardSubsumptionRemoval :: Bool -defaultEnableForwardSubsumptionRemoval = False - -setEnableBackwardSubsumptionRemoval :: Solver -> Bool -> IO () -setEnableBackwardSubsumptionRemoval solver flag = do - writeIORef (svEnableBackwardSubsumptionRemoval solver) flag - -getEnableBackwardSubsumptionRemoval :: Solver -> IO Bool -getEnableBackwardSubsumptionRemoval solver = do - readIORef (svEnableBackwardSubsumptionRemoval solver) - -defaultEnableBackwardSubsumptionRemoval :: Bool -defaultEnableBackwardSubsumptionRemoval = False - -{-------------------------------------------------------------------- - API for implementation of @solve@ ---------------------------------------------------------------------} - -pickBranchLit :: Solver -> IO Lit -pickBranchLit !solver = do - let vqueue = svVarQueue solver - - -- Random decision - let withRandGen :: (Rand.StdGen -> (a, Rand.StdGen)) -> IO a - withRandGen f = do - randgen <- readIORef (svRandomGen solver) - let (r, randgen') = f randgen - writeIORef (svRandomGen solver) randgen' - return r - !randfreq <- readIORef (svRandomFreq solver) - !size <- PQ.queueSize vqueue - !r <- withRandGen Rand.random - var <- - if (r < randfreq && size >= 2) - then do - a <- PQ.getHeapArray vqueue - i <- withRandGen $ Rand.randomR (0, size-1) - var <- readArray a i - val <- varValue solver var - if val == lUndef - then do - modifyIORef' (svNRandomDecision solver) (1+) - return var - else return litUndef - else - return litUndef - - -- Activity based decision - let loop :: IO Var - loop = do - m <- PQ.dequeue vqueue - case m of - Nothing -> return litUndef - Just var2 -> do - val2 <- varValue solver var2 - if val2 /= lUndef - then loop - else return var2 - var2 <- - if var==litUndef - then loop - else return var - - if var2==litUndef - then return litUndef - else do - vd <- varData solver var2 - -- TODO: random polarity - p <- readIORef (vdPolarity vd) - return $! literal var2 p - -decide :: Solver -> Lit -> IO () -decide solver !lit = do - modifyIORef' (svNDecision solver) (+1) - modifyIORef' (svLevel solver) (+1) - when debugMode $ do - val <- litValue solver lit - when (val /= lUndef) $ error "decide: should not happen" - assign solver lit - return () - -deduce :: Solver -> IO (Maybe SomeConstraintHandler) -deduce solver = loop - where - loop :: IO (Maybe SomeConstraintHandler) - loop = do - r <- bcpDequeue solver - case r of - Nothing -> return Nothing - Just lit -> do - ret <- processLit lit - case ret of - Just _ -> return ret - Nothing -> loop - - processLit :: Lit -> IO (Maybe SomeConstraintHandler) - processLit !lit = do - let falsifiedLit = litNot lit - ld <- litData solver falsifiedLit - let wsref = ldWatches ld - let loop2 [] = return Nothing - loop2 (w:ws) = do - ok <- propagate solver w falsifiedLit - if ok - then loop2 ws - else do - modifyIORef wsref (++ws) - return (Just w) - ws <- readIORef wsref - writeIORef wsref [] - loop2 ws - -analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level) -analyzeConflict solver constr = do - d <- readIORef (svLevel solver) - - let split :: [Lit] -> IO (LitSet, LitSet) - split = go (IS.empty, IS.empty) - where - go (xs,ys) [] = return (xs,ys) - go (xs,ys) (l:ls) = do - lv <- litLevel solver l - if lv == levelRoot then - go (xs,ys) ls - else if lv >= d then - go (IS.insert l xs, ys) ls - else - go (xs, IS.insert l ys) ls - - let loop :: LitSet -> LitSet -> IO LitSet - loop lits1 lits2 - | sz==1 = do - return $ lits1 `IS.union` lits2 - | sz>=2 = do - ret <- popTrail solver - case ret of - Nothing -> do - error $ printf "analyzeConflict: should not happen: empty trail: loop %s %s" - (show lits1) (show lits2) - Just l -> do - if litNot l `IS.notMember` lits1 - then do - unassign solver (litVar l) - loop lits1 lits2 - else do - m <- varReason solver (litVar l) - case m of - Nothing -> error "analyzeConflict: should not happen" - Just constr2 -> do - constrBumpActivity solver constr2 - xs <- reasonOf solver constr2 (Just l) - forM_ xs $ \lit -> varBumpActivity solver (litVar lit) - unassign solver (litVar l) - (ys,zs) <- split xs - loop (IS.delete (litNot l) lits1 `IS.union` ys) - (lits2 `IS.union` zs) - | otherwise = error "analyzeConflict: should not happen: reason of current level is empty" - where - sz = IS.size lits1 - - constrBumpActivity solver constr - conflictClause <- reasonOf solver constr Nothing - forM_ conflictClause $ \lit -> varBumpActivity solver (litVar lit) - (ys,zs) <- split conflictClause - lits <- loop ys zs - - lits2 <- minimizeConflictClause solver lits - - xs <- liftM (sortBy (flip (comparing snd))) $ - forM (IS.toList lits2) $ \l -> do - lv <- litLevel solver l - return (l,lv) - - let level = case xs of - [] -> error "analyzeConflict: should not happen" - [_] -> levelRoot - _:(_,lv):_ -> lv - return (map fst xs, level) - --- { p } ∪ { pにfalseを割り当てる原因のassumption } -analyzeFinal :: Solver -> Lit -> IO [Lit] -analyzeFinal solver p = do - lits <- readIORef (svTrail solver) - let go :: [Lit] -> VarSet -> [Lit] -> IO [Lit] - go [] _ result = return result - go (l:ls) seen result = do - lv <- litLevel solver l - if lv == levelRoot then - return result - else if litVar l `IS.member` seen then do - r <- varReason solver (litVar l) - case r of - Nothing -> do - let seen' = IS.delete (litVar l) seen - go ls seen' (l : result) - Just constr -> do - c <- reasonOf solver constr (Just l) - let seen' = IS.delete (litVar l) seen `IS.union` IS.fromList [litVar l2 | l2 <- c] - go ls seen' result - else - go ls seen result - go lits (IS.singleton (litVar p)) [p] - -analyzeConflictHybrid :: ConstraintHandler c => Solver -> c -> IO ((Clause, Level), (PBLinAtLeast, Level)) -analyzeConflictHybrid solver constr = do - d <- readIORef (svLevel solver) - - let split :: [Lit] -> IO (LitSet, LitSet) - split = go (IS.empty, IS.empty) - where - go (xs,ys) [] = return (xs,ys) - go (xs,ys) (l:ls) = do - lv <- litLevel solver l - if lv == levelRoot then - go (xs,ys) ls - else if lv >= d then - go (IS.insert l xs, ys) ls - else - go (xs, IS.insert l ys) ls - - let loop :: LitSet -> LitSet -> PBLinAtLeast -> IO (LitSet, PBLinAtLeast) - loop lits1 lits2 pb - | sz==1 = do - return $ (lits1 `IS.union` lits2, pb) - | sz>=2 = do - ret <- popTrail solver - case ret of - Nothing -> do - error $ printf "analyzeConflictHybrid: should not happen: empty trail: loop %s %s" - (show lits1) (show lits2) - Just l -> do - m <- varReason solver (litVar l) - case m of - Nothing -> error "analyzeConflictHybrid: should not happen" - Just constr2 -> do - xs <- reasonOf solver constr2 (Just l) - (lits1',lits2') <- - if litNot l `IS.notMember` lits1 - then return (lits1,lits2) - else do - constrBumpActivity solver constr2 - forM_ xs $ \lit -> varBumpActivity solver (litVar lit) - (ys,zs) <- split xs - return (IS.delete (litNot l) lits1 `IS.union` ys, lits2 `IS.union` zs) - - pb' <- if any (\(_,l2) -> litNot l == l2) (fst pb) - then do - pb2 <- toPBAtLeast solver constr2 - o <- pbOverSAT solver pb2 - let pb3 = if o then ([(1,l2) | l2 <- l:xs],1) else pb2 - return $ cutResolve pb pb3 (litVar l) - else return pb - - unassign solver (litVar l) - loop lits1' lits2' pb' - - | otherwise = error "analyzeConflictHybrid: should not happen: reason of current level is empty" - where - sz = IS.size lits1 - - constrBumpActivity solver constr - conflictClause <- reasonOf solver constr Nothing - pbConfl <- toPBAtLeast solver constr - forM_ conflictClause $ \lit -> varBumpActivity solver (litVar lit) - (ys,zs) <- split conflictClause - (lits, pb) <- loop ys zs pbConfl - - lits2 <- minimizeConflictClause solver lits - - xs <- liftM (sortBy (flip (comparing snd))) $ - forM (IS.toList lits2) $ \l -> do - lv <- litLevel solver l - return (l,lv) - - let level = case xs of - [] -> error "analyzeConflict: should not happen" - [_] -> levelRoot - _:(_,lv):_ -> lv - pblevel <- pbBacktrackLevel solver pb - return ((map fst xs, level), (pb, pblevel)) - -pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level -pbBacktrackLevel _ ([], rhs) = assert (rhs > 0) $ return levelRoot -pbBacktrackLevel solver (lhs, rhs) = do - levelToLiterals <- liftM (IM.unionsWith IM.union) $ forM lhs $ \(_,lit) -> do - val <- litValue solver lit - if val /= lUndef then do - level <- litLevel solver lit - return $ IM.singleton level (IM.singleton lit val) - else - return $ IM.empty - - let replay [] _ _ = error "pbBacktrackLevel: should not happen" - replay ((lv,lv_lits) : lvs) lhs slack = do - let slack_lv = slack - sum [c | (c,lit) <- lhs, IM.lookup lit lv_lits == Just lFalse] - lhs_lv = [tm | tm@(_,lit) <- lhs, IM.notMember lit lv_lits] - if slack_lv < 0 then - return lv -- CONFLICT - else if any (\(c,_) -> c > slack_lv) lhs_lv then - return lv -- UNIT - else - replay lvs lhs_lv slack_lv - - let initial_slack = sum [c | (c,_) <- lhs] - rhs - replay (IM.toList levelToLiterals) lhs initial_slack - -minimizeConflictClause :: Solver -> LitSet -> IO LitSet -minimizeConflictClause solver lits = do - ccmin <- readIORef (svCCMin solver) - if ccmin >= 2 then - minimizeConflictClauseRecursive solver lits - else if ccmin >= 1 then - minimizeConflictClauseLocal solver lits - else - return lits - -minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet -minimizeConflictClauseLocal solver lits = do - let xs = IS.toAscList lits - ys <- filterM (liftM not . isRedundant) xs - when debugMode $ do - log solver "minimizeConflictClauseLocal:" - log solver $ show xs - log solver $ show ys - return $ IS.fromAscList $ ys - - where - isRedundant :: Lit -> IO Bool - isRedundant lit = do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls <- reasonOf solver c2 (Just (litNot lit)) - allM test ls - - test :: Lit -> IO Bool - test lit = do - lv <- litLevel solver lit - return $ lv == levelRoot || lit `IS.member` lits - -minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet -minimizeConflictClauseRecursive solver lits = do - let - isRedundant :: Lit -> IO Bool - isRedundant lit = do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls <- reasonOf solver c2 (Just (litNot lit)) - go ls IS.empty - - go :: [Lit] -> IS.IntSet -> IO Bool - go [] _ = return True - go (lit : ls) seen = do - lv <- litLevel solver lit - if lv == levelRoot || lit `IS.member` lits || lit `IS.member` seen - then go ls seen - else do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls2 <- reasonOf solver c2 (Just (litNot lit)) - go (ls2 ++ ls) (IS.insert lit seen) - - let xs = IS.toAscList lits - ys <- filterM (liftM not . isRedundant) xs - when debugMode $ do - log solver "minimizeConflictClauseRecursive:" - log solver $ show xs - log solver $ show ys - return $ IS.fromAscList $ ys - -popTrail :: Solver -> IO (Maybe Lit) -popTrail solver = do - m <- readIORef (svTrail solver) - case m of - [] -> return Nothing - l:ls -> do - writeIORef (svTrail solver) ls - return $ Just l - --- | Revert to the state at given level --- (keeping all assignment at @level@ but not beyond). -backtrackTo :: Solver -> Int -> IO () -backtrackTo solver level = do - when debugMode $ log solver $ printf "backtrackTo: %d" level - writeIORef (svTrail solver) =<< loop =<< readIORef (svTrail solver) - SQ.clear (svBCPQueue solver) - writeIORef (svLevel solver) level - where - loop :: [Lit] -> IO [Lit] - loop [] = return [] - loop lls@(l:ls) = do - lv <- litLevel solver l - if lv <= level - then return lls - else unassign solver (litVar l) >> loop ls - -constructModel :: Solver -> IO () -constructModel solver = do - n <- nVars solver - (marr::IOUArray Var Bool) <- newArray_ (1,n) - forLoop 1 (<=n) (+1) $ \v -> do - vd <- varData solver v - a <- readIORef (vdAssignment vd) - writeArray marr v (aValue (fromJust a)) - m <- unsafeFreeze marr - writeIORef (svModel solver) (Just m) - -constrDecayActivity :: Solver -> IO () -constrDecayActivity solver = do - d <- readIORef (svConstrDecay solver) - modifyIORef' (svConstrInc solver) (d*) - -constrBumpActivity :: ConstraintHandler a => Solver -> a -> IO () -constrBumpActivity solver this = do - aval <- constrReadActivity this - when (aval >= 0) $ do -- learnt clause - inc <- readIORef (svConstrInc solver) - let aval2 = aval+inc - constrWriteActivity this $! aval2 - when (aval2 > 1e20) $ - -- Rescale - constrRescaleAllActivity solver - -constrRescaleAllActivity :: Solver -> IO () -constrRescaleAllActivity solver = do - xs <- learntConstraints solver - forM_ xs $ \c -> do - aval <- constrReadActivity c - when (aval >= 0) $ - constrWriteActivity c $! (aval * 1e-20) - modifyIORef' (svConstrInc solver) (* 1e-20) - -resetStat :: Solver -> IO () -resetStat solver = do - writeIORef (svNDecision solver) 0 - writeIORef (svNRandomDecision solver) 0 - writeIORef (svNConflict solver) 0 - writeIORef (svNRestart solver) 0 - writeIORef (svNLearntGC solver) 0 - -printStatHeader :: Solver -> IO () -printStatHeader solver = do - log solver $ "============================[ Search Statistics ]============================" - log solver $ " Time | Restart | Decision | Conflict | LEARNT | Fixed | Removed " - log solver $ " | | | | Limit GC | Var | Constra " - log solver $ "=============================================================================" - -printStat :: Solver -> Bool -> IO () -printStat solver force = do - nowWC <- getCurrentTime - b <- if force - then return True - else do - lastWC <- readIORef (svLastStatWC solver) - return $ (nowWC `diffUTCTime` lastWC) > 1 - when b $ do - startWC <- readIORef (svStartWC solver) - let tm = showTimeDiff $ nowWC `diffUTCTime` startWC - restart <- readIORef (svNRestart solver) - dec <- readIORef (svNDecision solver) - conflict <- readIORef (svNConflict solver) - learntLim <- readIORef (svLearntLim solver) - learntGC <- readIORef (svNLearntGC solver) - fixed <- readIORef (svNFixed solver) - removed <- readIORef (svNRemovedConstr solver) - log solver $ printf "%s | %7d | %8d | %8d | %8d %6d | %8d | %8d" - tm restart dec conflict learntLim learntGC fixed removed - writeIORef (svLastStatWC solver) nowWC - -showTimeDiff :: NominalDiffTime -> String -showTimeDiff sec - | si < 100 = printf "%4.1fs" (fromRational s :: Double) - | si <= 9999 = printf "%4ds" si - | mi < 100 = printf "%4.1fm" (fromRational m :: Double) - | mi <= 9999 = printf "%4dm" mi - | hi < 100 = printf "%4.1fs" (fromRational h :: Double) - | otherwise = printf "%4dh" hi - where - s :: Rational - s = realToFrac sec - - si :: Integer - si = round s - - m :: Rational - m = s / 60 - - mi :: Integer - mi = round m - - h :: Rational - h = m / 60 - - hi :: Integer - hi = round h - -{-------------------------------------------------------------------- - constraint implementation ---------------------------------------------------------------------} - -class (Eq a, Hashable a) => ConstraintHandler a where - toConstraintHandler :: a -> SomeConstraintHandler - - showConstraintHandler :: Solver -> a -> IO String - - attach :: Solver -> a -> IO Bool - - watchedLiterals :: Solver -> a -> IO [Lit] - - -- | invoked with the watched literal when the literal is falsified. - -- 'watch' で 'toConstraint' を呼び出して heap allocation が発生するのを - -- 避けるために、元の 'SomeConstraintHandler' も渡しておく。 - basicPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool - - -- | deduce a clause C∨l from the constraint and return C. - -- C and l should be false and true respectively under the current - -- assignment. - basicReasonOf :: Solver -> a -> Maybe Lit -> IO Clause - - toPBAtLeast :: Solver -> a -> IO PBLinAtLeast - - isSatisfied :: Solver -> a -> IO Bool - - constrIsProtected :: Solver -> a -> IO Bool - constrIsProtected _ _ = return False - - constrWeight :: Solver -> a -> IO Double - constrWeight _ _ = return 1.0 - - constrReadActivity :: a -> IO Double - - constrWriteActivity :: a -> Double -> IO () - -detach :: ConstraintHandler a => Solver -> a -> IO () -detach solver c = do - let c2 = toConstraintHandler c - lits <- watchedLiterals solver c - forM_ lits $ \lit -> do - ld <- litData solver lit - modifyIORef' (ldWatches ld) (delete c2) - (lhs,_) <- toPBAtLeast solver c - forM_ lhs $ \(_,lit) -> do - ld <- litData solver lit - modifyIORef' (ldOccurList ld) (HashSet.delete c2) - --- | invoked with the watched literal when the literal is falsified. -propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool -propagate solver c l = basicPropagate solver c c l - --- | deduce a clause C∨l from the constraint and return C. --- C and l should be false and true respectively under the current --- assignment. -reasonOf :: ConstraintHandler a => Solver -> a -> Maybe Lit -> IO Clause -reasonOf solver c x = do - when debugMode $ - case x of - Nothing -> return () - Just lit -> do - val <- litValue solver lit - unless (lTrue == val) $ do - str <- showConstraintHandler solver c - error (printf "reasonOf: value of literal %d should be True but %s (basicReasonOf %s %s)" lit (show val) str (show x)) - cl <- basicReasonOf solver c x - when debugMode $ do - forM_ cl $ \lit -> do - val <- litValue solver lit - unless (lFalse == val) $ do - str <- showConstraintHandler solver c - error (printf "reasonOf: value of literal %d should be False but %s (basicReasonOf %s %s)" lit (show val) str (show x)) - return cl - -isLocked :: Solver -> SomeConstraintHandler -> IO Bool -isLocked solver c = anyM p =<< watchedLiterals solver c - where - p :: Lit -> IO Bool - p lit = do - val <- litValue solver lit - if val /= lTrue - then return False - else do - m <- varReason solver (litVar lit) - case m of - Nothing -> return False - Just c2 -> return $! c == c2 - -data SomeConstraintHandler - = CHClause !ClauseHandler - | CHAtLeast !AtLeastHandler - | CHPBCounter !PBHandlerCounter - | CHPBPueblo !PBHandlerPueblo - deriving Eq - -instance Hashable SomeConstraintHandler where - hashWithSalt s (CHClause c) = s `hashWithSalt` (0::Int) `hashWithSalt` c - hashWithSalt s (CHAtLeast c) = s `hashWithSalt` (1::Int) `hashWithSalt` c - hashWithSalt s (CHPBCounter c) = s `hashWithSalt` (2::Int) `hashWithSalt` c - hashWithSalt s (CHPBPueblo c) = s `hashWithSalt` (3::Int) `hashWithSalt` c - -instance ConstraintHandler SomeConstraintHandler where - toConstraintHandler = id - - showConstraintHandler solver (CHClause c) = showConstraintHandler solver c - showConstraintHandler solver (CHAtLeast c) = showConstraintHandler solver c - showConstraintHandler solver (CHPBCounter c) = showConstraintHandler solver c - showConstraintHandler solver (CHPBPueblo c) = showConstraintHandler solver c - - attach solver (CHClause c) = attach solver c - attach solver (CHAtLeast c) = attach solver c - attach solver (CHPBCounter c) = attach solver c - attach solver (CHPBPueblo c) = attach solver c - - watchedLiterals solver (CHClause c) = watchedLiterals solver c - watchedLiterals solver (CHAtLeast c) = watchedLiterals solver c - watchedLiterals solver (CHPBCounter c) = watchedLiterals solver c - watchedLiterals solver (CHPBPueblo c) = watchedLiterals solver c - - basicPropagate solver this (CHClause c) lit = basicPropagate solver this c lit - basicPropagate solver this (CHAtLeast c) lit = basicPropagate solver this c lit - basicPropagate solver this (CHPBCounter c) lit = basicPropagate solver this c lit - basicPropagate solver this (CHPBPueblo c) lit = basicPropagate solver this c lit - - basicReasonOf solver (CHClause c) l = basicReasonOf solver c l - basicReasonOf solver (CHAtLeast c) l = basicReasonOf solver c l - basicReasonOf solver (CHPBCounter c) l = basicReasonOf solver c l - basicReasonOf solver (CHPBPueblo c) l = basicReasonOf solver c l - - toPBAtLeast solver (CHClause c) = toPBAtLeast solver c - toPBAtLeast solver (CHAtLeast c) = toPBAtLeast solver c - toPBAtLeast solver (CHPBCounter c) = toPBAtLeast solver c - toPBAtLeast solver (CHPBPueblo c) = toPBAtLeast solver c - - isSatisfied solver (CHClause c) = isSatisfied solver c - isSatisfied solver (CHAtLeast c) = isSatisfied solver c - isSatisfied solver (CHPBCounter c) = isSatisfied solver c - isSatisfied solver (CHPBPueblo c) = isSatisfied solver c - - constrIsProtected solver (CHClause c) = constrIsProtected solver c - constrIsProtected solver (CHAtLeast c) = constrIsProtected solver c - constrIsProtected solver (CHPBCounter c) = constrIsProtected solver c - constrIsProtected solver (CHPBPueblo c) = constrIsProtected solver c - - constrReadActivity (CHClause c) = constrReadActivity c - constrReadActivity (CHAtLeast c) = constrReadActivity c - constrReadActivity (CHPBCounter c) = constrReadActivity c - constrReadActivity (CHPBPueblo c) = constrReadActivity c - - constrWriteActivity (CHClause c) aval = constrWriteActivity c aval - constrWriteActivity (CHAtLeast c) aval = constrWriteActivity c aval - constrWriteActivity (CHPBCounter c) aval = constrWriteActivity c aval - constrWriteActivity (CHPBPueblo c) aval = constrWriteActivity c aval - --- To avoid heap-allocation Maybe value, it returns -1 when not found. -findForWatch :: Solver -> IOUArray Int Lit -> Int -> Int -> IO Int -#ifndef __GLASGOW_HASKELL__ -findForWatch solver a beg end = go beg end - where - go :: Int -> Int -> IO Int - go i end | i > end = return (-1) - go i end = do - val <- litValue s =<< unsafeRead a i - if val /= lFalse - then return i - else go (i+1) end -#else -{- We performed worker-wrapper transfomation manually, since the worker - generated by GHC has type - "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", - not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". - We want latter one to avoid heap-allocating Int value. -} -findForWatch solver a (I# beg) (I# end) = IO $ \w -> - case go# beg end w of - (# w2, ret #) -> (# w2, I# ret #) - where - go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) -#if __GLASGOW_HASKELL__ < 708 - go# i end w | i ># end = (# w, -1# #) -#else - go# i end w | isTrue# (i ># end) = (# w, -1# #) -#endif - go# i end w = - case unIO (litValue solver =<< unsafeRead a (I# i)) w of - (# w2, val #) -> - if val /= lFalse - then (# w2, i #) - else go# (i +# 1#) end w2 - - unIO (IO f) = f -#endif - -{-------------------------------------------------------------------- - Clause ---------------------------------------------------------------------} - -data ClauseHandler - = ClauseHandler - { claLits :: !(IOUArray Int Lit) - , claActivity :: !(IORef Double) - , claHash :: !Int - } - -instance Eq ClauseHandler where - (==) = (==) `on` claLits - -instance Hashable ClauseHandler where - hash = claHash - hashWithSalt = defaultHashWithSalt - -newClauseHandler :: Clause -> Bool -> IO ClauseHandler -newClauseHandler ls learnt = do - let size = length ls - a <- newListArray (0, size-1) ls - act <- newIORef $! (if learnt then 0 else -1) - return (ClauseHandler a act (hash ls)) - -instance ConstraintHandler ClauseHandler where - toConstraintHandler = CHClause - - showConstraintHandler _ this = do - lits <- getElems (claLits this) - return (show lits) - - attach solver this = do - -- BCP Queue should be empty at this point. - -- If not, duplicated propagation happens. - bcpCheckEmpty solver - - (lb,ub) <- getBounds (claLits this) - assert (lb == 0) $ return () - let size = ub-lb+1 - - if size == 0 then do - markBad solver - return False - else if size == 1 then do - lit0 <- unsafeRead (claLits this) 0 - assignBy solver lit0 this - else do - ref <- newIORef 1 - let f i = do - lit_i <- unsafeRead (claLits this) i - val_i <- litValue solver lit_i - if val_i /= lFalse then - return True - else do - j <- readIORef ref - k <- findForWatch solver (claLits this) j ub - case k of - -1 -> do - return False - _ -> do - lit_k <- unsafeRead (claLits this) k - unsafeWrite (claLits this) i lit_k - unsafeWrite (claLits this) k lit_i - writeIORef ref $! (k+1) - return True - - b <- f 0 - if b then do - lit0 <- unsafeRead (claLits this) 0 - watch solver lit0 this - b2 <- f 1 - if b2 then do - lit1 <- unsafeRead (claLits this) 1 - watch solver lit1 this - return True - else do -- UNIT - -- We need to watch the most recently falsified literal - (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..ub] $ \l -> do - lit <- unsafeRead (claLits this) l - lv <- litLevel solver lit - return (l,lv) - lit1 <- unsafeRead (claLits this) 1 - liti <- unsafeRead (claLits this) i - unsafeWrite (claLits this) 1 liti - unsafeWrite (claLits this) i lit1 - watch solver liti this - assignBy solver lit0 this -- should always succeed - else do -- CONFLICT - ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [lb..ub] $ \l -> do - lit <- unsafeRead (claLits this) l - lv <- litLevel solver lit - return (l,lv) - forM_ (zip [0..] ls) $ \(i,lit) -> do - unsafeWrite (claLits this) i lit - lit0 <- unsafeRead (claLits this) 0 - lit1 <- unsafeRead (claLits this) 1 - watch solver lit0 this - watch solver lit1 this - return False - - watchedLiterals _ this = do - lits <- getElems (claLits this) - case lits of - l1:l2:_ -> return [l1, l2] - _ -> return [] - - basicPropagate !solver this this2 !falsifiedLit = do - preprocess - - !lit0 <- unsafeRead a 0 - !val0 <- litValue solver lit0 - if val0 == lTrue - then do - watch solver falsifiedLit this - return True - else do - (!lb,!ub) <- getBounds a - assert (lb==0) $ return () - i <- findForWatch solver a 2 ub - case i of - -1 -> do - when debugMode $ logIO solver $ do - str <- showConstraintHandler solver this - return $ printf "basicPropagate: %s is unit" str - watch solver falsifiedLit this - assignBy solver lit0 this - _ -> do - !lit1 <- unsafeRead a 1 - !liti <- unsafeRead a i - unsafeWrite a 1 liti - unsafeWrite a i lit1 - watch solver liti this - return True - - where - a = claLits this2 - - preprocess :: IO () - preprocess = do - !l0 <- unsafeRead a 0 - !l1 <- unsafeRead a 1 - assert (l0==falsifiedLit || l1==falsifiedLit) $ return () - when (l0==falsifiedLit) $ do - unsafeWrite a 0 l1 - unsafeWrite a 1 l0 - - basicReasonOf _ this l = do - lits <- getElems (claLits this) - case l of - Nothing -> return lits - Just lit -> do - assert (lit == head lits) $ return () - return $ tail lits - - toPBAtLeast _ this = do - lits <- getElems (claLits this) - return ([(1,l) | l <- lits], 1) - - isSatisfied solver this = do - lits <- getElems (claLits this) - vals <- mapM (litValue solver) lits - return $ lTrue `elem` vals - - constrIsProtected _ this = do - size <- liftM rangeSize (getBounds (claLits this)) - return $! size <= 2 - - constrReadActivity this = readIORef (claActivity this) - - constrWriteActivity this aval = writeIORef (claActivity this) $! aval - -instantiateClause :: Solver -> Clause -> IO (Maybe Clause) -instantiateClause solver = loop [] - where - loop :: [Lit] -> [Lit] -> IO (Maybe Clause) - loop ret [] = return $ Just ret - loop ret (l:ls) = do - val <- litValue solver l - if val==lTrue then - return Nothing - else if val==lFalse then - loop ret ls - else - loop (l : ret) ls - -basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool -basicAttachClauseHandler solver this = do - lits <- getElems (claLits this) - case lits of - [] -> do - markBad solver - return False - [l1] -> do - assignBy solver l1 this - l1:l2:_ -> do - watch solver l1 this - watch solver l2 this - return True - -{-------------------------------------------------------------------- - Cardinality Constraint ---------------------------------------------------------------------} - -data AtLeastHandler - = AtLeastHandler - { atLeastLits :: IOUArray Int Lit - , atLeastNum :: !Int - , atLeastActivity :: !(IORef Double) - , atLeastHash :: !Int - } - -instance Eq AtLeastHandler where - (==) = (==) `on` atLeastLits - -instance Hashable AtLeastHandler where - hash = atLeastHash - hashWithSalt = defaultHashWithSalt - -newAtLeastHandler :: [Lit] -> Int -> Bool -> IO AtLeastHandler -newAtLeastHandler ls n learnt = do - let size = length ls - a <- newListArray (0, size-1) ls - act <- newIORef $! (if learnt then 0 else -1) - return (AtLeastHandler a n act (hash (ls,n))) - -instance ConstraintHandler AtLeastHandler where - toConstraintHandler = CHAtLeast - - showConstraintHandler _ this = do - lits <- getElems (atLeastLits this) - return $ show lits ++ " >= " ++ show (atLeastNum this) - - -- FIXME: simplify implementation - attach solver this = do - -- BCP Queue should be empty at this point. - -- If not, duplicated propagation happens. - bcpCheckEmpty solver - - let a = atLeastLits this - (lb,ub) <- getBounds a - assert (lb == 0) $ return () - let m = ub - lb + 1 - n = atLeastNum this - - if m < n then do - markBad solver - return False - else if m == n then do - let f i = do - lit <- unsafeRead a i - assignBy solver lit this - allM f [0..n-1] - else do -- m > n - let f !i !j - | i == n = do - -- NOT VIOLATED: n literals (0 .. n-1) are watched - k <- findForWatch solver a j ub - if k /= -1 then do - -- NOT UNIT - lit_n <- unsafeRead a n - lit_k <- unsafeRead a k - unsafeWrite a n lit_k - unsafeWrite a k lit_n - watch solver lit_k this - -- n+1 literals (0 .. n) are watched. - else do - -- UNIT - forLoop 0 ( do - lit <- unsafeRead a l - _ <- assignBy solver lit this -- should always succeed - return () - -- We need to watch the most recently falsified literal - (l,_) <- liftM (maximumBy (comparing snd)) $ forM [n..ub] $ \l -> do - lit <- unsafeRead a l - lv <- litLevel solver lit - when debugMode $ do - val <- litValue solver lit - unless (val == lFalse) $ error "AtLeastHandler.attach: should not happen" - return (l,lv) - lit_n <- unsafeRead a n - lit_l <- unsafeRead a l - unsafeWrite a n lit_l - unsafeWrite a l lit_n - watch solver lit_l this - -- n+1 literals (0 .. n) are watched. - return True - | otherwise = do - assert (i < n && n <= j) $ return () - lit_i <- unsafeRead a i - val_i <- litValue solver lit_i - if val_i /= lFalse then do - watch solver lit_i this - f (i+1) j - else do - k <- findForWatch solver a j ub - if k /= -1 then do - lit_k <- unsafeRead a k - unsafeWrite a i lit_k - unsafeWrite a k lit_i - watch solver lit_k this - f (i+1) (k+1) - else do - -- CONFLICT - -- We need to watch unassigned literals or most recently falsified literals. - do xs <- liftM (sortBy (flip (comparing snd))) $ forM [i..ub] $ \l -> do - lit <- readArray a l - val <- litValue solver lit - if val == lFalse then do - lv <- litLevel solver lit - return (lit, lv) - else do - return (lit, maxBound) - forM_ (zip [i..ub] xs) $ \(l,(lit,_lv)) -> do - writeArray a l lit - forLoop i (<=n) (+1) $ \l -> do - lit_l <- readArray a l - watch solver lit_l this - -- n+1 literals (0 .. n) are watched. - return False - f 0 n - - watchedLiterals _ this = do - lits <- getElems (atLeastLits this) - let n = atLeastNum this - let ws = if length lits > n then take (n+1) lits else [] - return ws - - basicPropagate solver this this2 falsifiedLit = do - preprocess - - when debugMode $ do - litn <- readArray a n - unless (litn == falsifiedLit) $ error "AtLeastHandler.basicPropagate: should not happen" - - (lb,ub) <- getBounds a - assert (lb==0) $ return () - i <- findForWatch solver a (n+1) ub - case i of - -1 -> do - when debugMode $ logIO solver $ do - str <- showConstraintHandler solver this - return $ printf "basicPropagate: %s is unit" str - watch solver falsifiedLit this - let loop :: Int -> IO Bool - loop i - | i >= n = return True - | otherwise = do - liti <- unsafeRead a i - ret2 <- assignBy solver liti this - if ret2 - then loop (i+1) - else return False - loop 0 - _ -> do - liti <- unsafeRead a i - litn <- unsafeRead a n - unsafeWrite a i litn - unsafeWrite a n liti - watch solver liti this - return True - - where - a = atLeastLits this2 - n = atLeastNum this2 - - preprocess :: IO () - preprocess = loop 0 - where - loop :: Int -> IO () - loop i - | i >= n = return () - | otherwise = do - li <- unsafeRead a i - if (li /= falsifiedLit) - then loop (i+1) - else do - ln <- unsafeRead a n - unsafeWrite a n li - unsafeWrite a i ln - - basicReasonOf solver this concl = do - (lb,ub) <- getBounds (atLeastLits this) - assert (lb==0) $ return () - let n = atLeastNum this - falsifiedLits <- mapM (readArray (atLeastLits this)) [n..ub] -- drop first n elements - when debugMode $ do - forM_ falsifiedLits $ \lit -> do - val <- litValue solver lit - unless (val == lFalse) $ do - error $ printf "AtLeastHandler.basicReasonOf: %d is %s (lFalse expected)" lit (show val) - case concl of - Nothing -> do - let go :: Int -> IO Lit - go i - | i >= n = error $ printf "AtLeastHandler.basicReasonOf: cannot find falsified literal in first %d elements" n - | otherwise = do - lit <- readArray (atLeastLits this) i - val <- litValue solver lit - if val == lFalse - then return lit - else go (i+1) - lit <- go lb - return $ lit : falsifiedLits - Just lit -> do - when debugMode $ do - es <- getElems (atLeastLits this) - unless (lit `elem` take n es) $ - error $ printf "AtLeastHandler.basicReasonOf: cannot find %d in first %d elements" n - return falsifiedLits - - toPBAtLeast _ this = do - lits <- getElems (atLeastLits this) - return ([(1,l) | l <- lits], fromIntegral (atLeastNum this)) - - isSatisfied solver this = do - lits <- getElems (atLeastLits this) - vals <- mapM (litValue solver) lits - return $ length [v | v <- vals, v == lTrue] >= atLeastNum this - - constrReadActivity this = readIORef (atLeastActivity this) - - constrWriteActivity this aval = writeIORef (atLeastActivity this) $! aval - -instantiateAtLeast :: Solver -> AtLeast -> IO AtLeast -instantiateAtLeast solver (xs,n) = loop ([],n) xs - where - loop :: AtLeast -> [Lit] -> IO AtLeast - loop ret [] = return ret - loop (ys,m) (l:ls) = do - val <- litValue solver l - if val == lTrue then - loop (ys, m-1) ls - else if val == lFalse then - loop (ys, m) ls - else - loop (l:ys, m) ls - -basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool -basicAttachAtLeastHandler solver this = do - lits <- getElems (atLeastLits this) - let m = length lits - n = atLeastNum this - if m < n then do - markBad solver - return False - else if m == n then do - allM (\l -> assignBy solver l this) lits - else do -- m > n - forM_ (take (n+1) lits) $ \l -> watch solver l this - return True - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint ---------------------------------------------------------------------} - -newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler -newPBHandler solver ts degree learnt = do - config <- readIORef (svPBHandlerType solver) - case config of - PBHandlerTypeCounter -> do - c <- newPBHandlerCounter ts degree learnt - return (toConstraintHandler c) - PBHandlerTypePueblo -> do - c <- newPBHandlerPueblo ts degree learnt - return (toConstraintHandler c) - -newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler -newPBHandlerPromoted solver lhs rhs learnt = do - case pbToAtLeast (lhs,rhs) of - Nothing -> newPBHandler solver lhs rhs learnt - Just (lhs2, rhs2) -> do - if rhs2 /= 1 then do - h <- newAtLeastHandler lhs2 rhs2 learnt - return $ toConstraintHandler h - else do - h <- newClauseHandler lhs2 learnt - return $ toConstraintHandler h - -instantiatePB :: Solver -> PBLinAtLeast -> IO PBLinAtLeast -instantiatePB solver (xs,n) = loop ([],n) xs - where - loop :: PBLinAtLeast -> PBLinSum -> IO PBLinAtLeast - loop ret [] = return ret - loop (ys,m) ((c,l):ts) = do - val <- litValue solver l - if val == lTrue then - loop (ys, m-c) ts - else if val == lFalse then - loop (ys, m) ts - else - loop ((c,l):ys, m) ts - -pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool -pbOverSAT solver (lhs, rhs) = do - ss <- forM lhs $ \(c,l) -> do - v <- litValue solver l - if v /= lFalse - then return c - else return 0 - return $! sum ss > rhs - -pbToAtLeast :: PBLinAtLeast -> Maybe AtLeast -pbToAtLeast (lhs, rhs) = do - let cs = [c | (c,_) <- lhs] - guard $ Set.size (Set.fromList cs) == 1 - let c = head cs - return $ (map snd lhs, fromInteger ((rhs+c-1) `div` c)) - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint (Counter) ---------------------------------------------------------------------} - -data PBHandlerCounter - = PBHandlerCounter - { pbTerms :: !PBLinSum -- sorted in the decending order on coefficients. - , pbDegree :: !Integer - , pbCoeffMap :: !(LitMap Integer) - , pbMaxSlack :: !Integer - , pbSlack :: !(IORef Integer) - , pbActivity :: !(IORef Double) - , pbHash :: !Int - } - -instance Eq PBHandlerCounter where - (==) = (==) `on` pbSlack - -instance Hashable PBHandlerCounter where - hash = pbHash - hashWithSalt = defaultHashWithSalt - -newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter -newPBHandlerCounter ts degree learnt = do - let ts' = sortBy (flip compare `on` fst) ts - slack = sum (map fst ts) - degree - m = IM.fromList [(l,c) | (c,l) <- ts] - s <- newIORef slack - act <- newIORef $! (if learnt then 0 else -1) - return (PBHandlerCounter ts' degree m slack s act (hash (ts,degree))) - -instance ConstraintHandler PBHandlerCounter where - toConstraintHandler = CHPBCounter - - showConstraintHandler _ this = do - return $ show (pbTerms this) ++ " >= " ++ show (pbDegree this) - - attach solver this = do - -- BCP queue should be empty at this point. - -- It is important for calculating slack. - bcpCheckEmpty solver - s <- liftM sum $ forM (pbTerms this) $ \(c,l) -> do - watch solver l this - val <- litValue solver l - if val == lFalse then do - addBacktrackCB solver (litVar l) $ modifyIORef' (pbSlack this) (+ c) - return 0 - else do - return c - let slack = s - pbDegree this - writeIORef (pbSlack this) $! slack - if slack < 0 then - return False - else do - flip allM (pbTerms this) $ \(c,l) -> do - val <- litValue solver l - if c > slack && val == lUndef then do - assignBy solver l this - else - return True - - watchedLiterals _ this = do - return $ map snd $ pbTerms this - - basicPropagate solver this this2 falsifiedLit = do - watch solver falsifiedLit this - let c = pbCoeffMap this2 IM.! falsifiedLit - modifyIORef' (pbSlack this2) (subtract c) - addBacktrackCB solver (litVar falsifiedLit) $ modifyIORef' (pbSlack this2) (+ c) - s <- readIORef (pbSlack this2) - if s < 0 then - return False - else do - forM_ (takeWhile (\(c1,_) -> c1 > s) (pbTerms this2)) $ \(_,l1) -> do - v <- litValue solver l1 - when (v == lUndef) $ do - assignBy solver l1 this - return () - return True - - basicReasonOf solver this l = do - case l of - Nothing -> do - let p _ = return True - f p (pbMaxSlack this) (pbTerms this) - Just lit -> do - idx <- varAssignNo solver (litVar lit) - -- PB制約の場合には複数回unitになる可能性があり、 - -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 - let p lit2 =do - idx2 <- varAssignNo solver (litVar lit2) - return $ idx2 < idx - let c = pbCoeffMap this IM.! lit - f p (pbMaxSlack this - c) (pbTerms this) - where - {-# INLINE f #-} - f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] - f p s xs = go s xs [] - where - go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] - go s _ ret | s < 0 = return ret - go _ [] _ = error "PBHandlerCounter.basicReasonOf: should not happen" - go s ((c,lit):xs) ret = do - val <- litValue solver lit - if val == lFalse then do - b <- p lit - if b - then go (s - c) xs (lit:ret) - else go s xs ret - else do - go s xs ret - - toPBAtLeast _ this = do - return (pbTerms this, pbDegree this) - - isSatisfied solver this = do - xs <- forM (pbTerms this) $ \(c,l) -> do - v <- litValue solver l - if v == lTrue - then return c - else return 0 - return $ sum xs >= pbDegree this - - constrWeight _ _ = return 0.5 - - constrReadActivity this = readIORef (pbActivity this) - - constrWriteActivity this aval = writeIORef (pbActivity this) $! aval - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint (Pueblo) ---------------------------------------------------------------------} - -data PBHandlerPueblo - = PBHandlerPueblo - { puebloTerms :: !PBLinSum - , puebloDegree :: !Integer - , puebloMaxSlack :: !Integer - , puebloWatches :: !(IORef LitSet) - , puebloWatchSum :: !(IORef Integer) - , puebloActivity :: !(IORef Double) - , puebloHash :: !Int - } - -instance Eq PBHandlerPueblo where - (==) = (==) `on` puebloWatchSum - -instance Hashable PBHandlerPueblo where - hash = puebloHash - hashWithSalt = defaultHashWithSalt - -puebloAMax :: PBHandlerPueblo -> Integer -puebloAMax this = - case puebloTerms this of - (c,_):_ -> c - [] -> 0 -- should not happen? - -newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo -newPBHandlerPueblo ts degree learnt = do - let ts' = sortBy (flip compare `on` fst) ts - slack = sum [c | (c,_) <- ts'] - degree - ws <- newIORef IS.empty - wsum <- newIORef 0 - act <- newIORef $! (if learnt then 0 else -1) - return $ PBHandlerPueblo ts' degree slack ws wsum act (hash (ts,degree)) - -puebloGetWatchSum :: PBHandlerPueblo -> IO Integer -puebloGetWatchSum pb = readIORef (puebloWatchSum pb) - -puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO () -puebloWatch solver constr !pb (c, lit) = do - watch solver lit constr - modifyIORef' (puebloWatches pb) (IS.insert lit) - modifyIORef' (puebloWatchSum pb) (+c) - -puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO () -puebloUnwatch _solver pb (c, lit) = do - modifyIORef' (puebloWatches pb) (IS.delete lit) - modifyIORef' (puebloWatchSum pb) (subtract c) - -instance ConstraintHandler PBHandlerPueblo where - toConstraintHandler = CHPBPueblo - - showConstraintHandler _ this = do - return $ show (puebloTerms this) ++ " >= " ++ show (puebloDegree this) - - attach solver this = do - bcpCheckEmpty solver - let constr = toConstraintHandler this - ret <- puebloPropagate solver constr this - - -- register to watch recently falsified literals to recover - -- "WatchSum >= puebloDegree this + puebloAMax this" when backtrack is performed. - wsum <- puebloGetWatchSum this - unless (wsum >= puebloDegree this + puebloAMax this) $ do - let f m tm@(_,lit) = do - val <- litValue solver lit - if val == lFalse then do - idx <- varAssignNo solver (litVar lit) - return (IM.insert idx tm m) - else - return m -#if MIN_VERSION_containers(0,5,0) - xs <- liftM (map snd . IM.toDescList) $ foldM f IM.empty (puebloTerms this) -#else - xs <- liftM (reverse . map snd . IM.toAscList) $ foldM f IM.empty (puebloTerms this) -#endif - let g !_ [] = return () - g !s (t@(c,l):ts) = do - addBacktrackCB solver (litVar l) $ puebloWatch solver constr this t - if s+c >= puebloDegree this + puebloAMax this then return () - else g (s+c) ts - g wsum xs - - return ret - - watchedLiterals _ this = liftM IS.toList $ readIORef (puebloWatches this) - - basicPropagate solver this this2 falsifiedLit = do - let t = fromJust $ find (\(_,l) -> l==falsifiedLit) (puebloTerms this2) - puebloUnwatch solver this2 t - ret <- puebloPropagate solver this this2 - wsum <- puebloGetWatchSum this2 - unless (wsum >= puebloDegree this2 + puebloAMax this2) $ - addBacktrackCB solver (litVar falsifiedLit) $ puebloWatch solver this this2 t - return ret - - basicReasonOf solver this l = do - case l of - Nothing -> do - let p _ = return True - f p (puebloMaxSlack this) (puebloTerms this) - Just lit -> do - idx <- varAssignNo solver (litVar lit) - -- PB制約の場合には複数回unitになる可能性があり、 - -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 - let p lit2 =do - idx2 <- varAssignNo solver (litVar lit2) - return $ idx2 < idx - let c = fst $ fromJust $ find (\(_,l) -> l == lit) (puebloTerms this) - f p (puebloMaxSlack this - c) (puebloTerms this) - where - {-# INLINE f #-} - f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] - f p s xs = go s xs [] - where - go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] - go s _ ret | s < 0 = return ret - go _ [] _ = error "PBHandlerPueblo.basicReasonOf: should not happen" - go s ((c,lit):xs) ret = do - val <- litValue solver lit - if val == lFalse then do - b <- p lit - if b - then go (s - c) xs (lit:ret) - else go s xs ret - else do - go s xs ret - - toPBAtLeast _ this = do - return (puebloTerms this, puebloDegree this) - - isSatisfied solver this = do - xs <- forM (puebloTerms this) $ \(c,l) -> do - v <- litValue solver l - if v == lTrue - then return c - else return 0 - return $ sum xs >= puebloDegree this - - constrWeight _ _ = return 0.5 - - constrReadActivity this = readIORef (puebloActivity this) - - constrWriteActivity this aval = writeIORef (puebloActivity this) $! aval - -puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool -puebloPropagate solver constr this = do - puebloUpdateWatchSum solver constr this - watchsum <- puebloGetWatchSum this - if puebloDegree this + puebloAMax this <= watchsum then - return True - else if watchsum < puebloDegree this then do - -- CONFLICT - return False - else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this - -- UNIT PROPAGATION - let f [] = return True - f ((c,lit) : ts) = do - watchsum <- puebloGetWatchSum this - if watchsum - c >= puebloDegree this then - return True - else do - val <- litValue solver lit - when (val == lUndef) $ do - b <- assignBy solver lit this - assert b $ return () - f ts - f $ puebloTerms this - -puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO () -puebloUpdateWatchSum solver constr this = do - let f [] = return () - f (t@(_,lit):ts) = do - watchSum <- puebloGetWatchSum this - if watchSum >= puebloDegree this + puebloAMax this then - return () - else do - val <- litValue solver lit - watched <- liftM (lit `IS.member`) $ readIORef (puebloWatches this) - when (val /= lFalse && not watched) $ do - puebloWatch solver constr this t - f ts - f (puebloTerms this) - -{-------------------------------------------------------------------- - Restart strategy ---------------------------------------------------------------------} - -data RestartStrategy = MiniSATRestarts | ArminRestarts | LubyRestarts - deriving (Show, Eq, Ord) - -mkRestartSeq :: RestartStrategy -> Int -> Double -> [Int] -mkRestartSeq MiniSATRestarts = miniSatRestartSeq -mkRestartSeq ArminRestarts = arminRestartSeq -mkRestartSeq LubyRestarts = lubyRestartSeq - -miniSatRestartSeq :: Int -> Double -> [Int] -miniSatRestartSeq start inc = iterate (ceiling . (inc *) . fromIntegral) start - -{- -miniSatRestartSeq :: Int -> Double -> [Int] -miniSatRestartSeq start inc = map round $ iterate (inc*) (fromIntegral start) --} - -arminRestartSeq :: Int -> Double -> [Int] -arminRestartSeq start inc = go (fromIntegral start) (fromIntegral start) - where - go !inner !outer = round inner : go inner' outer' - where - (inner',outer') = - if inner >= outer - then (fromIntegral start, outer * inc) - else (inner * inc, outer) - -lubyRestartSeq :: Int -> Double -> [Int] -lubyRestartSeq start inc = map (ceiling . (fromIntegral start *) . luby inc) [0..] - -{- - Finite subsequences of the Luby-sequence: - - 0: 1 - 1: 1 1 2 - 2: 1 1 2 1 1 2 4 - 3: 1 1 2 1 1 2 4 1 1 2 1 1 2 4 8 - ... - - --} -luby :: Double -> Integer -> Double -luby y x = go2 size1 sequ1 x - where - -- Find the finite subsequence that contains index 'x', and the - -- size of that subsequence: - (size1, sequ1) = go 1 0 - - go :: Integer -> Integer -> (Integer, Integer) - go size sequ - | size < x+1 = go (2*size+1) (sequ+1) - | otherwise = (size, sequ) - - go2 :: Integer -> Integer -> Integer -> Double - go2 size sequ x2 - | size-1 /= x2 = let size' = (size-1) `div` 2 in go2 size' (sequ - 1) (x2 `mod` size') - | otherwise = y ^ sequ - - -{-------------------------------------------------------------------- - utility ---------------------------------------------------------------------} - -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM p = go - where - go [] = return True - go (x:xs) = do - b <- p x - if b - then go xs - else return False - -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM p = go - where - go [] = return False - go (x:xs) = do - b <- p x - if b - then return True - else go xs - -#if !MIN_VERSION_base(4,6,0) - -modifyIORef' :: IORef a -> (a -> a) -> IO () -modifyIORef' ref f = do - x <- readIORef ref - writeIORef ref $! f x - -#endif - -shift :: IORef [a] -> IO a -shift ref = do - (x:xs) <- readIORef ref - writeIORef ref xs - return x - -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` hash x -#if MIN_VERSION_hashable(1,2,0) - where - combine :: Int -> Int -> Int - combine h1 h2 = (h1 * 16777619) `xor` h2 -#endif - -{-------------------------------------------------------------------- - debug ---------------------------------------------------------------------} - -debugMode :: Bool -debugMode = False - -checkSatisfied :: Solver -> IO () -checkSatisfied solver = do - cls <- readIORef (svConstrDB solver) - forM_ cls $ \c -> do - b <- isSatisfied solver c - unless b $ do - s <- showConstraintHandler solver c - log solver $ "BUG: " ++ s ++ " is violated" - -sanityCheck :: Solver -> IO () -sanityCheck _ | not debugMode = return () -sanityCheck solver = do - cls <- readIORef (svConstrDB solver) - forM_ cls $ \constr -> do - lits <- watchedLiterals solver constr - forM_ lits $ \l -> do - ws <- watches solver l - unless (constr `elem` ws) $ error $ printf "sanityCheck:A:%s" (show lits) - - vs <- variables solver - let lits = [l | v <- vs, l <- [literal v True, literal v False]] - forM_ lits $ \l -> do - cs <- watches solver l - forM_ cs $ \constr -> do - lits2 <- watchedLiterals solver constr - unless (l `elem` lits2) $ do - error $ printf "sanityCheck:C:%d %s" l (show lits2) - -dumpVarActivity :: Solver -> IO () -dumpVarActivity solver = do - log solver "Variable activity:" - vs <- variables solver - forM_ vs $ \v -> do - activity <- varActivity solver v - log solver $ printf "activity(%d) = %d" v activity - -dumpConstrActivity :: Solver -> IO () -dumpConstrActivity solver = do - log solver "Learnt constraints activity:" - xs <- learntConstraints solver - forM_ xs $ \c -> do - s <- showConstraintHandler solver c + , addXORClause + , addXORClauseSoft + + -- * Solving + , solve + , solveWith + , BudgetExceeded (..) + + -- * Extract results + , Model + , getModel + , getFailedAssumptions + + -- * Solver configulation + , RestartStrategy (..) + , setRestartStrategy + , defaultRestartStrategy + , setRestartFirst + , defaultRestartFirst + , setRestartInc + , defaultRestartInc + , setLearntSizeFirst + , defaultLearntSizeFirst + , setLearntSizeInc + , defaultLearntSizeInc + , setCCMin + , defaultCCMin + , LearningStrategy (..) + , setLearningStrategy + , defaultLearningStrategy + , setEnablePhaseSaving + , getEnablePhaseSaving + , defaultEnablePhaseSaving + , setEnableForwardSubsumptionRemoval + , getEnableForwardSubsumptionRemoval + , defaultEnableForwardSubsumptionRemoval + , setEnableBackwardSubsumptionRemoval + , getEnableBackwardSubsumptionRemoval + , defaultEnableBackwardSubsumptionRemoval + , setVarPolarity + , setLogger + , setCheckModel + , setRandomFreq + , defaultRandomFreq + , setRandomGen + , getRandomGen + , setConfBudget + , PBHandlerType (..) + , setPBHandlerType + , defaultPBHandlerType + + -- * Read state + , nVars + , nAssigns + , nConstraints + , nLearnt + , getVarFixed + , getLitFixed + + -- * Internal API + , varBumpActivity + , varDecayActivity + ) where + +import Prelude hiding (log) +import Control.Loop +import Control.Monad +import Control.Exception +#if MIN_VERSION_array(0,5,0) +import Data.Array.IO +#else +import Data.Array.IO hiding (unsafeFreeze) +#endif +import Data.Array.Unsafe (unsafeFreeze) +import Data.Array.Base (unsafeRead, unsafeWrite) +#if MIN_VERSION_hashable(1,2,0) +import Data.Bits (xor) -- for defining 'combine' function +#endif +import Data.Function (on) +import Data.Hashable +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.IORef +import Data.List +import Data.Maybe +import Data.Ord +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Set as Set +import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ +import qualified ToySolver.Internal.Data.SeqQueue as SQ +import qualified ToySolver.Internal.Data.Vec as Vec +import Data.Time +import Data.Typeable +import System.CPUTime +import qualified System.Random as Rand +import Text.Printf + +#ifdef __GLASGOW_HASKELL__ +import GHC.Types (IO (..)) +import GHC.Exts hiding (Constraint) +#endif + +import ToySolver.Data.LBool +import ToySolver.SAT.Types + +{-------------------------------------------------------------------- + internal data structures +--------------------------------------------------------------------} + +type Level = Int + +levelRoot :: Level +levelRoot = -1 + +data Assignment + = Assignment + { aValue :: !Bool + , aIndex :: {-# UNPACK #-} !Int + , aLevel :: {-# UNPACK #-} !Level + , aReason :: !(Maybe SomeConstraintHandler) + , aBacktrackCBs :: !(IORef [IO ()]) + } + +data VarData + = VarData + { vdAssignment :: !(IORef (Maybe Assignment)) + , vdPolarity :: !(IORef Bool) + , vdPosLitData :: !LitData + , vdNegLitData :: !LitData + -- | will be invoked when the variable is assigned + , vdWatches :: !(IORef [SomeConstraintHandler]) + , vdActivity :: !(IORef VarActivity) + } + +data LitData + = LitData + { -- | will be invoked when this literal is falsified + ldWatches :: !(IORef [SomeConstraintHandler]) + , ldOccurList :: !(IORef (HashSet SomeConstraintHandler)) + } + +newVarData :: IO VarData +newVarData = do + ainfo <- newIORef Nothing + polarity <- newIORef True + pos <- newLitData + neg <- newLitData + watches <- newIORef [] + activity <- newIORef 0 + return $ VarData ainfo polarity pos neg watches activity + +newLitData :: IO LitData +newLitData = do + ws <- newIORef [] + occ <- newIORef HashSet.empty + return $ LitData ws occ + +varData :: Solver -> Var -> IO VarData +varData solver !v = Vec.unsafeRead (svVarData solver) (v-1) + +litData :: Solver -> Lit -> IO LitData +litData solver !l = + -- litVar による heap allocation を避けるために、 + -- litPolarityによる分岐後にvarDataを呼ぶ。 + if litPolarity l then do + vd <- varData solver l + return $ vdPosLitData vd + else do + vd <- varData solver (negate l) + return $ vdNegLitData vd + +{-# INLINE varValue #-} +varValue :: Solver -> Var -> IO LBool +varValue solver !v = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> return lUndef + Just x -> return $! (liftBool $! aValue x) + +{-# INLINE litValue #-} +litValue :: Solver -> Lit -> IO LBool +litValue solver !l = do + -- litVar による heap allocation を避けるために、 + -- litPolarityによる分岐後にvarDataを呼ぶ。 + if litPolarity l then + varValue solver l + else do + m <- varValue solver (negate l) + return $! lnot m + +getVarFixed :: Solver -> Var -> IO LBool +getVarFixed solver !v = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Just x | aLevel x == levelRoot -> return $! (liftBool $! aValue x) + _ -> return lUndef + +getLitFixed :: Solver -> Var -> IO LBool +getLitFixed solver !l = do + -- litVar による heap allocation を避けるために、 + -- litPolarityによる分岐後にvarDataを呼ぶ。 + if litPolarity l then + getVarFixed solver l + else do + m <- getVarFixed solver (negate l) + return $! lnot m + +varLevel :: Solver -> Var -> IO Level +varLevel solver !v = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> error ("ToySolver.SAT.varLevel: unassigned var " ++ show v) + Just a -> return (aLevel a) + +litLevel :: Solver -> Lit -> IO Level +litLevel solver l = varLevel solver (litVar l) + +varReason :: Solver -> Var -> IO (Maybe SomeConstraintHandler) +varReason solver !v = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> error ("ToySolver.SAT.varReason: unassigned var " ++ show v) + Just a -> return (aReason a) + +varAssignNo :: Solver -> Var -> IO Int +varAssignNo solver !v = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> error ("ToySolver.SAT.varAssignNo: unassigned var " ++ show v) + Just a -> return (aIndex a) + +-- | Solver instance +data Solver + = Solver + { svOk :: !(IORef Bool) + , svVarQueue :: !PQ.PriorityQueue + , svTrail :: !(IORef [Lit]) + , svVarData :: !(Vec.Vec VarData) + , svConstrDB :: !(IORef [SomeConstraintHandler]) + , svLearntDB :: !(IORef (Int,[SomeConstraintHandler])) + , svAssumptions :: !(IORef (IOUArray Int Lit)) + , svLevel :: !(IORef Level) + , svBCPQueue :: !(SQ.SeqQueue Lit) + , svModel :: !(IORef (Maybe Model)) + , svNDecision :: !(IORef Int) + , svNRandomDecision :: !(IORef Int) + , svNConflict :: !(IORef Int) + , svNRestart :: !(IORef Int) + , svNAssigns :: !(IORef Int) + , svNFixed :: !(IORef Int) + , svNLearntGC :: !(IORef Int) + , svNRemovedConstr :: !(IORef Int) + + -- | Inverse of the variable activity decay factor. (default 1 / 0.95) + , svVarDecay :: !(IORef Double) + + -- | Amount to bump next variable with. + , svVarInc :: !(IORef Double) + + -- | Inverse of the constraint activity decay factor. (1 / 0.999) + , svConstrDecay :: !(IORef Double) + + -- | Amount to bump next constraint with. + , svConstrInc :: !(IORef Double) + + , svRestartStrategy :: !(IORef RestartStrategy) + + -- | The initial restart limit. (default 100) + , svRestartFirst :: !(IORef Int) + + -- | The factor with which the restart limit is multiplied in each restart. (default 1.5) + , svRestartInc :: !(IORef Double) + + -- | The initial limit for learnt constraints. + , svLearntSizeFirst :: !(IORef Int) + + -- | The limit for learnt constraints is multiplied with this factor periodically. (default 1.1) + , svLearntSizeInc :: !(IORef Double) + + , svLearntLim :: !(IORef Int) + , svLearntLimAdjCnt :: !(IORef Int) + , svLearntLimSeq :: !(IORef [(Int,Int)]) + + -- | Controls conflict constraint minimization (0=none, 1=local, 2=recursive) + , svCCMin :: !(IORef Int) + + , svEnablePhaseSaving :: !(IORef Bool) + , svEnableForwardSubsumptionRemoval :: !(IORef Bool) + + , svLearningStrategy :: !(IORef LearningStrategy) + + , svPBHandlerType :: !(IORef PBHandlerType) + + , svEnableBackwardSubsumptionRemoval :: !(IORef Bool) + + , svLogger :: !(IORef (Maybe (String -> IO ()))) + , svStartWC :: !(IORef UTCTime) + , svLastStatWC :: !(IORef UTCTime) + + , svCheckModel :: !(IORef Bool) + + , svRandomFreq :: !(IORef Double) + , svRandomGen :: !(IORef Rand.StdGen) + + , svFailedAssumptions :: !(IORef [Lit]) + + , svConfBudget :: !(IORef Int) + } + +markBad :: Solver -> IO () +markBad solver = do + writeIORef (svOk solver) False + SQ.clear (svBCPQueue solver) + +bcpEnqueue :: Solver -> Lit -> IO () +bcpEnqueue solver l = SQ.enqueue (svBCPQueue solver) l + +bcpDequeue :: Solver -> IO (Maybe Lit) +bcpDequeue solver = SQ.dequeue (svBCPQueue solver) + +bcpCheckEmpty :: Solver -> IO () +bcpCheckEmpty solver = do + size <- SQ.queueSize (svBCPQueue solver) + unless (size == 0) $ + error "BUG: BCP Queue should be empty at this point" + +assignBy :: ConstraintHandler c => Solver -> Lit -> c -> IO Bool +assignBy solver lit c = do + lv <- readIORef (svLevel solver) + let !c2 = if lv == levelRoot + then Nothing + else Just $! toConstraintHandler c + assign_ solver lit c2 + +assign :: Solver -> Lit -> IO Bool +assign solver lit = assign_ solver lit Nothing + +assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool +assign_ solver !lit reason = assert (validLit lit) $ do + vd <- varData solver (litVar lit) + m <- readIORef (vdAssignment vd) + case m of + Just a -> return $ litPolarity lit == aValue a + Nothing -> do + idx <- readIORef (svNAssigns solver) + lv <- readIORef (svLevel solver) + bt <- newIORef [] + + writeIORef (vdAssignment vd) $ Just $! + Assignment + { aValue = litPolarity lit + , aIndex = idx + , aLevel = lv + , aReason = reason + , aBacktrackCBs = bt + } + + modifyIORef (svTrail solver) (lit:) + modifyIORef' (svNAssigns solver) (+1) + when (lv == levelRoot) $ modifyIORef' (svNFixed solver) (+1) + bcpEnqueue solver lit + + when debugMode $ logIO solver $ do + let r = case reason of + Nothing -> "" + Just _ -> " by propagation" + return $ printf "assign(level=%d): %d%s" lv lit r + + return True + +unassign :: Solver -> Var -> IO () +unassign solver !v = assert (validVar v) $ do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> error "unassign: should not happen" + Just a -> do + flag <- getEnablePhaseSaving solver + when flag $ writeIORef (vdPolarity vd) (aValue a) + readIORef (aBacktrackCBs a) >>= sequence_ + writeIORef (vdAssignment vd) Nothing + modifyIORef' (svNAssigns solver) (subtract 1) + PQ.enqueue (svVarQueue solver) v + +addBacktrackCB :: Solver -> Var -> IO () -> IO () +addBacktrackCB solver !v callback = do + vd <- varData solver v + m <- readIORef (vdAssignment vd) + case m of + Nothing -> error "addBacktrackCB: should not happen" + Just a -> modifyIORef (aBacktrackCBs a) (callback :) + +-- | Register the constraint to be notified when the literal becames false. +watchLit :: ConstraintHandler c => Solver -> Lit -> c -> IO () +watchLit solver !lit c = do + when debugMode $ do + lits <- watchedLiterals solver c + unless (lit `elem` lits) $ error "watch: should not happen" + ld <- litData solver lit + modifyIORef (ldWatches ld) (toConstraintHandler c : ) + +-- | Register the constraint to be notified when the variable is assigned. +watchVar :: ConstraintHandler c => Solver -> Var -> c -> IO () +watchVar solver !var c = do + when debugMode $ do + vs <- watchedVariables solver c + unless (var `elem` vs) $ error "watchVar: should not happen" + vd <- varData solver var + modifyIORef (vdWatches vd) (toConstraintHandler c : ) + +-- | Returns list of constraints that are watching the literal. +watches :: Solver -> Lit -> IO [SomeConstraintHandler] +watches solver !lit = do + ld <- litData solver lit + readIORef (ldWatches ld) + +addToDB :: ConstraintHandler c => Solver -> c -> IO () +addToDB solver c = do + let c2 = toConstraintHandler c + modifyIORef (svConstrDB solver) (c2 : ) + when debugMode $ logIO solver $ do + str <- showConstraintHandler c + return $ printf "constraint %s is added" str + + b <- isPBRepresentable c + when b $ do + (lhs,_) <- toPBLinAtLeast c + forM_ lhs $ \(_,lit) -> do + ld <- litData solver lit + modifyIORef' (ldOccurList ld) (HashSet.insert c2) + + sanityCheck solver + +addToLearntDB :: ConstraintHandler c => Solver -> c -> IO () +addToLearntDB solver c = do + modifyIORef (svLearntDB solver) $ \(n,xs) -> (n+1, toConstraintHandler c : xs) + when debugMode $ logIO solver $ do + str <- showConstraintHandler c + return $ printf "constraint %s is added" str + sanityCheck solver + +reduceDB :: Solver -> IO () +reduceDB solver = do + (_,cs) <- readIORef (svLearntDB solver) + + xs <- forM cs $ \c -> do + p <- constrIsProtected solver c + w <- constrWeight solver c + actval <- constrReadActivity c + return (c, (p, w*actval)) + + -- Note that False <= True + let ys = sortBy (comparing snd) xs + (zs,ws) = splitAt (length ys `div` 2) ys + + let loop [] ret = return ret + loop ((c,(isShort,_)) : rest) ret = do + flag <- if isShort + then return True + else isLocked solver c + if flag then + loop rest (c:ret) + else do + detach solver c + loop rest ret + zs2 <- loop zs [] + + let cs2 = zs2 ++ map fst ws + n2 = length cs2 + + -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2 + writeIORef (svLearntDB solver) (n2,cs2) + +type VarActivity = Double + +varActivity :: Solver -> Var -> IO VarActivity +varActivity solver !v = do + vd <- varData solver v + readIORef (vdActivity vd) + +varDecayActivity :: Solver -> IO () +varDecayActivity solver = do + d <- readIORef (svVarDecay solver) + modifyIORef' (svVarInc solver) (d*) + +varBumpActivity :: Solver -> Var -> IO () +varBumpActivity solver !v = do + inc <- readIORef (svVarInc solver) + vd <- varData solver v + modifyIORef' (vdActivity vd) (+inc) + PQ.update (svVarQueue solver) v + aval <- readIORef (vdActivity vd) + when (aval > 1e20) $ + -- Rescale + varRescaleAllActivity solver + +varRescaleAllActivity :: Solver -> IO () +varRescaleAllActivity solver = do + vs <- variables solver + forM_ vs $ \v -> do + vd <- varData solver v + modifyIORef' (vdActivity vd) (* 1e-20) + modifyIORef' (svVarInc solver) (* 1e-20) + +variables :: Solver -> IO [Var] +variables solver = do + n <- nVars solver + return [1 .. n] + +-- | number of variables of the problem. +nVars :: Solver -> IO Int +nVars solver = Vec.getSize (svVarData solver) + +-- | number of assigned variables. +nAssigns :: Solver -> IO Int +nAssigns solver = readIORef (svNAssigns solver) + +-- | number of constraints. +nConstraints :: Solver -> IO Int +nConstraints solver = do + xs <- readIORef (svConstrDB solver) + return $ length xs + +-- | number of learnt constrints. +nLearnt :: Solver -> IO Int +nLearnt solver = do + (n,_) <- readIORef (svLearntDB solver) + return n + +learntConstraints :: Solver -> IO [SomeConstraintHandler] +learntConstraints solver = do + (_,cs) <- readIORef (svLearntDB solver) + return cs + +{-------------------------------------------------------------------- + Solver +--------------------------------------------------------------------} + +-- | Create a new Solver instance. +newSolver :: IO Solver +newSolver = do + rec + ok <- newIORef True + trail <- newIORef [] + vars <- Vec.new + vqueue <- PQ.newPriorityQueueBy (ltVar solver) + db <- newIORef [] + db2 <- newIORef (0,[]) + as <- newIORef =<< newArray_ (0,-1) + lv <- newIORef levelRoot + q <- SQ.newFifo + m <- newIORef Nothing + ndecision <- newIORef 0 + nranddec <- newIORef 0 + nconflict <- newIORef 0 + nrestart <- newIORef 0 + nassigns <- newIORef 0 + nfixed <- newIORef 0 + nlearntgc <- newIORef 0 + nremoved <- newIORef 0 + + constrDecay <- newIORef (1 / 0.999) + constrInc <- newIORef 1 + varDecay <- newIORef (1 / 0.95) + varInc <- newIORef 1 + restartStrat <- newIORef defaultRestartStrategy + restartFirst <- newIORef defaultRestartFirst + restartInc <- newIORef defaultRestartInc + learning <- newIORef defaultLearningStrategy + learntSizeFirst <- newIORef defaultLearntSizeFirst + learntSizeInc <- newIORef defaultLearntSizeInc + ccMin <- newIORef defaultCCMin + checkModel <- newIORef False + pbHandlerType <- newIORef defaultPBHandlerType + enablePhaseSaving <- newIORef defaultEnablePhaseSaving + enableForwardSubsumptionRemoval <- newIORef defaultEnableForwardSubsumptionRemoval + enableBackwardSubsumptionRemoval <- newIORef defaultEnableBackwardSubsumptionRemoval + + learntLim <- newIORef undefined + learntLimAdjCnt <- newIORef (-1) + learntLimSeq <- newIORef undefined + + logger <- newIORef Nothing + startWC <- newIORef undefined + lastStatWC <- newIORef undefined + + randfreq <- newIORef defaultRandomFreq + randgen <- newIORef =<< Rand.newStdGen + + failed <- newIORef [] + + confBudget <- newIORef (-1) + + let solver = + Solver + { svOk = ok + , svVarQueue = vqueue + , svTrail = trail + , svVarData = vars + , svConstrDB = db + , svLearntDB = db2 + , svAssumptions = as + , svLevel = lv + , svBCPQueue = q + , svModel = m + , svNDecision = ndecision + , svNRandomDecision = nranddec + , svNConflict = nconflict + , svNRestart = nrestart + , svNAssigns = nassigns + , svNFixed = nfixed + , svNLearntGC = nlearntgc + , svNRemovedConstr = nremoved + , svVarDecay = varDecay + , svVarInc = varInc + , svConstrDecay = constrDecay + , svConstrInc = constrInc + , svRestartStrategy = restartStrat + , svRestartFirst = restartFirst + , svRestartInc = restartInc + , svLearningStrategy = learning + , svLearntSizeFirst = learntSizeFirst + , svLearntSizeInc = learntSizeInc + , svCCMin = ccMin + , svEnablePhaseSaving = enablePhaseSaving + , svEnableForwardSubsumptionRemoval = enableForwardSubsumptionRemoval + , svPBHandlerType = pbHandlerType + , svEnableBackwardSubsumptionRemoval = enableBackwardSubsumptionRemoval + , svLearntLim = learntLim + , svLearntLimAdjCnt = learntLimAdjCnt + , svLearntLimSeq = learntLimSeq + , svLogger = logger + , svStartWC = startWC + , svLastStatWC = lastStatWC + , svCheckModel = checkModel + , svRandomFreq = randfreq + , svRandomGen = randgen + , svFailedAssumptions = failed + , svConfBudget = confBudget + } + return solver + +ltVar :: Solver -> Var -> Var -> IO Bool +ltVar solver v1 v2 = do + a1 <- varActivity solver v1 + a2 <- varActivity solver v2 + return $! a1 > a2 + +{-------------------------------------------------------------------- + Problem specification +--------------------------------------------------------------------} + +-- |Add a new variable +newVar :: Solver -> IO Var +newVar solver = do + n <- Vec.getSize (svVarData solver) + let v = n + 1 + vd <- newVarData + Vec.push (svVarData solver) vd + PQ.enqueue (svVarQueue solver) v + return v + +-- |Add variables. @newVars solver n = replicateM n (newVar solver)@ +newVars :: Solver -> Int -> IO [Var] +newVars solver n = do + nv <- nVars solver + resizeVarCapacity solver (nv+n) + replicateM n (newVar solver) + +-- |Add variables. @newVars_ solver n = newVars solver n >> return ()@ +newVars_ :: Solver -> Int -> IO () +newVars_ solver n = do + nv <- nVars solver + resizeVarCapacity solver (nv+n) + replicateM_ n (newVar solver) + +-- |Pre-allocate internal buffer for @n@ variables. +resizeVarCapacity :: Solver -> Int -> IO () +resizeVarCapacity solver n = do + Vec.resizeCapacity (svVarData solver) n + PQ.resizeHeapCapacity (svVarQueue solver) n + PQ.resizeTableCapacity (svVarQueue solver) (n+1) + +-- |Add a clause to the solver. +addClause :: Solver -> Clause -> IO () +addClause solver lits = do + d <- readIORef (svLevel solver) + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + lits2 <- instantiateClause solver lits + case normalizeClause =<< lits2 of + Nothing -> return () + Just [] -> markBad solver + Just [lit] -> do + {- We do not call 'removeBackwardSubsumedBy' here, + because subsumed constraints will be removed by 'simplify'. -} + ret <- assign solver lit + assert ret $ return () + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + Just lits3 -> do + subsumed <- checkForwardSubsumption solver lits + unless subsumed $ do + removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits3], 1) + clause <- newClauseHandler lits3 False + addToDB solver clause + _ <- basicAttachClauseHandler solver clause + return () + +-- | Add a cardinality constraints /atleast({l1,l2,..},n)/. +addAtLeast :: Solver -- ^ The 'Solver' argument. + -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) + -> Int -- ^ /n/. + -> IO () +addAtLeast solver lits n = do + d <- readIORef (svLevel solver) + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + (lits',n') <- liftM normalizeAtLeast $ instantiateAtLeast solver (lits,n) + let len = length lits' + + if n' <= 0 then return () + else if n' > len then markBad solver + else if n' == 1 then addClause solver lits' + else if n' == len then do + {- We do not call 'removeBackwardSubsumedBy' here, + because subsumed constraints will be removed by 'simplify'. -} + forM_ lits' $ \l -> do + ret <- assign solver l + assert ret $ return () + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + else do + removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits'], fromIntegral n') + c <- newAtLeastHandler lits' n' False + addToDB solver c + _ <- basicAttachAtLeastHandler solver c + return () + +-- | Add a cardinality constraints /atmost({l1,l2,..},n)/. +addAtMost :: Solver -- ^ The 'Solver' argument + -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) + -> Int -- ^ /n/ + -> IO () +addAtMost solver lits n = addAtLeast solver lits' (len-n) + where + len = length lits + lits' = map litNot lits + +-- | Add a cardinality constraints /exactly({l1,l2,..},n)/. +addExactly :: Solver -- ^ The 'Solver' argument + -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) + -> Int -- ^ /n/ + -> IO () +addExactly solver lits n = do + addAtLeast solver lits n + addAtMost solver lits n + +-- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … ≥ n/. +addPBAtLeast :: Solver -- ^ The 'Solver' argument. + -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBAtLeast solver ts n = do + d <- readIORef (svLevel solver) + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + (ts',degree) <- liftM normalizePBLinAtLeast $ instantiatePB solver (ts,n) + + case pbToAtLeast (ts',degree) of + Just (lhs',rhs') -> addAtLeast solver lhs' rhs' + Nothing -> do + let cs = map fst ts' + slack = sum cs - degree + if degree <= 0 then return () + else if slack < 0 then markBad solver + else do + removeBackwardSubsumedBy solver (ts', degree) + c <- newPBHandler solver ts' degree False + addToDB solver c + ret <- attach solver c + if not ret then do + markBad solver + else do + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + +-- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … ≤ n/. +addPBAtMost :: Solver -- ^ The 'Solver' argument. + -> [(Integer,Lit)] -- ^ list of @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBAtMost solver ts n = addPBAtLeast solver [(-c,l) | (c,l) <- ts] (negate n) + +-- | Add a pseudo boolean constraints /c1*l1 + c2*l2 + … = n/. +addPBExactly :: Solver -- ^ The 'Solver' argument. + -> [(Integer,Lit)] -- ^ list of terms @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBExactly solver ts n = do + (ts2,n2) <- liftM normalizePBLinExactly $ instantiatePB solver (ts,n) + addPBAtLeast solver ts2 n2 + addPBAtMost solver ts2 n2 + +-- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … ≥ n/. +addPBAtLeastSoft + :: Solver -- ^ The 'Solver' argument. + -> Lit -- ^ indicator @lit@ + -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBAtLeastSoft solver sel lhs rhs = do + (lhs', rhs') <- liftM normalizePBLinAtLeast $ instantiatePB solver (lhs,rhs) + addPBAtLeast solver ((rhs', litNot sel) : lhs') rhs' + +-- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … ≤ n/. +addPBAtMostSoft + :: Solver -- ^ The 'Solver' argument. + -> Lit -- ^ indicator @lit@ + -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBAtMostSoft solver sel lhs rhs = + addPBAtLeastSoft solver sel [(negate c, lit) | (c,lit) <- lhs] (negate rhs) + +-- | Add a soft pseudo boolean constraints /lit ⇒ c1*l1 + c2*l2 + … = n/. +addPBExactlySoft + :: Solver -- ^ The 'Solver' argument. + -> Lit -- ^ indicator @lit@ + -> [(Integer,Lit)] -- ^ set of terms @[(c1,l1),(c2,l2),…]@ + -> Integer -- ^ /n/ + -> IO () +addPBExactlySoft solver sel lhs rhs = do + (lhs2, rhs2) <- liftM normalizePBLinExactly $ instantiatePB solver (lhs,rhs) + addPBAtLeastSoft solver sel lhs2 rhs2 + addPBAtMostSoft solver sel lhs2 rhs2 + +-- | Add a parity constraint /l1 ⊕ l2 ⊕ … ⊕ ln = rhs/ +addXORClause + :: Solver -- ^ The 'Solver' argument. + -> [Lit] -- ^ literals @[l1, l2, …, ln]@ + -> Bool -- ^ /rhs/ + -> IO () +addXORClause solver lits rhs = do + d <- readIORef (svLevel solver) + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + xcl <- instantiateXORClause solver (lits,rhs) + case normalizeXORClause xcl of + ([], True) -> markBad solver + ([], False) -> return () + ([l], b) -> addClause solver [if b then l else litNot l] + (l:ls, b) -> do + c <- newXORClauseHandler ((if b then l else litNot l) : ls) False + addToDB solver c + _ <- basicAttachXORClauseHandler solver c + return () + +-- | Add a soft parity constraint /lit ⇒ l1 ⊕ l2 ⊕ … ⊕ ln = rhs/ +addXORClauseSoft + :: Solver -- ^ The 'Solver' argument. + -> Lit -- ^ indicator @lit@ + -> [Lit] -- ^ literals @[l1, l2, …, ln]@ + -> Bool -- ^ /rhs/ + -> IO () +addXORClauseSoft solver ind lits rhs = do + reified <- newVar solver + addXORClause solver (litNot reified : lits) rhs + addClause solver [litNot ind, reified] -- ind ⇒ reified + +{-------------------------------------------------------------------- + Problem solving +--------------------------------------------------------------------} + +-- | Solve constraints. +-- Returns 'True' if the problem is SATISFIABLE. +-- Returns 'False' if the problem is UNSATISFIABLE. +solve :: Solver -> IO Bool +solve solver = do + as <- newArray_ (0,-1) + writeIORef (svAssumptions solver) as + solve_ solver + +-- | Solve constraints under assuptions. +-- Returns 'True' if the problem is SATISFIABLE. +-- Returns 'False' if the problem is UNSATISFIABLE. +solveWith :: Solver + -> [Lit] -- ^ Assumptions + -> IO Bool +solveWith solver ls = do + as <- newListArray (0, length ls -1) ls + writeIORef (svAssumptions solver) as + solve_ solver + +solve_ :: Solver -> IO Bool +solve_ solver = do + log solver "Solving starts ..." + resetStat solver + writeIORef (svModel solver) Nothing + writeIORef (svFailedAssumptions solver) [] + + ok <- readIORef (svOk solver) + if not ok then + return False + else do + when debugMode $ dumpVarActivity solver + d <- readIORef (svLevel solver) + assert (d == levelRoot) $ return () + + restartStrategy <- readIORef (svRestartStrategy solver) + restartFirst <- readIORef (svRestartFirst solver) + restartInc <- readIORef (svRestartInc solver) + let restartSeq = mkRestartSeq restartStrategy restartFirst restartInc + + let learntSizeAdj = do + (size,adj) <- shift (svLearntLimSeq solver) + writeIORef (svLearntLim solver) size + writeIORef (svLearntLimAdjCnt solver) adj + onConflict = do + cnt <- readIORef (svLearntLimAdjCnt solver) + if (cnt==0) + then learntSizeAdj + else writeIORef (svLearntLimAdjCnt solver) $! cnt-1 + + cnt <- readIORef (svLearntLimAdjCnt solver) + when (cnt == -1) $ do + learntSizeFirst <- readIORef (svLearntSizeFirst solver) + learntSizeInc <- readIORef (svLearntSizeInc solver) + nc <- nConstraints solver + nv <- nVars solver + let initialLearntLim = if learntSizeFirst > 0 then learntSizeFirst else max ((nc + nv) `div` 3) 16 + learntSizeSeq = iterate (ceiling . (learntSizeInc*) . fromIntegral) initialLearntLim + learntSizeAdjSeq = iterate (\x -> (x * 3) `div` 2) (100::Int) + writeIORef (svLearntLimSeq solver) (zip learntSizeSeq learntSizeAdjSeq) + learntSizeAdj + + let loop [] = error "solve_: should not happen" + loop (conflict_lim:rs) = do + printStat solver True + ret <- search solver conflict_lim onConflict + case ret of + SRFinished x -> return $ Just x + SRBudgetExceeded -> return Nothing + SRRestart -> do + modifyIORef' (svNRestart solver) (+1) + backtrackTo solver levelRoot + loop rs + + printStatHeader solver + + startCPU <- getCPUTime + startWC <- getCurrentTime + writeIORef (svStartWC solver) startWC + result <- loop restartSeq + endCPU <- getCPUTime + endWC <- getCurrentTime + + when (result == Just True) $ do + checkModel <- readIORef (svCheckModel solver) + when checkModel $ checkSatisfied solver + constructModel solver + + backtrackTo solver levelRoot + + when debugMode $ dumpVarActivity solver + when debugMode $ dumpConstrActivity solver + printStat solver True + (log solver . printf "#cpu_time = %.3fs") (fromIntegral (endCPU - startCPU) / 10^(12::Int) :: Double) + (log solver . printf "#wall_clock_time = %.3fs") (realToFrac (endWC `diffUTCTime` startWC) :: Double) + (log solver . printf "#decision = %d") =<< readIORef (svNDecision solver) + (log solver . printf "#random_decision = %d") =<< readIORef (svNRandomDecision solver) + (log solver . printf "#conflict = %d") =<< readIORef (svNConflict solver) + (log solver . printf "#restart = %d") =<< readIORef (svNRestart solver) + + case result of + Just x -> return x + Nothing -> throw BudgetExceeded + +data BudgetExceeded = BudgetExceeded + deriving (Show, Typeable) + +instance Exception BudgetExceeded + +data SearchResult + = SRFinished Bool + | SRRestart + | SRBudgetExceeded + +search :: Solver -> Int -> IO () -> IO SearchResult +search solver !conflict_lim onConflict = do + conflictCounter <- newIORef 0 + let + loop :: IO SearchResult + loop = do + sanityCheck solver + conflict <- deduce solver + sanityCheck solver + case conflict of + Just constr -> do + ret <- handleConflict conflictCounter constr + case ret of + Just sr -> return sr + Nothing -> loop + Nothing -> do + lv <- readIORef (svLevel solver) + when (lv == levelRoot) $ simplify solver + checkGC + r <- pickAssumption + case r of + Nothing -> return (SRFinished False) + Just lit + | lit /= litUndef -> decide solver lit >> loop + | otherwise -> do + lit2 <- pickBranchLit solver + if lit2 == litUndef + then return (SRFinished True) + else decide solver lit2 >> loop + loop + + where + checkGC :: IO () + checkGC = do + n <- nLearnt solver + m <- nAssigns solver + learnt_lim <- readIORef (svLearntLim solver) + when (learnt_lim >= 0 && n - m > learnt_lim) $ do + modifyIORef' (svNLearntGC solver) (+1) + reduceDB solver + + pickAssumption :: IO (Maybe Lit) + pickAssumption = do + !as <- readIORef (svAssumptions solver) + !b <- getBounds as + let go = do + d <- readIORef (svLevel solver) + if not (inRange b (d+1)) then + return (Just litUndef) + else do + l <- readArray as (d+1) + val <- litValue solver l + if val == lTrue then do + -- dummy decision level + modifyIORef' (svLevel solver) (+1) + go + else if val == lFalse then do + -- conflict with assumption + core <- analyzeFinal solver l + writeIORef (svFailedAssumptions solver) core + return Nothing + else + return (Just l) + go + + handleConflict :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) + handleConflict conflictCounter constr = do + varDecayActivity solver + constrDecayActivity solver + onConflict + + modifyIORef' (svNConflict solver) (+1) + d <- readIORef (svLevel solver) + + when debugMode $ logIO solver $ do + str <- showConstraintHandler constr + return $ printf "conflict(level=%d): %s" d str + + modifyIORef' conflictCounter (+1) + c <- readIORef conflictCounter + + modifyIORef' (svConfBudget solver) $ \confBudget -> + if confBudget > 0 then confBudget - 1 else confBudget + confBudget <- readIORef (svConfBudget solver) + + when (c `mod` 100 == 0) $ do + printStat solver False + + if d == levelRoot then do + markBad solver + return $ Just (SRFinished False) + else if confBudget==0 then + return $ Just SRBudgetExceeded + else if conflict_lim >= 0 && c >= conflict_lim then + return $ Just SRRestart + else do + strat <- readIORef (svLearningStrategy solver) + case strat of + LearningClause -> learnClause constr >> return Nothing + LearningHybrid -> learnHybrid conflictCounter constr + + learnClause :: SomeConstraintHandler -> IO () + learnClause constr = do + (learntClause, level) <- analyzeConflict solver constr + backtrackTo solver level + case learntClause of + [] -> error "search(LearningClause): should not happen" + [lit] -> do + ret <- assign solver lit + assert ret $ return () + return () + lit:_ -> do + cl <- newClauseHandler learntClause True + addToLearntDB solver cl + basicAttachClauseHandler solver cl + assignBy solver lit cl + constrBumpActivity solver cl + + learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) + learnHybrid conflictCounter constr = do + ((learntClause, clauseLevel), (pb, pbLevel)) <- analyzeConflictHybrid solver constr + let minLevel = min clauseLevel pbLevel + backtrackTo solver minLevel + + case learntClause of + [] -> error "search(LearningHybrid): should not happen" + [lit] -> do + _ <- assign solver lit -- This should always succeed. + return () + lit:_ -> do + cl <- newClauseHandler learntClause True + addToLearntDB solver cl + basicAttachClauseHandler solver cl + constrBumpActivity solver cl + when (minLevel == clauseLevel) $ do + _ <- assignBy solver lit cl -- This should always succeed. + return () + + ret <- deduce solver + case ret of + Just conflicted -> do + handleConflict conflictCounter conflicted + -- TODO: should also learn the PB constraint? + Nothing -> do + let (lhs,rhs) = pb + h <- newPBHandlerPromoted solver lhs rhs True + case h of + CHClause _ -> do + {- We don't want to add additional clause, + since it would be subsumed by already added one. -} + return Nothing + _ -> do + addToLearntDB solver h + ret2 <- attach solver h + constrBumpActivity solver h + if ret2 then + return Nothing + else + handleConflict conflictCounter h + +-- | After 'solve' returns True, it returns an satisfying assignment. +getModel :: Solver -> IO Model +getModel solver = do + m <- readIORef (svModel solver) + return (fromJust m) + +-- | After 'solveWith' returns False, it returns a set of assumptions +-- that leads to contradiction. In particular, if it returns an empty +-- set, the problem is unsatisiable without any assumptions. +getFailedAssumptions :: Solver -> IO [Lit] +getFailedAssumptions solver = readIORef (svFailedAssumptions solver) + +{-------------------------------------------------------------------- + Simplification +--------------------------------------------------------------------} + +-- | Simplify the constraint database according to the current top-level assigment. +simplify :: Solver -> IO () +simplify solver = do + let loop [] rs !n = return (rs,n) + loop (y:ys) rs !n = do + b1 <- isSatisfied solver y + b2 <- isLocked solver y + if b1 && not b2 then do + detach solver y + loop ys rs (n+1) + else loop ys (y:rs) n + + -- simplify original constraint DB + do + xs <- readIORef (svConstrDB solver) + (ys,n) <- loop xs [] (0::Int) + modifyIORef' (svNRemovedConstr solver) (+n) + writeIORef (svConstrDB solver) ys + + -- simplify learnt constraint DB + do + (m,xs) <- readIORef (svLearntDB solver) + (ys,n) <- loop xs [] (0::Int) + writeIORef (svLearntDB solver) (m-n, ys) + +{- +References: +L. Zhang, "On subsumption removal and On-the-Fly CNF simplification," +Theory and Applications of Satisfiability Testing (2005), pp. 482-489. +-} + +checkForwardSubsumption :: Solver -> Clause -> IO Bool +checkForwardSubsumption solver lits = do + flag <- getEnableForwardSubsumptionRemoval solver + if not flag then + return False + else do + withEnablePhaseSaving solver False $ do + bracket_ + (modifyIORef' (svLevel solver) (+1)) + (backtrackTo solver levelRoot) $ do + b <- allM (\lit -> assign solver (litNot lit)) lits + if b then + liftM isJust (deduce solver) + else do + when debugMode $ log solver ("forward subsumption: " ++ show lits) + return True + where + withEnablePhaseSaving solver flag m = + bracket + (getEnablePhaseSaving solver) + (setEnablePhaseSaving solver) + (\_ -> setEnablePhaseSaving solver flag >> m) + +removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO () +removeBackwardSubsumedBy solver pb = do + flag <- getEnableBackwardSubsumptionRemoval solver + when flag $ do + xs <- backwardSubsumedBy solver pb + when debugMode $ do + forM_ (HashSet.toList xs) $ \c -> do + s <- showConstraintHandler c + log solver (printf "backward subsumption: %s is subsumed by %s\n" s (show pb)) + removeConstraintHandlers solver xs + +backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler) +backwardSubsumedBy solver pb@(lhs,_) = do + xs <- forM lhs $ \(_,lit) -> do + ld <- litData solver lit + readIORef (ldOccurList ld) + case xs of + [] -> return HashSet.empty + s:ss -> do + let p c = do + -- Note that @isPBRepresentable c@ is always True here, + -- because only such constraints are added to occur list. + -- See 'addToDB'. + pb2 <- instantiatePB solver =<< toPBLinAtLeast c + return $ pbSubsume pb pb2 + liftM HashSet.fromList + $ filterM p + $ HashSet.toList + $ foldl' HashSet.intersection s ss + +removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO () +removeConstraintHandlers _ zs | HashSet.null zs = return () +removeConstraintHandlers solver zs = do + let loop [] rs !n = return (rs,n) + loop (c:cs) rs !n = do + if c `HashSet.member` zs then do + detach solver c + loop cs rs (n+1) + else loop cs (c:rs) n + xs <- readIORef (svConstrDB solver) + (ys,n) <- loop xs [] (0::Int) + modifyIORef' (svNRemovedConstr solver) (+n) + writeIORef (svConstrDB solver) ys + +{-------------------------------------------------------------------- + Parameter settings. +--------------------------------------------------------------------} + +setRestartStrategy :: Solver -> RestartStrategy -> IO () +setRestartStrategy solver s = writeIORef (svRestartStrategy solver) s + +-- | default value for @RestartStrategy@. +defaultRestartStrategy :: RestartStrategy +defaultRestartStrategy = MiniSATRestarts + +-- | The initial restart limit. (default 100) +-- Negative value is used to disable restart. +setRestartFirst :: Solver -> Int -> IO () +setRestartFirst solver !n = writeIORef (svRestartFirst solver) n + +-- | default value for @RestartFirst@. +defaultRestartFirst :: Int +defaultRestartFirst = 100 + +-- | The factor with which the restart limit is multiplied in each restart. (default 1.5) +setRestartInc :: Solver -> Double -> IO () +setRestartInc solver !r = writeIORef (svRestartInc solver) r + +-- | default value for @RestartInc@. +defaultRestartInc :: Double +defaultRestartInc = 1.5 + +data LearningStrategy + = LearningClause + | LearningHybrid + +setLearningStrategy :: Solver -> LearningStrategy -> IO () +setLearningStrategy solver l = writeIORef (svLearningStrategy solver) $! l + +defaultLearningStrategy :: LearningStrategy +defaultLearningStrategy = LearningClause + +-- | The initial limit for learnt clauses. +setLearntSizeFirst :: Solver -> Int -> IO () +setLearntSizeFirst solver !x = writeIORef (svLearntSizeFirst solver) x + +-- | default value for @LearntSizeFirst@. +defaultLearntSizeFirst :: Int +defaultLearntSizeFirst = -1 + +-- | The limit for learnt clauses is multiplied with this factor each restart. (default 1.1) +setLearntSizeInc :: Solver -> Double -> IO () +setLearntSizeInc solver !r = writeIORef (svLearntSizeInc solver) r + +-- | default value for @LearntSizeInc@. +defaultLearntSizeInc :: Double +defaultLearntSizeInc = 1.1 + +-- | The limit for learnt clauses is multiplied with this factor each restart. (default 1.1) +setCCMin :: Solver -> Int -> IO () +setCCMin solver !v = writeIORef (svCCMin solver) v + +-- | default value for @CCMin@. +defaultCCMin :: Int +defaultCCMin = 2 + +-- | The default polarity of a variable. +setVarPolarity :: Solver -> Var -> Bool -> IO () +setVarPolarity solver v val = do + vd <- varData solver v + writeIORef (vdPolarity vd) val + +setCheckModel :: Solver -> Bool -> IO () +setCheckModel solver flag = do + writeIORef (svCheckModel solver) flag + +-- | The frequency with which the decision heuristic tries to choose a random variable +setRandomFreq :: Solver -> Double -> IO () +setRandomFreq solver r = do + writeIORef (svRandomFreq solver) r + +defaultRandomFreq :: Double +defaultRandomFreq = 0.005 + +-- | Set random generator used by the random variable selection +setRandomGen :: Solver -> Rand.StdGen -> IO () +setRandomGen solver = writeIORef (svRandomGen solver) + +-- | Get random generator used by the random variable selection +getRandomGen :: Solver -> IO Rand.StdGen +getRandomGen solver = readIORef (svRandomGen solver) + +setConfBudget :: Solver -> Maybe Int -> IO () +setConfBudget solver (Just b) | b >= 0 = writeIORef (svConfBudget solver) b +setConfBudget solver _ = writeIORef (svConfBudget solver) (-1) + +data PBHandlerType = PBHandlerTypeCounter | PBHandlerTypePueblo + deriving (Show, Eq, Ord) + +defaultPBHandlerType :: PBHandlerType +defaultPBHandlerType = PBHandlerTypeCounter + +setPBHandlerType :: Solver -> PBHandlerType -> IO () +setPBHandlerType solver ht = do + writeIORef (svPBHandlerType solver) ht + +setEnablePhaseSaving :: Solver -> Bool -> IO () +setEnablePhaseSaving solver flag = do + writeIORef (svEnablePhaseSaving solver) flag + +getEnablePhaseSaving :: Solver -> IO Bool +getEnablePhaseSaving solver = do + readIORef (svEnablePhaseSaving solver) + +defaultEnablePhaseSaving :: Bool +defaultEnablePhaseSaving = True + +setEnableForwardSubsumptionRemoval :: Solver -> Bool -> IO () +setEnableForwardSubsumptionRemoval solver flag = do + writeIORef (svEnableForwardSubsumptionRemoval solver) flag + +getEnableForwardSubsumptionRemoval :: Solver -> IO Bool +getEnableForwardSubsumptionRemoval solver = do + readIORef (svEnableForwardSubsumptionRemoval solver) + +defaultEnableForwardSubsumptionRemoval :: Bool +defaultEnableForwardSubsumptionRemoval = False + +setEnableBackwardSubsumptionRemoval :: Solver -> Bool -> IO () +setEnableBackwardSubsumptionRemoval solver flag = do + writeIORef (svEnableBackwardSubsumptionRemoval solver) flag + +getEnableBackwardSubsumptionRemoval :: Solver -> IO Bool +getEnableBackwardSubsumptionRemoval solver = do + readIORef (svEnableBackwardSubsumptionRemoval solver) + +defaultEnableBackwardSubsumptionRemoval :: Bool +defaultEnableBackwardSubsumptionRemoval = False + +{-------------------------------------------------------------------- + API for implementation of @solve@ +--------------------------------------------------------------------} + +pickBranchLit :: Solver -> IO Lit +pickBranchLit !solver = do + let vqueue = svVarQueue solver + + -- Random decision + let withRandGen :: (Rand.StdGen -> (a, Rand.StdGen)) -> IO a + withRandGen f = do + randgen <- readIORef (svRandomGen solver) + let (r, randgen') = f randgen + writeIORef (svRandomGen solver) randgen' + return r + !randfreq <- readIORef (svRandomFreq solver) + !size <- PQ.queueSize vqueue + !r <- withRandGen Rand.random + var <- + if (r < randfreq && size >= 2) then do + a <- PQ.getHeapArray vqueue + i <- withRandGen $ Rand.randomR (0, size-1) + var <- readArray a i + val <- varValue solver var + if val == lUndef then do + modifyIORef' (svNRandomDecision solver) (1+) + return var + else return litUndef + else + return litUndef + + -- Activity based decision + let loop :: IO Var + loop = do + m <- PQ.dequeue vqueue + case m of + Nothing -> return litUndef + Just var2 -> do + val2 <- varValue solver var2 + if val2 /= lUndef + then loop + else return var2 + var2 <- + if var==litUndef + then loop + else return var + + if var2==litUndef then + return litUndef + else do + vd <- varData solver var2 + -- TODO: random polarity + p <- readIORef (vdPolarity vd) + return $! literal var2 p + +decide :: Solver -> Lit -> IO () +decide solver !lit = do + modifyIORef' (svNDecision solver) (+1) + modifyIORef' (svLevel solver) (+1) + when debugMode $ do + val <- litValue solver lit + when (val /= lUndef) $ error "decide: should not happen" + assign solver lit + return () + +deduce :: Solver -> IO (Maybe SomeConstraintHandler) +deduce solver = loop + where + loop :: IO (Maybe SomeConstraintHandler) + loop = do + r <- bcpDequeue solver + case r of + Nothing -> return Nothing + Just lit -> do + ret <- processLit lit + case ret of + Just _ -> return ret + Nothing -> do + ret <- processVar (litVar lit) + case ret of + Just _ -> return ret + Nothing -> loop + + processLit :: Lit -> IO (Maybe SomeConstraintHandler) + processLit !lit = do + let falsifiedLit = litNot lit + ld <- litData solver falsifiedLit + let wsref = ldWatches ld + let loop2 [] = return Nothing + loop2 (w:ws) = do + ok <- propagate solver w falsifiedLit + if ok then + loop2 ws + else do + modifyIORef wsref (++ws) + return (Just w) + ws <- readIORef wsref + writeIORef wsref [] + loop2 ws + + processVar :: Lit -> IO (Maybe SomeConstraintHandler) + processVar !lit = do + let falsifiedLit = litNot lit + vd <- varData solver (litVar lit) + let wsref = vdWatches vd + let loop2 [] = return Nothing + loop2 (w:ws) = do + ok <- propagate solver w falsifiedLit + if ok + then loop2 ws + else do + modifyIORef wsref (++ws) + return (Just w) + ws <- readIORef wsref + writeIORef wsref [] + loop2 ws + +analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level) +analyzeConflict solver constr = do + d <- readIORef (svLevel solver) + + let split :: [Lit] -> IO (LitSet, LitSet) + split = go (IS.empty, IS.empty) + where + go (xs,ys) [] = return (xs,ys) + go (xs,ys) (l:ls) = do + lv <- litLevel solver l + if lv == levelRoot then + go (xs,ys) ls + else if lv >= d then + go (IS.insert l xs, ys) ls + else + go (xs, IS.insert l ys) ls + + let loop :: LitSet -> LitSet -> IO LitSet + loop lits1 lits2 + | sz==1 = do + return $ lits1 `IS.union` lits2 + | sz>=2 = do + l <- popTrail solver + if litNot l `IS.notMember` lits1 then do + unassign solver (litVar l) + loop lits1 lits2 + else do + m <- varReason solver (litVar l) + case m of + Nothing -> error "analyzeConflict: should not happen" + Just constr2 -> do + constrBumpActivity solver constr2 + xs <- reasonOf solver constr2 (Just l) + forM_ xs $ \lit -> varBumpActivity solver (litVar lit) + unassign solver (litVar l) + (ys,zs) <- split xs + loop (IS.delete (litNot l) lits1 `IS.union` ys) + (lits2 `IS.union` zs) + | otherwise = error "analyzeConflict: should not happen: reason of current level is empty" + where + sz = IS.size lits1 + + constrBumpActivity solver constr + conflictClause <- reasonOf solver constr Nothing + forM_ conflictClause $ \lit -> varBumpActivity solver (litVar lit) + (ys,zs) <- split conflictClause + lits <- loop ys zs + + lits2 <- minimizeConflictClause solver lits + + xs <- liftM (sortBy (flip (comparing snd))) $ + forM (IS.toList lits2) $ \l -> do + lv <- litLevel solver l + return (l,lv) + + let level = case xs of + [] -> error "analyzeConflict: should not happen" + [_] -> levelRoot + _:(_,lv):_ -> lv + return (map fst xs, level) + +-- { p } ∪ { pにfalseを割り当てる原因のassumption } +analyzeFinal :: Solver -> Lit -> IO [Lit] +analyzeFinal solver p = do + lits <- readIORef (svTrail solver) + let go :: [Lit] -> VarSet -> [Lit] -> IO [Lit] + go [] _ result = return result + go (l:ls) seen result = do + lv <- litLevel solver l + if lv == levelRoot then + return result + else if litVar l `IS.member` seen then do + r <- varReason solver (litVar l) + case r of + Nothing -> do + let seen' = IS.delete (litVar l) seen + go ls seen' (l : result) + Just constr -> do + c <- reasonOf solver constr (Just l) + let seen' = IS.delete (litVar l) seen `IS.union` IS.fromList [litVar l2 | l2 <- c] + go ls seen' result + else + go ls seen result + go lits (IS.singleton (litVar p)) [p] + +analyzeConflictHybrid :: ConstraintHandler c => Solver -> c -> IO ((Clause, Level), (PBLinAtLeast, Level)) +analyzeConflictHybrid solver constr = do + d <- readIORef (svLevel solver) + + let split :: [Lit] -> IO (LitSet, LitSet) + split = go (IS.empty, IS.empty) + where + go (xs,ys) [] = return (xs,ys) + go (xs,ys) (l:ls) = do + lv <- litLevel solver l + if lv == levelRoot then + go (xs,ys) ls + else if lv >= d then + go (IS.insert l xs, ys) ls + else + go (xs, IS.insert l ys) ls + + let loop :: LitSet -> LitSet -> PBLinAtLeast -> IO (LitSet, PBLinAtLeast) + loop lits1 lits2 pb + | sz==1 = do + return $ (lits1 `IS.union` lits2, pb) + | sz>=2 = do + l <- popTrail solver + m <- varReason solver (litVar l) + case m of + Nothing -> error "analyzeConflictHybrid: should not happen" + Just constr2 -> do + xs <- reasonOf solver constr2 (Just l) + (lits1',lits2') <- + if litNot l `IS.notMember` lits1 then + return (lits1,lits2) + else do + constrBumpActivity solver constr2 + forM_ xs $ \lit -> varBumpActivity solver (litVar lit) + (ys,zs) <- split xs + return (IS.delete (litNot l) lits1 `IS.union` ys, lits2 `IS.union` zs) + + pb' <- if any (\(_,l2) -> litNot l == l2) (fst pb) + then do + pb2 <- do + b <- isPBRepresentable constr2 + if not b then do + return $ clauseToPBLinAtLeast (l:xs) + else do + pb2 <- toPBLinAtLeast constr2 + o <- pbOverSAT solver pb2 + if o then + return $ clauseToPBLinAtLeast (l:xs) + else + return pb2 + return $ cutResolve pb pb2 (litVar l) + else return pb + + unassign solver (litVar l) + loop lits1' lits2' pb' + + | otherwise = error "analyzeConflictHybrid: should not happen: reason of current level is empty" + where + sz = IS.size lits1 + + constrBumpActivity solver constr + conflictClause <- reasonOf solver constr Nothing + pbConfl <- do + b <- isPBRepresentable constr + if b then + toPBLinAtLeast constr + else + return (clauseToPBLinAtLeast conflictClause) + forM_ conflictClause $ \lit -> varBumpActivity solver (litVar lit) + (ys,zs) <- split conflictClause + (lits, pb) <- loop ys zs pbConfl + + lits2 <- minimizeConflictClause solver lits + + xs <- liftM (sortBy (flip (comparing snd))) $ + forM (IS.toList lits2) $ \l -> do + lv <- litLevel solver l + return (l,lv) + + let level = case xs of + [] -> error "analyzeConflict: should not happen" + [_] -> levelRoot + _:(_,lv):_ -> lv + pblevel <- pbBacktrackLevel solver pb + return ((map fst xs, level), (pb, pblevel)) + +pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level +pbBacktrackLevel _ ([], rhs) = assert (rhs > 0) $ return levelRoot +pbBacktrackLevel solver (lhs, rhs) = do + levelToLiterals <- liftM (IM.unionsWith IM.union) $ forM lhs $ \(_,lit) -> do + val <- litValue solver lit + if val /= lUndef then do + level <- litLevel solver lit + return $ IM.singleton level (IM.singleton lit val) + else + return $ IM.empty + + let replay [] _ _ = error "pbBacktrackLevel: should not happen" + replay ((lv,lv_lits) : lvs) lhs slack = do + let slack_lv = slack - sum [c | (c,lit) <- lhs, IM.lookup lit lv_lits == Just lFalse] + lhs_lv = [tm | tm@(_,lit) <- lhs, IM.notMember lit lv_lits] + if slack_lv < 0 then + return lv -- CONFLICT + else if any (\(c,_) -> c > slack_lv) lhs_lv then + return lv -- UNIT + else + replay lvs lhs_lv slack_lv + + let initial_slack = sum [c | (c,_) <- lhs] - rhs + replay (IM.toList levelToLiterals) lhs initial_slack + +minimizeConflictClause :: Solver -> LitSet -> IO LitSet +minimizeConflictClause solver lits = do + ccmin <- readIORef (svCCMin solver) + if ccmin >= 2 then + minimizeConflictClauseRecursive solver lits + else if ccmin >= 1 then + minimizeConflictClauseLocal solver lits + else + return lits + +minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet +minimizeConflictClauseLocal solver lits = do + let xs = IS.toAscList lits + ys <- filterM (liftM not . isRedundant) xs + when debugMode $ do + log solver "minimizeConflictClauseLocal:" + log solver $ show xs + log solver $ show ys + return $ IS.fromAscList $ ys + + where + isRedundant :: Lit -> IO Bool + isRedundant lit = do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls <- reasonOf solver c2 (Just (litNot lit)) + allM test ls + + test :: Lit -> IO Bool + test lit = do + lv <- litLevel solver lit + return $ lv == levelRoot || lit `IS.member` lits + +minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet +minimizeConflictClauseRecursive solver lits = do + let + isRedundant :: Lit -> IO Bool + isRedundant lit = do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls <- reasonOf solver c2 (Just (litNot lit)) + go ls IS.empty + + go :: [Lit] -> IS.IntSet -> IO Bool + go [] _ = return True + go (lit : ls) seen = do + lv <- litLevel solver lit + if lv == levelRoot || lit `IS.member` lits || lit `IS.member` seen then + go ls seen + else do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls2 <- reasonOf solver c2 (Just (litNot lit)) + go (ls2 ++ ls) (IS.insert lit seen) + + let xs = IS.toAscList lits + ys <- filterM (liftM not . isRedundant) xs + when debugMode $ do + log solver "minimizeConflictClauseRecursive:" + log solver $ show xs + log solver $ show ys + return $ IS.fromAscList $ ys + +popTrail :: Solver -> IO Lit +popTrail solver = do + m <- readIORef (svTrail solver) + case m of + [] -> error "ToySolver.SAT.popTrail: empty trail" + l:ls -> do + writeIORef (svTrail solver) ls + return l + +-- | Revert to the state at given level +-- (keeping all assignment at @level@ but not beyond). +backtrackTo :: Solver -> Int -> IO () +backtrackTo solver level = do + when debugMode $ log solver $ printf "backtrackTo: %d" level + writeIORef (svTrail solver) =<< loop =<< readIORef (svTrail solver) + SQ.clear (svBCPQueue solver) + writeIORef (svLevel solver) level + where + loop :: [Lit] -> IO [Lit] + loop [] = return [] + loop lls@(l:ls) = do + lv <- litLevel solver l + if lv <= level + then return lls + else unassign solver (litVar l) >> loop ls + +constructModel :: Solver -> IO () +constructModel solver = do + n <- nVars solver + (marr::IOUArray Var Bool) <- newArray_ (1,n) + forLoop 1 (<=n) (+1) $ \v -> do + vd <- varData solver v + a <- readIORef (vdAssignment vd) + writeArray marr v (aValue (fromJust a)) + m <- unsafeFreeze marr + writeIORef (svModel solver) (Just m) + +constrDecayActivity :: Solver -> IO () +constrDecayActivity solver = do + d <- readIORef (svConstrDecay solver) + modifyIORef' (svConstrInc solver) (d*) + +constrBumpActivity :: ConstraintHandler a => Solver -> a -> IO () +constrBumpActivity solver this = do + aval <- constrReadActivity this + when (aval >= 0) $ do -- learnt clause + inc <- readIORef (svConstrInc solver) + let aval2 = aval+inc + constrWriteActivity this $! aval2 + when (aval2 > 1e20) $ + -- Rescale + constrRescaleAllActivity solver + +constrRescaleAllActivity :: Solver -> IO () +constrRescaleAllActivity solver = do + xs <- learntConstraints solver + forM_ xs $ \c -> do + aval <- constrReadActivity c + when (aval >= 0) $ + constrWriteActivity c $! (aval * 1e-20) + modifyIORef' (svConstrInc solver) (* 1e-20) + +resetStat :: Solver -> IO () +resetStat solver = do + writeIORef (svNDecision solver) 0 + writeIORef (svNRandomDecision solver) 0 + writeIORef (svNConflict solver) 0 + writeIORef (svNRestart solver) 0 + writeIORef (svNLearntGC solver) 0 + +printStatHeader :: Solver -> IO () +printStatHeader solver = do + log solver $ "============================[ Search Statistics ]============================" + log solver $ " Time | Restart | Decision | Conflict | LEARNT | Fixed | Removed " + log solver $ " | | | | Limit GC | Var | Constra " + log solver $ "=============================================================================" + +printStat :: Solver -> Bool -> IO () +printStat solver force = do + nowWC <- getCurrentTime + b <- if force + then return True + else do + lastWC <- readIORef (svLastStatWC solver) + return $ (nowWC `diffUTCTime` lastWC) > 1 + when b $ do + startWC <- readIORef (svStartWC solver) + let tm = showTimeDiff $ nowWC `diffUTCTime` startWC + restart <- readIORef (svNRestart solver) + dec <- readIORef (svNDecision solver) + conflict <- readIORef (svNConflict solver) + learntLim <- readIORef (svLearntLim solver) + learntGC <- readIORef (svNLearntGC solver) + fixed <- readIORef (svNFixed solver) + removed <- readIORef (svNRemovedConstr solver) + log solver $ printf "%s | %7d | %8d | %8d | %8d %6d | %8d | %8d" + tm restart dec conflict learntLim learntGC fixed removed + writeIORef (svLastStatWC solver) nowWC + +showTimeDiff :: NominalDiffTime -> String +showTimeDiff sec + | si < 100 = printf "%4.1fs" (fromRational s :: Double) + | si <= 9999 = printf "%4ds" si + | mi < 100 = printf "%4.1fm" (fromRational m :: Double) + | mi <= 9999 = printf "%4dm" mi + | hi < 100 = printf "%4.1fs" (fromRational h :: Double) + | otherwise = printf "%4dh" hi + where + s :: Rational + s = realToFrac sec + + si :: Integer + si = round s + + m :: Rational + m = s / 60 + + mi :: Integer + mi = round m + + h :: Rational + h = m / 60 + + hi :: Integer + hi = round h + +{-------------------------------------------------------------------- + constraint implementation +--------------------------------------------------------------------} + +class (Eq a, Hashable a) => ConstraintHandler a where + toConstraintHandler :: a -> SomeConstraintHandler + + showConstraintHandler :: a -> IO String + + attach :: Solver -> a -> IO Bool + + watchedLiterals :: Solver -> a -> IO [Lit] + + watchedVariables :: Solver -> a -> IO [Var] + + -- | invoked with the watched literal when the literal is falsified. + -- 'watch' で 'toConstraint' を呼び出して heap allocation が発生するのを + -- 避けるために、元の 'SomeConstraintHandler' も渡しておく。 + basicPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool + + -- | deduce a clause C∨l from the constraint and return C. + -- C and l should be false and true respectively under the current + -- assignment. + basicReasonOf :: Solver -> a -> Maybe Lit -> IO Clause + + isPBRepresentable :: a -> IO Bool + toPBLinAtLeast :: a -> IO PBLinAtLeast + + isSatisfied :: Solver -> a -> IO Bool + + constrIsProtected :: Solver -> a -> IO Bool + constrIsProtected _ _ = return False + + constrWeight :: Solver -> a -> IO Double + constrWeight _ _ = return 1.0 + + constrReadActivity :: a -> IO Double + + constrWriteActivity :: a -> Double -> IO () + +detach :: Solver -> SomeConstraintHandler -> IO () +detach solver c = do + lits <- watchedLiterals solver c + forM_ lits $ \lit -> do + ld <- litData solver lit + modifyIORef' (ldWatches ld) (delete c) + vs <- watchedVariables solver c + forM_ vs $ \v -> do + vd <- varData solver v + modifyIORef' (vdWatches vd) (delete c) + + b <- isPBRepresentable c + when b $ do + (lhs,_) <- toPBLinAtLeast c + forM_ lhs $ \(_,lit) -> do + ld <- litData solver lit + modifyIORef' (ldOccurList ld) (HashSet.delete c) + +-- | invoked with the watched literal when the literal is falsified. +propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool +propagate solver c l = basicPropagate solver c c l + +-- | deduce a clause C∨l from the constraint and return C. +-- C and l should be false and true respectively under the current +-- assignment. +reasonOf :: ConstraintHandler a => Solver -> a -> Maybe Lit -> IO Clause +reasonOf solver c x = do + when debugMode $ + case x of + Nothing -> return () + Just lit -> do + val <- litValue solver lit + unless (lTrue == val) $ do + str <- showConstraintHandler c + error (printf "reasonOf: value of literal %d should be True but %s (basicReasonOf %s %s)" lit (show val) str (show x)) + cl <- basicReasonOf solver c x + when debugMode $ do + forM_ cl $ \lit -> do + val <- litValue solver lit + unless (lFalse == val) $ do + str <- showConstraintHandler c + error (printf "reasonOf: value of literal %d should be False but %s (basicReasonOf %s %s)" lit (show val) str (show x)) + return cl + +isLocked :: Solver -> SomeConstraintHandler -> IO Bool +isLocked solver c = do + b1 <- anyM p1 =<< watchedLiterals solver c + b2 <- anyM p2 =<< watchedVariables solver c + return $ b1 || b2 + where + p1 :: Lit -> IO Bool + p1 lit = do + val <- litValue solver lit + if val /= lTrue then return False + else do + m <- varReason solver (litVar lit) + case m of + Nothing -> return False + Just c2 -> return $! c == c2 + p2 :: Var -> IO Bool + p2 var = do + val <- varValue solver var + if val == lUndef then return False + else do + m <- varReason solver var + case m of + Nothing -> return False + Just c2 -> return $! c == c2 + +data SomeConstraintHandler + = CHClause !ClauseHandler + | CHAtLeast !AtLeastHandler + | CHPBCounter !PBHandlerCounter + | CHPBPueblo !PBHandlerPueblo + | CHXORClause !XORClauseHandler + deriving Eq + +instance Hashable SomeConstraintHandler where + hashWithSalt s (CHClause c) = s `hashWithSalt` (0::Int) `hashWithSalt` c + hashWithSalt s (CHAtLeast c) = s `hashWithSalt` (1::Int) `hashWithSalt` c + hashWithSalt s (CHPBCounter c) = s `hashWithSalt` (2::Int) `hashWithSalt` c + hashWithSalt s (CHPBPueblo c) = s `hashWithSalt` (3::Int) `hashWithSalt` c + hashWithSalt s (CHXORClause c) = s `hashWithSalt` (4::Int) `hashWithSalt` c + +instance ConstraintHandler SomeConstraintHandler where + toConstraintHandler = id + + showConstraintHandler (CHClause c) = showConstraintHandler c + showConstraintHandler (CHAtLeast c) = showConstraintHandler c + showConstraintHandler (CHPBCounter c) = showConstraintHandler c + showConstraintHandler (CHPBPueblo c) = showConstraintHandler c + showConstraintHandler (CHXORClause c) = showConstraintHandler c + + attach solver (CHClause c) = attach solver c + attach solver (CHAtLeast c) = attach solver c + attach solver (CHPBCounter c) = attach solver c + attach solver (CHPBPueblo c) = attach solver c + attach solver (CHXORClause c) = attach solver c + + watchedLiterals solver (CHClause c) = watchedLiterals solver c + watchedLiterals solver (CHAtLeast c) = watchedLiterals solver c + watchedLiterals solver (CHPBCounter c) = watchedLiterals solver c + watchedLiterals solver (CHPBPueblo c) = watchedLiterals solver c + watchedLiterals solver (CHXORClause c) = watchedLiterals solver c + + watchedVariables solver (CHClause c) = watchedVariables solver c + watchedVariables solver (CHAtLeast c) = watchedVariables solver c + watchedVariables solver (CHPBCounter c) = watchedVariables solver c + watchedVariables solver (CHPBPueblo c) = watchedVariables solver c + watchedVariables solver (CHXORClause c) = watchedVariables solver c + + basicPropagate solver this (CHClause c) lit = basicPropagate solver this c lit + basicPropagate solver this (CHAtLeast c) lit = basicPropagate solver this c lit + basicPropagate solver this (CHPBCounter c) lit = basicPropagate solver this c lit + basicPropagate solver this (CHPBPueblo c) lit = basicPropagate solver this c lit + basicPropagate solver this (CHXORClause c) lit = basicPropagate solver this c lit + + basicReasonOf solver (CHClause c) l = basicReasonOf solver c l + basicReasonOf solver (CHAtLeast c) l = basicReasonOf solver c l + basicReasonOf solver (CHPBCounter c) l = basicReasonOf solver c l + basicReasonOf solver (CHPBPueblo c) l = basicReasonOf solver c l + basicReasonOf solver (CHXORClause c) l = basicReasonOf solver c l + + isPBRepresentable (CHClause c) = isPBRepresentable c + isPBRepresentable (CHAtLeast c) = isPBRepresentable c + isPBRepresentable (CHPBCounter c) = isPBRepresentable c + isPBRepresentable (CHPBPueblo c) = isPBRepresentable c + isPBRepresentable (CHXORClause c) = isPBRepresentable c + + toPBLinAtLeast (CHClause c) = toPBLinAtLeast c + toPBLinAtLeast (CHAtLeast c) = toPBLinAtLeast c + toPBLinAtLeast (CHPBCounter c) = toPBLinAtLeast c + toPBLinAtLeast (CHPBPueblo c) = toPBLinAtLeast c + toPBLinAtLeast (CHXORClause c) = toPBLinAtLeast c + + isSatisfied solver (CHClause c) = isSatisfied solver c + isSatisfied solver (CHAtLeast c) = isSatisfied solver c + isSatisfied solver (CHPBCounter c) = isSatisfied solver c + isSatisfied solver (CHPBPueblo c) = isSatisfied solver c + isSatisfied solver (CHXORClause c) = isSatisfied solver c + + constrIsProtected solver (CHClause c) = constrIsProtected solver c + constrIsProtected solver (CHAtLeast c) = constrIsProtected solver c + constrIsProtected solver (CHPBCounter c) = constrIsProtected solver c + constrIsProtected solver (CHPBPueblo c) = constrIsProtected solver c + constrIsProtected solver (CHXORClause c) = constrIsProtected solver c + + constrReadActivity (CHClause c) = constrReadActivity c + constrReadActivity (CHAtLeast c) = constrReadActivity c + constrReadActivity (CHPBCounter c) = constrReadActivity c + constrReadActivity (CHPBPueblo c) = constrReadActivity c + constrReadActivity (CHXORClause c) = constrReadActivity c + + constrWriteActivity (CHClause c) aval = constrWriteActivity c aval + constrWriteActivity (CHAtLeast c) aval = constrWriteActivity c aval + constrWriteActivity (CHPBCounter c) aval = constrWriteActivity c aval + constrWriteActivity (CHPBPueblo c) aval = constrWriteActivity c aval + constrWriteActivity (CHXORClause c) aval = constrWriteActivity c aval + +-- To avoid heap-allocation Maybe value, it returns -1 when not found. +findForWatch :: Solver -> IOUArray Int Lit -> Int -> Int -> IO Int +#ifndef __GLASGOW_HASKELL__ +findForWatch solver a beg end = go beg end + where + go :: Int -> Int -> IO Int + go i end | i > end = return (-1) + go i end = do + val <- litValue s =<< unsafeRead a i + if val /= lFalse + then return i + else go (i+1) end +#else +{- We performed worker-wrapper transfomation manually, since the worker + generated by GHC has type + "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", + not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". + We want latter one to avoid heap-allocating Int value. -} +findForWatch solver a (I# beg) (I# end) = IO $ \w -> + case go# beg end w of + (# w2, ret #) -> (# w2, I# ret #) + where + go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) +#if __GLASGOW_HASKELL__ < 708 + go# i end w | i ># end = (# w, -1# #) +#else + go# i end w | isTrue# (i ># end) = (# w, -1# #) +#endif + go# i end w = + case unIO (litValue solver =<< unsafeRead a (I# i)) w of + (# w2, val #) -> + if val /= lFalse + then (# w2, i #) + else go# (i +# 1#) end w2 + + unIO (IO f) = f +#endif + +-- To avoid heap-allocating Maybe value, it returns -1 when not found. +findForWatch2 :: Solver -> IOUArray Int Lit -> Int -> Int -> IO Int +#ifndef __GLASGOW_HASKELL__ +findForWatch2 solver a beg end = go beg end + where + go :: Int -> Int -> IO Int + go i end | i > end = return (-1) + go i end = do + val <- litValue s =<< unsafeRead a i + if val == lUndef + then return i + else go (i+1) end +#else +{- We performed worker-wrapper transfomation manually, since the worker + generated by GHC has type + "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", + not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". + We want latter one to avoid heap-allocating Int value. -} +findForWatch2 solver a (I# beg) (I# end) = IO $ \w -> + case go# beg end w of + (# w2, ret #) -> (# w2, I# ret #) + where + go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) +#if __GLASGOW_HASKELL__ < 708 + go# i end w | i ># end = (# w, -1# #) +#else + go# i end w | isTrue# (i ># end) = (# w, -1# #) +#endif + go# i end w = + case unIO (litValue solver =<< unsafeRead a (I# i)) w of + (# w2, val #) -> + if val == lUndef + then (# w2, i #) + else go# (i +# 1#) end w2 + + unIO (IO f) = f +#endif + +{-------------------------------------------------------------------- + Clause +--------------------------------------------------------------------} + +data ClauseHandler + = ClauseHandler + { claLits :: !(IOUArray Int Lit) + , claActivity :: !(IORef Double) + , claHash :: !Int + } + +instance Eq ClauseHandler where + (==) = (==) `on` claLits + +instance Hashable ClauseHandler where + hash = claHash + hashWithSalt = defaultHashWithSalt + +newClauseHandler :: Clause -> Bool -> IO ClauseHandler +newClauseHandler ls learnt = do + let size = length ls + a <- newListArray (0, size-1) ls + act <- newIORef $! (if learnt then 0 else -1) + return (ClauseHandler a act (hash ls)) + +instance ConstraintHandler ClauseHandler where + toConstraintHandler = CHClause + + showConstraintHandler this = do + lits <- getElems (claLits this) + return (show lits) + + attach solver this = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + (lb,ub) <- getBounds (claLits this) + assert (lb == 0) $ return () + let size = ub-lb+1 + + if size == 0 then do + markBad solver + return False + else if size == 1 then do + lit0 <- unsafeRead (claLits this) 0 + assignBy solver lit0 this + else do + ref <- newIORef 1 + let f i = do + lit_i <- unsafeRead (claLits this) i + val_i <- litValue solver lit_i + if val_i /= lFalse then + return True + else do + j <- readIORef ref + k <- findForWatch solver (claLits this) j ub + case k of + -1 -> do + return False + _ -> do + lit_k <- unsafeRead (claLits this) k + unsafeWrite (claLits this) i lit_k + unsafeWrite (claLits this) k lit_i + writeIORef ref $! (k+1) + return True + + b <- f 0 + if b then do + lit0 <- unsafeRead (claLits this) 0 + watchLit solver lit0 this + b2 <- f 1 + if b2 then do + lit1 <- unsafeRead (claLits this) 1 + watchLit solver lit1 this + return True + else do -- UNIT + -- We need to watch the most recently falsified literal + (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..ub] $ \l -> do + lit <- unsafeRead (claLits this) l + lv <- litLevel solver lit + return (l,lv) + lit1 <- unsafeRead (claLits this) 1 + liti <- unsafeRead (claLits this) i + unsafeWrite (claLits this) 1 liti + unsafeWrite (claLits this) i lit1 + watchLit solver liti this + assignBy solver lit0 this -- should always succeed + else do -- CONFLICT + ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [lb..ub] $ \l -> do + lit <- unsafeRead (claLits this) l + lv <- litLevel solver lit + return (l,lv) + forM_ (zip [0..] ls) $ \(i,lit) -> do + unsafeWrite (claLits this) i lit + lit0 <- unsafeRead (claLits this) 0 + lit1 <- unsafeRead (claLits this) 1 + watchLit solver lit0 this + watchLit solver lit1 this + return False + + watchedLiterals _ this = do + lits <- getElems (claLits this) + case lits of + l1:l2:_ -> return [l1, l2] + _ -> return [] + + watchedVariables _ _ = return [] + + basicPropagate !solver this this2 !falsifiedLit = do + preprocess + + !lit0 <- unsafeRead a 0 + !val0 <- litValue solver lit0 + if val0 == lTrue then do + watchLit solver falsifiedLit this + return True + else do + (!lb,!ub) <- getBounds a + assert (lb==0) $ return () + i <- findForWatch solver a 2 ub + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "basicPropagate: %s is unit" str + watchLit solver falsifiedLit this + assignBy solver lit0 this + _ -> do + !lit1 <- unsafeRead a 1 + !liti <- unsafeRead a i + unsafeWrite a 1 liti + unsafeWrite a i lit1 + watchLit solver liti this + return True + + where + a = claLits this2 + + preprocess :: IO () + preprocess = do + !l0 <- unsafeRead a 0 + !l1 <- unsafeRead a 1 + assert (l0==falsifiedLit || l1==falsifiedLit) $ return () + when (l0==falsifiedLit) $ do + unsafeWrite a 0 l1 + unsafeWrite a 1 l0 + + basicReasonOf _ this l = do + lits <- getElems (claLits this) + case l of + Nothing -> return lits + Just lit -> do + assert (lit == head lits) $ return () + return $ tail lits + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + lits <- getElems (claLits this) + return ([(1,l) | l <- lits], 1) + + isSatisfied solver this = do + lits <- getElems (claLits this) + vals <- mapM (litValue solver) lits + return $ lTrue `elem` vals + + constrIsProtected _ this = do + size <- liftM rangeSize (getBounds (claLits this)) + return $! size <= 2 + + constrReadActivity this = readIORef (claActivity this) + + constrWriteActivity this aval = writeIORef (claActivity this) $! aval + +instantiateClause :: Solver -> Clause -> IO (Maybe Clause) +instantiateClause solver = loop [] + where + loop :: [Lit] -> [Lit] -> IO (Maybe Clause) + loop ret [] = return $ Just ret + loop ret (l:ls) = do + val <- litValue solver l + if val==lTrue then + return Nothing + else if val==lFalse then + loop ret ls + else + loop (l : ret) ls + +basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool +basicAttachClauseHandler solver this = do + lits <- getElems (claLits this) + case lits of + [] -> do + markBad solver + return False + [l1] -> do + assignBy solver l1 this + l1:l2:_ -> do + watchLit solver l1 this + watchLit solver l2 this + return True + +{-------------------------------------------------------------------- + Cardinality Constraint +--------------------------------------------------------------------} + +data AtLeastHandler + = AtLeastHandler + { atLeastLits :: IOUArray Int Lit + , atLeastNum :: !Int + , atLeastActivity :: !(IORef Double) + , atLeastHash :: !Int + } + +instance Eq AtLeastHandler where + (==) = (==) `on` atLeastLits + +instance Hashable AtLeastHandler where + hash = atLeastHash + hashWithSalt = defaultHashWithSalt + +newAtLeastHandler :: [Lit] -> Int -> Bool -> IO AtLeastHandler +newAtLeastHandler ls n learnt = do + let size = length ls + a <- newListArray (0, size-1) ls + act <- newIORef $! (if learnt then 0 else -1) + return (AtLeastHandler a n act (hash (ls,n))) + +instance ConstraintHandler AtLeastHandler where + toConstraintHandler = CHAtLeast + + showConstraintHandler this = do + lits <- getElems (atLeastLits this) + return $ show lits ++ " >= " ++ show (atLeastNum this) + + -- FIXME: simplify implementation + attach solver this = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + let a = atLeastLits this + (lb,ub) <- getBounds a + assert (lb == 0) $ return () + let m = ub - lb + 1 + n = atLeastNum this + + if m < n then do + markBad solver + return False + else if m == n then do + let f i = do + lit <- unsafeRead a i + assignBy solver lit this + allM f [0..n-1] + else do -- m > n + let f !i !j + | i == n = do + -- NOT VIOLATED: n literals (0 .. n-1) are watched + k <- findForWatch solver a j ub + if k /= -1 then do + -- NOT UNIT + lit_n <- unsafeRead a n + lit_k <- unsafeRead a k + unsafeWrite a n lit_k + unsafeWrite a k lit_n + watchLit solver lit_k this + -- n+1 literals (0 .. n) are watched. + else do + -- UNIT + forLoop 0 ( do + lit <- unsafeRead a l + _ <- assignBy solver lit this -- should always succeed + return () + -- We need to watch the most recently falsified literal + (l,_) <- liftM (maximumBy (comparing snd)) $ forM [n..ub] $ \l -> do + lit <- unsafeRead a l + lv <- litLevel solver lit + when debugMode $ do + val <- litValue solver lit + unless (val == lFalse) $ error "AtLeastHandler.attach: should not happen" + return (l,lv) + lit_n <- unsafeRead a n + lit_l <- unsafeRead a l + unsafeWrite a n lit_l + unsafeWrite a l lit_n + watchLit solver lit_l this + -- n+1 literals (0 .. n) are watched. + return True + | otherwise = do + assert (i < n && n <= j) $ return () + lit_i <- unsafeRead a i + val_i <- litValue solver lit_i + if val_i /= lFalse then do + watchLit solver lit_i this + f (i+1) j + else do + k <- findForWatch solver a j ub + if k /= -1 then do + lit_k <- unsafeRead a k + unsafeWrite a i lit_k + unsafeWrite a k lit_i + watchLit solver lit_k this + f (i+1) (k+1) + else do + -- CONFLICT + -- We need to watch unassigned literals or most recently falsified literals. + do xs <- liftM (sortBy (flip (comparing snd))) $ forM [i..ub] $ \l -> do + lit <- readArray a l + val <- litValue solver lit + if val == lFalse then do + lv <- litLevel solver lit + return (lit, lv) + else do + return (lit, maxBound) + forM_ (zip [i..ub] xs) $ \(l,(lit,_lv)) -> do + writeArray a l lit + forLoop i (<=n) (+1) $ \l -> do + lit_l <- readArray a l + watchLit solver lit_l this + -- n+1 literals (0 .. n) are watched. + return False + f 0 n + + watchedLiterals _ this = do + lits <- getElems (atLeastLits this) + let n = atLeastNum this + let ws = if length lits > n then take (n+1) lits else [] + return ws + + watchedVariables _ _ = return [] + + basicPropagate solver this this2 falsifiedLit = do + preprocess + + when debugMode $ do + litn <- readArray a n + unless (litn == falsifiedLit) $ error "AtLeastHandler.basicPropagate: should not happen" + + (lb,ub) <- getBounds a + assert (lb==0) $ return () + i <- findForWatch solver a (n+1) ub + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "basicPropagate: %s is unit" str + watchLit solver falsifiedLit this + let loop :: Int -> IO Bool + loop i + | i >= n = return True + | otherwise = do + liti <- unsafeRead a i + ret2 <- assignBy solver liti this + if ret2 + then loop (i+1) + else return False + loop 0 + _ -> do + liti <- unsafeRead a i + litn <- unsafeRead a n + unsafeWrite a i litn + unsafeWrite a n liti + watchLit solver liti this + return True + + where + a = atLeastLits this2 + n = atLeastNum this2 + + preprocess :: IO () + preprocess = loop 0 + where + loop :: Int -> IO () + loop i + | i >= n = return () + | otherwise = do + li <- unsafeRead a i + if (li /= falsifiedLit) then + loop (i+1) + else do + ln <- unsafeRead a n + unsafeWrite a n li + unsafeWrite a i ln + + basicReasonOf solver this concl = do + (lb,ub) <- getBounds (atLeastLits this) + assert (lb==0) $ return () + let n = atLeastNum this + falsifiedLits <- mapM (readArray (atLeastLits this)) [n..ub] -- drop first n elements + when debugMode $ do + forM_ falsifiedLits $ \lit -> do + val <- litValue solver lit + unless (val == lFalse) $ do + error $ printf "AtLeastHandler.basicReasonOf: %d is %s (lFalse expected)" lit (show val) + case concl of + Nothing -> do + let go :: Int -> IO Lit + go i + | i >= n = error $ printf "AtLeastHandler.basicReasonOf: cannot find falsified literal in first %d elements" n + | otherwise = do + lit <- readArray (atLeastLits this) i + val <- litValue solver lit + if val == lFalse + then return lit + else go (i+1) + lit <- go lb + return $ lit : falsifiedLits + Just lit -> do + when debugMode $ do + es <- getElems (atLeastLits this) + unless (lit `elem` take n es) $ + error $ printf "AtLeastHandler.basicReasonOf: cannot find %d in first %d elements" n + return falsifiedLits + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + lits <- getElems (atLeastLits this) + return ([(1,l) | l <- lits], fromIntegral (atLeastNum this)) + + isSatisfied solver this = do + lits <- getElems (atLeastLits this) + vals <- mapM (litValue solver) lits + return $ length [v | v <- vals, v == lTrue] >= atLeastNum this + + constrReadActivity this = readIORef (atLeastActivity this) + + constrWriteActivity this aval = writeIORef (atLeastActivity this) $! aval + +instantiateAtLeast :: Solver -> AtLeast -> IO AtLeast +instantiateAtLeast solver (xs,n) = loop ([],n) xs + where + loop :: AtLeast -> [Lit] -> IO AtLeast + loop ret [] = return ret + loop (ys,m) (l:ls) = do + val <- litValue solver l + if val == lTrue then + loop (ys, m-1) ls + else if val == lFalse then + loop (ys, m) ls + else + loop (l:ys, m) ls + +basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool +basicAttachAtLeastHandler solver this = do + lits <- getElems (atLeastLits this) + let m = length lits + n = atLeastNum this + if m < n then do + markBad solver + return False + else if m == n then do + allM (\l -> assignBy solver l this) lits + else do -- m > n + forM_ (take (n+1) lits) $ \l -> watchLit solver l this + return True + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint +--------------------------------------------------------------------} + +newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler +newPBHandler solver ts degree learnt = do + config <- readIORef (svPBHandlerType solver) + case config of + PBHandlerTypeCounter -> do + c <- newPBHandlerCounter ts degree learnt + return (toConstraintHandler c) + PBHandlerTypePueblo -> do + c <- newPBHandlerPueblo ts degree learnt + return (toConstraintHandler c) + +newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler +newPBHandlerPromoted solver lhs rhs learnt = do + case pbToAtLeast (lhs,rhs) of + Nothing -> newPBHandler solver lhs rhs learnt + Just (lhs2, rhs2) -> do + if rhs2 /= 1 then do + h <- newAtLeastHandler lhs2 rhs2 learnt + return $ toConstraintHandler h + else do + h <- newClauseHandler lhs2 learnt + return $ toConstraintHandler h + +instantiatePB :: Solver -> PBLinAtLeast -> IO PBLinAtLeast +instantiatePB solver (xs,n) = loop ([],n) xs + where + loop :: PBLinAtLeast -> PBLinSum -> IO PBLinAtLeast + loop ret [] = return ret + loop (ys,m) ((c,l):ts) = do + val <- litValue solver l + if val == lTrue then + loop (ys, m-c) ts + else if val == lFalse then + loop (ys, m) ts + else + loop ((c,l):ys, m) ts + +pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool +pbOverSAT solver (lhs, rhs) = do + ss <- forM lhs $ \(c,l) -> do + v <- litValue solver l + if v /= lFalse + then return c + else return 0 + return $! sum ss > rhs + +pbToAtLeast :: PBLinAtLeast -> Maybe AtLeast +pbToAtLeast (lhs, rhs) = do + let cs = [c | (c,_) <- lhs] + guard $ Set.size (Set.fromList cs) == 1 + let c = head cs + return $ (map snd lhs, fromInteger ((rhs+c-1) `div` c)) + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint (Counter) +--------------------------------------------------------------------} + +data PBHandlerCounter + = PBHandlerCounter + { pbTerms :: !PBLinSum -- sorted in the decending order on coefficients. + , pbDegree :: !Integer + , pbCoeffMap :: !(LitMap Integer) + , pbMaxSlack :: !Integer + , pbSlack :: !(IORef Integer) + , pbActivity :: !(IORef Double) + , pbHash :: !Int + } + +instance Eq PBHandlerCounter where + (==) = (==) `on` pbSlack + +instance Hashable PBHandlerCounter where + hash = pbHash + hashWithSalt = defaultHashWithSalt + +newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter +newPBHandlerCounter ts degree learnt = do + let ts' = sortBy (flip compare `on` fst) ts + slack = sum (map fst ts) - degree + m = IM.fromList [(l,c) | (c,l) <- ts] + s <- newIORef slack + act <- newIORef $! (if learnt then 0 else -1) + return (PBHandlerCounter ts' degree m slack s act (hash (ts,degree))) + +instance ConstraintHandler PBHandlerCounter where + toConstraintHandler = CHPBCounter + + showConstraintHandler this = do + return $ show (pbTerms this) ++ " >= " ++ show (pbDegree this) + + attach solver this = do + -- BCP queue should be empty at this point. + -- It is important for calculating slack. + bcpCheckEmpty solver + s <- liftM sum $ forM (pbTerms this) $ \(c,l) -> do + watchLit solver l this + val <- litValue solver l + if val == lFalse then do + addBacktrackCB solver (litVar l) $ modifyIORef' (pbSlack this) (+ c) + return 0 + else do + return c + let slack = s - pbDegree this + writeIORef (pbSlack this) $! slack + if slack < 0 then + return False + else do + flip allM (pbTerms this) $ \(c,l) -> do + val <- litValue solver l + if c > slack && val == lUndef then do + assignBy solver l this + else + return True + + watchedLiterals _ this = do + return $ map snd $ pbTerms this + + watchedVariables _ _ = return [] + + basicPropagate solver this this2 falsifiedLit = do + watchLit solver falsifiedLit this + let c = pbCoeffMap this2 IM.! falsifiedLit + modifyIORef' (pbSlack this2) (subtract c) + addBacktrackCB solver (litVar falsifiedLit) $ modifyIORef' (pbSlack this2) (+ c) + s <- readIORef (pbSlack this2) + if s < 0 then + return False + else do + forM_ (takeWhile (\(c1,_) -> c1 > s) (pbTerms this2)) $ \(_,l1) -> do + v <- litValue solver l1 + when (v == lUndef) $ do + assignBy solver l1 this + return () + return True + + basicReasonOf solver this l = do + case l of + Nothing -> do + let p _ = return True + f p (pbMaxSlack this) (pbTerms this) + Just lit -> do + idx <- varAssignNo solver (litVar lit) + -- PB制約の場合には複数回unitになる可能性があり、 + -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 + let p lit2 =do + idx2 <- varAssignNo solver (litVar lit2) + return $ idx2 < idx + let c = pbCoeffMap this IM.! lit + f p (pbMaxSlack this - c) (pbTerms this) + where + {-# INLINE f #-} + f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] + f p s xs = go s xs [] + where + go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] + go s _ ret | s < 0 = return ret + go _ [] _ = error "PBHandlerCounter.basicReasonOf: should not happen" + go s ((c,lit):xs) ret = do + val <- litValue solver lit + if val == lFalse then do + b <- p lit + if b + then go (s - c) xs (lit:ret) + else go s xs ret + else do + go s xs ret + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + return (pbTerms this, pbDegree this) + + isSatisfied solver this = do + xs <- forM (pbTerms this) $ \(c,l) -> do + v <- litValue solver l + if v == lTrue + then return c + else return 0 + return $ sum xs >= pbDegree this + + constrWeight _ _ = return 0.5 + + constrReadActivity this = readIORef (pbActivity this) + + constrWriteActivity this aval = writeIORef (pbActivity this) $! aval + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint (Pueblo) +--------------------------------------------------------------------} + +data PBHandlerPueblo + = PBHandlerPueblo + { puebloTerms :: !PBLinSum + , puebloDegree :: !Integer + , puebloMaxSlack :: !Integer + , puebloWatches :: !(IORef LitSet) + , puebloWatchSum :: !(IORef Integer) + , puebloActivity :: !(IORef Double) + , puebloHash :: !Int + } + +instance Eq PBHandlerPueblo where + (==) = (==) `on` puebloWatchSum + +instance Hashable PBHandlerPueblo where + hash = puebloHash + hashWithSalt = defaultHashWithSalt + +puebloAMax :: PBHandlerPueblo -> Integer +puebloAMax this = + case puebloTerms this of + (c,_):_ -> c + [] -> 0 -- should not happen? + +newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo +newPBHandlerPueblo ts degree learnt = do + let ts' = sortBy (flip compare `on` fst) ts + slack = sum [c | (c,_) <- ts'] - degree + ws <- newIORef IS.empty + wsum <- newIORef 0 + act <- newIORef $! (if learnt then 0 else -1) + return $ PBHandlerPueblo ts' degree slack ws wsum act (hash (ts,degree)) + +puebloGetWatchSum :: PBHandlerPueblo -> IO Integer +puebloGetWatchSum pb = readIORef (puebloWatchSum pb) + +puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO () +puebloWatch solver constr !pb (c, lit) = do + watchLit solver lit constr + modifyIORef' (puebloWatches pb) (IS.insert lit) + modifyIORef' (puebloWatchSum pb) (+c) + +puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO () +puebloUnwatch _solver pb (c, lit) = do + modifyIORef' (puebloWatches pb) (IS.delete lit) + modifyIORef' (puebloWatchSum pb) (subtract c) + +instance ConstraintHandler PBHandlerPueblo where + toConstraintHandler = CHPBPueblo + + showConstraintHandler this = do + return $ show (puebloTerms this) ++ " >= " ++ show (puebloDegree this) + + attach solver this = do + bcpCheckEmpty solver + let constr = toConstraintHandler this + ret <- puebloPropagate solver constr this + + -- register to watch recently falsified literals to recover + -- "WatchSum >= puebloDegree this + puebloAMax this" when backtrack is performed. + wsum <- puebloGetWatchSum this + unless (wsum >= puebloDegree this + puebloAMax this) $ do + let f m tm@(_,lit) = do + val <- litValue solver lit + if val == lFalse then do + idx <- varAssignNo solver (litVar lit) + return (IM.insert idx tm m) + else + return m +#if MIN_VERSION_containers(0,5,0) + xs <- liftM (map snd . IM.toDescList) $ foldM f IM.empty (puebloTerms this) +#else + xs <- liftM (reverse . map snd . IM.toAscList) $ foldM f IM.empty (puebloTerms this) +#endif + let g !_ [] = return () + g !s (t@(c,l):ts) = do + addBacktrackCB solver (litVar l) $ puebloWatch solver constr this t + if s+c >= puebloDegree this + puebloAMax this then return () + else g (s+c) ts + g wsum xs + + return ret + + watchedLiterals _ this = liftM IS.toList $ readIORef (puebloWatches this) + + watchedVariables _ _ = return [] + + basicPropagate solver this this2 falsifiedLit = do + let t = fromJust $ find (\(_,l) -> l==falsifiedLit) (puebloTerms this2) + puebloUnwatch solver this2 t + ret <- puebloPropagate solver this this2 + wsum <- puebloGetWatchSum this2 + unless (wsum >= puebloDegree this2 + puebloAMax this2) $ + addBacktrackCB solver (litVar falsifiedLit) $ puebloWatch solver this this2 t + return ret + + basicReasonOf solver this l = do + case l of + Nothing -> do + let p _ = return True + f p (puebloMaxSlack this) (puebloTerms this) + Just lit -> do + idx <- varAssignNo solver (litVar lit) + -- PB制約の場合には複数回unitになる可能性があり、 + -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 + let p lit2 =do + idx2 <- varAssignNo solver (litVar lit2) + return $ idx2 < idx + let c = fst $ fromJust $ find (\(_,l) -> l == lit) (puebloTerms this) + f p (puebloMaxSlack this - c) (puebloTerms this) + where + {-# INLINE f #-} + f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] + f p s xs = go s xs [] + where + go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] + go s _ ret | s < 0 = return ret + go _ [] _ = error "PBHandlerPueblo.basicReasonOf: should not happen" + go s ((c,lit):xs) ret = do + val <- litValue solver lit + if val == lFalse then do + b <- p lit + if b + then go (s - c) xs (lit:ret) + else go s xs ret + else do + go s xs ret + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + return (puebloTerms this, puebloDegree this) + + isSatisfied solver this = do + xs <- forM (puebloTerms this) $ \(c,l) -> do + v <- litValue solver l + if v == lTrue + then return c + else return 0 + return $ sum xs >= puebloDegree this + + constrWeight _ _ = return 0.5 + + constrReadActivity this = readIORef (puebloActivity this) + + constrWriteActivity this aval = writeIORef (puebloActivity this) $! aval + +puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool +puebloPropagate solver constr this = do + puebloUpdateWatchSum solver constr this + watchsum <- puebloGetWatchSum this + if puebloDegree this + puebloAMax this <= watchsum then + return True + else if watchsum < puebloDegree this then do + -- CONFLICT + return False + else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this + -- UNIT PROPAGATION + let f [] = return True + f ((c,lit) : ts) = do + watchsum <- puebloGetWatchSum this + if watchsum - c >= puebloDegree this then + return True + else do + val <- litValue solver lit + when (val == lUndef) $ do + b <- assignBy solver lit this + assert b $ return () + f ts + f $ puebloTerms this + +puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO () +puebloUpdateWatchSum solver constr this = do + let f [] = return () + f (t@(_,lit):ts) = do + watchSum <- puebloGetWatchSum this + if watchSum >= puebloDegree this + puebloAMax this then + return () + else do + val <- litValue solver lit + watched <- liftM (lit `IS.member`) $ readIORef (puebloWatches this) + when (val /= lFalse && not watched) $ do + puebloWatch solver constr this t + f ts + f (puebloTerms this) + +{-------------------------------------------------------------------- + XOR Clause +--------------------------------------------------------------------} + +data XORClauseHandler + = XORClauseHandler + { xorLits :: !(IOUArray Int Lit) + , xorActivity :: !(IORef Double) + , xorHash :: !Int + } + +instance Eq XORClauseHandler where + (==) = (==) `on` xorLits + +instance Hashable XORClauseHandler where + hash = xorHash + hashWithSalt = defaultHashWithSalt + +newXORClauseHandler :: [Lit] -> Bool -> IO XORClauseHandler +newXORClauseHandler ls learnt = do + let size = length ls + a <- newListArray (0, size-1) ls + act <- newIORef $! (if learnt then 0 else -1) + return (XORClauseHandler a act (hash ls)) + +instance ConstraintHandler XORClauseHandler where + toConstraintHandler = CHXORClause + + showConstraintHandler this = do + lits <- getElems (xorLits this) + return ("XOR " ++ show lits) + + attach solver this = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + let a = xorLits this + (lb,ub) <- getBounds a + assert (lb == 0) $ return () + let size = ub-lb+1 + + if size == 0 then do + markBad solver + return False + else if size == 1 then do + lit0 <- unsafeRead a 0 + assignBy solver lit0 this + else do + ref <- newIORef 1 + let f i = do + lit_i <- unsafeRead a i + val_i <- litValue solver lit_i + if val_i == lUndef then + return True + else do + j <- readIORef ref + k <- findForWatch2 solver a j ub + case k of + -1 -> do + return False + _ -> do + lit_k <- unsafeRead a k + unsafeWrite a i lit_k + unsafeWrite a k lit_i + writeIORef ref $! (k+1) + return True + + b <- f 0 + if b then do + lit0 <- unsafeRead a 0 + watchVar solver (litVar lit0) this + b2 <- f 1 + if b2 then do + lit1 <- unsafeRead a 1 + watchVar solver (litVar lit1) this + return True + else do -- UNIT + -- We need to watch the most recently falsified literal + (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..ub] $ \l -> do + lit <- unsafeRead a l + lv <- litLevel solver lit + return (l,lv) + lit1 <- unsafeRead a 1 + liti <- unsafeRead a i + unsafeWrite a 1 liti + unsafeWrite a i lit1 + watchVar solver (litVar liti) this + -- lit0 ⊕ y + y <- do + ref <- newIORef False + forLoop 1 (<=ub) (+1) $ \j -> do + lit_j <- unsafeRead a j + val_j <- litValue solver lit_j + modifyIORef' ref (/= fromJust (unliftBool val_j)) + readIORef ref + assignBy solver (if y then litNot lit0 else lit0) this -- should always succeed + else do + ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [lb..ub] $ \l -> do + lit <- unsafeRead a l + lv <- litLevel solver lit + return (l,lv) + forM_ (zip [0..] ls) $ \(i,lit) -> do + unsafeWrite a i lit + lit0 <- unsafeRead a 0 + lit1 <- unsafeRead a 1 + watchVar solver (litVar lit0) this + watchVar solver (litVar lit1) this + isSatisfied solver this + + watchedLiterals _ _ = return [] + + watchedVariables _ this = do + lits <- getElems (xorLits this) + case lits of + l1:l2:_ -> return [litVar l1, litVar l2] + _ -> return [] + + -- FIXME: 伝播した変数から再度呼ばれて、再び伝播処理が起こってしまう + basicPropagate !solver this this2 !falsifiedLit = do + preprocess + + !lit0 <- unsafeRead a 0 + (!lb,!ub) <- getBounds a + assert (lb==0) $ return () + i <- findForWatch2 solver a 2 ub + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "basicPropagate: %s is unit" str + watchVar solver v this + -- lit0 ⊕ y + y <- do + ref <- newIORef False + forLoop 1 (<=ub) (+1) $ \j -> do + lit_j <- unsafeRead a j + val_j <- litValue solver lit_j + modifyIORef' ref (/= fromJust (unliftBool val_j)) + readIORef ref + assignBy solver (if y then litNot lit0 else lit0) this + _ -> do + !lit1 <- unsafeRead a 1 + !liti <- unsafeRead a i + unsafeWrite a 1 liti + unsafeWrite a i lit1 + watchVar solver (litVar liti) this + return True + + where + v = litVar falsifiedLit + a = xorLits this2 + + preprocess :: IO () + preprocess = do + !l0 <- unsafeRead a 0 + !l1 <- unsafeRead a 1 + assert (litVar l0 == v || litVar l1 == v) $ return () + when (litVar l0 == v) $ do + unsafeWrite a 0 l1 + unsafeWrite a 1 l0 + + basicReasonOf solver this l = do + lits <- getElems (xorLits this) + xs <- + case l of + Nothing -> mapM f lits + Just lit -> do + -- FIXME: 伝播処理が二回起こってしまうせいで、伝播結果のリテラルが先頭とは限らない + case lits of + l1:l2:ls + | litVar lit == litVar l1 -> mapM f (l2 : ls) + | litVar lit == litVar l2 -> mapM f (l1 : ls) + _ -> error "XORClauseHandler.basicReasonOf: should not happen" + return xs + where + f :: Lit -> IO Lit + f lit = do + let v = litVar lit + val <- varValue solver v + return $ literal v (not (fromJust (unliftBool val))) + + isPBRepresentable _ = return False + + toPBLinAtLeast _ = error "XORClauseHandler does not support toPBLinAtLeast" + + isSatisfied solver this = do + lits <- getElems (xorLits this) + vals <- mapM (litValue solver) lits + let f x y + | x == lUndef || y == lUndef = lUndef + | otherwise = liftBool (x /= y) + return $ foldl' f lFalse vals == lTrue + + constrIsProtected _ this = do + size <- liftM rangeSize (getBounds (xorLits this)) + return $! size <= 2 + + constrReadActivity this = readIORef (xorActivity this) + + constrWriteActivity this aval = writeIORef (xorActivity this) $! aval + +instantiateXORClause :: Solver -> XORClause -> IO XORClause +instantiateXORClause solver (ls,b) = loop [] b ls + where + loop :: [Lit] -> Bool -> [Lit] -> IO XORClause + loop lhs !rhs [] = return (lhs, rhs) + loop lhs !rhs (l:ls) = do + val <- litValue solver l + if val==lTrue then + loop lhs (not rhs) ls + else if val==lFalse then + loop lhs rhs ls + else + loop (l : lhs) rhs ls + +basicAttachXORClauseHandler :: Solver -> XORClauseHandler -> IO Bool +basicAttachXORClauseHandler solver this = do + lits <- getElems (xorLits this) + case lits of + [] -> do + markBad solver + return False + [l1] -> do + assignBy solver l1 this + l1:l2:_ -> do + watchVar solver (litVar l1) this + watchVar solver (litVar l2) this + return True + +{-------------------------------------------------------------------- + Restart strategy +--------------------------------------------------------------------} + +data RestartStrategy = MiniSATRestarts | ArminRestarts | LubyRestarts + deriving (Show, Eq, Ord) + +mkRestartSeq :: RestartStrategy -> Int -> Double -> [Int] +mkRestartSeq MiniSATRestarts = miniSatRestartSeq +mkRestartSeq ArminRestarts = arminRestartSeq +mkRestartSeq LubyRestarts = lubyRestartSeq + +miniSatRestartSeq :: Int -> Double -> [Int] +miniSatRestartSeq start inc = iterate (ceiling . (inc *) . fromIntegral) start + +{- +miniSatRestartSeq :: Int -> Double -> [Int] +miniSatRestartSeq start inc = map round $ iterate (inc*) (fromIntegral start) +-} + +arminRestartSeq :: Int -> Double -> [Int] +arminRestartSeq start inc = go (fromIntegral start) (fromIntegral start) + where + go !inner !outer = round inner : go inner' outer' + where + (inner',outer') = + if inner >= outer + then (fromIntegral start, outer * inc) + else (inner * inc, outer) + +lubyRestartSeq :: Int -> Double -> [Int] +lubyRestartSeq start inc = map (ceiling . (fromIntegral start *) . luby inc) [0..] + +{- + Finite subsequences of the Luby-sequence: + + 0: 1 + 1: 1 1 2 + 2: 1 1 2 1 1 2 4 + 3: 1 1 2 1 1 2 4 1 1 2 1 1 2 4 8 + ... + + +-} +luby :: Double -> Integer -> Double +luby y x = go2 size1 sequ1 x + where + -- Find the finite subsequence that contains index 'x', and the + -- size of that subsequence: + (size1, sequ1) = go 1 0 + + go :: Integer -> Integer -> (Integer, Integer) + go size sequ + | size < x+1 = go (2*size+1) (sequ+1) + | otherwise = (size, sequ) + + go2 :: Integer -> Integer -> Integer -> Double + go2 size sequ x2 + | size-1 /= x2 = let size' = (size-1) `div` 2 in go2 size' (sequ - 1) (x2 `mod` size') + | otherwise = y ^ sequ + + +{-------------------------------------------------------------------- + utility +--------------------------------------------------------------------} + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM p = go + where + go [] = return True + go (x:xs) = do + b <- p x + if b + then go xs + else return False + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p = go + where + go [] = return False + go (x:xs) = do + b <- p x + if b + then return True + else go xs + +#if !MIN_VERSION_base(4,6,0) + +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + writeIORef ref $! f x + +#endif + +shift :: IORef [a] -> IO a +shift ref = do + (x:xs) <- readIORef ref + writeIORef ref xs + return x + +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` hash x +#if MIN_VERSION_hashable(1,2,0) + where + combine :: Int -> Int -> Int + combine h1 h2 = (h1 * 16777619) `xor` h2 +#endif + +{-------------------------------------------------------------------- + debug +--------------------------------------------------------------------} + +debugMode :: Bool +debugMode = False + +checkSatisfied :: Solver -> IO () +checkSatisfied solver = do + cls <- readIORef (svConstrDB solver) + forM_ cls $ \c -> do + b <- isSatisfied solver c + unless b $ do + s <- showConstraintHandler c + log solver $ "BUG: " ++ s ++ " is violated" + +sanityCheck :: Solver -> IO () +sanityCheck _ | not debugMode = return () +sanityCheck solver = do + cls <- readIORef (svConstrDB solver) + forM_ cls $ \constr -> do + lits <- watchedLiterals solver constr + forM_ lits $ \l -> do + ws <- watches solver l + unless (constr `elem` ws) $ error $ printf "sanityCheck:A:%s" (show lits) + + vs <- variables solver + let lits = [l | v <- vs, l <- [literal v True, literal v False]] + forM_ lits $ \l -> do + cs <- watches solver l + forM_ cs $ \constr -> do + lits2 <- watchedLiterals solver constr + unless (l `elem` lits2) $ do + error $ printf "sanityCheck:C:%d %s" l (show lits2) + +dumpVarActivity :: Solver -> IO () +dumpVarActivity solver = do + log solver "Variable activity:" + vs <- variables solver + forM_ vs $ \v -> do + activity <- varActivity solver v + log solver $ printf "activity(%d) = %d" v activity + +dumpConstrActivity :: Solver -> IO () +dumpConstrActivity solver = do + log solver "Learnt constraints activity:" + xs <- learntConstraints solver + forM_ xs $ \c -> do + s <- showConstraintHandler c aval <- constrReadActivity c log solver $ printf "activity(%s) = %f" s aval diff --git a/src/ToySolver/SAT/CAMUS.hs b/src/ToySolver/SAT/CAMUS.hs deleted file mode 100644 --- a/src/ToySolver/SAT/CAMUS.hs +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : ToySolver.SAT.CAMUS --- Copyright : (c) Masahiro Sakai 2012-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal --- unsatisfiable subsets of constraints, Journal of Automated Reasoning, --- vol. 40, no. 1, pp. 1-33, Jan. 2008. --- --- --- * [HYCAM] A. Gregoire, B. Mazure, and C. Piette, Boosting a complete --- technique to find MSS and MUS: thanks to a local search oracle, in --- Proceedings of the 20th international joint conference on Artifical --- intelligence, ser. IJCAI'07. San Francisco, CA, USA: Morgan Kaufmann --- Publishers Inc., 2007, pp. 2300-2305. --- --- ------------------------------------------------------------------------------ -module ToySolver.SAT.CAMUS - ( MUS - , MCS - , Options (..) - , defaultOptions - , allMCSAssumptions - , allMUSAssumptions - , enumMCSAssumptions - ) where - -import Control.Monad -import Data.Array.IArray -import qualified Data.IntSet as IS -import Data.List -import Data.IORef -import qualified ToySolver.HittingSet as HittingSet -import qualified ToySolver.SAT as SAT -import ToySolver.SAT.Types - --- | Minimal Unsatisfiable Subset of constraints. -type MUS = [Lit] - --- | Minimal Correction Subset of constraints. -type MCS = [Lit] - --- | Options for 'enumMCSAssumptions', 'allMCSAssumptions', 'allMUSAssumptions' -data Options - = Options - { optLogger :: String -> IO () - , optCallback :: MCS -> IO () - , optMCSCandidates :: [MCS] - -- ^ MCS candidates (see HYCAM paper for details). - -- A MCS candidate must be a superset of real MCS. - } - --- | default 'Options' value -defaultOptions :: Options -defaultOptions = - Options - { optLogger = \_ -> return () - , optCallback = \_ -> return () - , optMCSCandidates = [] - } - -enumMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO () -enumMCSAssumptions solver sels opt = do - candRef <- newIORef [(IS.size s, s) | mcs <- optMCSCandidates opt, let s = IS.fromList mcs] - loop candRef 1 - - where - log :: String -> IO () - log = optLogger opt - - mcsFound :: MCS -> IO () - mcsFound mcs = do - optCallback opt mcs - SAT.addClause solver mcs - - loop :: IORef [(Int, LitSet)] -> Int -> IO () - loop candRef k = do - log $ "CAMUS: k = " ++ show k - cand <- readIORef candRef - - ret <- if not (null cand) then return True else SAT.solve solver - when ret $ do - forM_ cand $ \(size,cs) -> do - when (size == k) $ do - -- If a candidate MCS is not superset of already obtained MCS, - -- we are sure that they are real MCS. - mcsFound (IS.toList cs) - writeIORef candRef [(size,cs) | (size,cs) <- cand, size /= k] - - vk <- SAT.newVar solver - SAT.addPBAtMostSoft solver vk [(1,-sel) | sel <- sels] (fromIntegral k) - let loop2 = do - ret2 <- SAT.solveWith solver [vk] - when ret2 $ do - m <- SAT.model solver - let mcs = [sel | sel <- sels, not (evalLit m sel)] - mcs' = IS.fromList mcs - mcsFound mcs - modifyIORef candRef (filter (\(_,cs) -> not (mcs' `IS.isSubsetOf` cs))) - loop2 - loop2 - SAT.addClause solver [-vk] - loop candRef (k+1) - -allMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MCS] -allMCSAssumptions solver sels opt = do - ref <- newIORef [] - let opt2 = - opt - { optCallback = \mcs -> do - modifyIORef ref (mcs:) - optCallback opt mcs - } - enumMCSAssumptions solver sels opt2 - readIORef ref - -allMUSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MUS] -allMUSAssumptions solver sels opt = do - log "CAMUS: MCS enumeration begins" - mcses <- allMCSAssumptions solver sels opt - log "CAMUS: MCS enumeration done" - return $ HittingSet.minimalHittingSets mcses - where - log :: String -> IO () - log = optLogger opt diff --git a/src/ToySolver/SAT/Integer.hs b/src/ToySolver/SAT/Integer.hs --- a/src/ToySolver/SAT/Integer.hs +++ b/src/ToySolver/SAT/Integer.hs @@ -21,14 +21,18 @@ data Expr = Expr [(Integer, [SAT.Lit])] newVar :: SAT.Solver -> Integer -> Integer -> IO Expr -newVar solver lo hi = do - when (lo > hi) $ error $ printf "ToySolver.SAT.Integer.newVar: inconsistent bounds given [%d, %d]" lo hi - let hi' = hi - lo - bitWidth = head $ [w | w <- [1..], let mx = 2 ^ w - 1, hi' <= mx] - vs <- SAT.newVars solver bitWidth - let xs = zip (iterate (2*) 1) vs - SAT.addPBAtMost solver xs hi' - return $ Expr ((lo,[]) : [(c,[x]) | (c,x) <- xs]) +newVar solver lo hi + | lo > hi = do + SAT.addClause solver [] -- assert inconsistency + return 0 + | lo == hi = return $ fromInteger lo + | otherwise = do + let hi' = hi - lo + bitWidth = head $ [w | w <- [1..], let mx = 2 ^ w - 1, hi' <= mx] + vs <- SAT.newVars solver bitWidth + let xs = zip (iterate (2*) 1) vs + SAT.addPBAtMost solver xs hi' + return $ Expr ((lo,[]) : [(c,[x]) | (c,x) <- xs]) instance AdditiveGroup Expr where Expr xs1 ^+^ Expr xs2 = Expr (xs1++xs2) @@ -56,8 +60,8 @@ return (c,l) return (zs, c) -addConstraint :: TseitinEncoder.Encoder -> Rel Expr -> IO () -addConstraint enc (Rel lhs op rhs) = do +addConstraint :: TseitinEncoder.Encoder -> ArithRel Expr -> IO () +addConstraint enc (ArithRel lhs op rhs) = do let solver = TseitinEncoder.encSolver enc (lhs2,c) <- linearize enc (lhs - rhs) let rhs2 = -c @@ -72,8 +76,8 @@ SAT.addPBAtLeastSoft solver sel lhs2 (rhs2+1) SAT.addPBAtMostSoft solver (-sel) lhs2 (rhs2-1) -addConstraintSoft :: TseitinEncoder.Encoder -> SAT.Lit -> Rel Expr -> IO () -addConstraintSoft enc sel (Rel lhs op rhs) = do +addConstraintSoft :: TseitinEncoder.Encoder -> SAT.Lit -> ArithRel Expr -> IO () +addConstraintSoft enc sel (ArithRel lhs op rhs) = do let solver = TseitinEncoder.encSolver enc (lhs2,c) <- linearize enc (lhs - rhs) let rhs2 = -c diff --git a/src/ToySolver/SAT/MUS.hs b/src/ToySolver/SAT/MUS.hs --- a/src/ToySolver/SAT/MUS.hs +++ b/src/ToySolver/SAT/MUS.hs @@ -12,16 +12,19 @@ -- ----------------------------------------------------------------------------- module ToySolver.SAT.MUS - ( Options (..) + ( module ToySolver.SAT.MUS.Types + , Options (..) , defaultOptions , findMUSAssumptions ) where import Control.Monad +import Data.Default.Class import Data.List import qualified Data.IntSet as IS import qualified ToySolver.SAT as SAT import ToySolver.SAT.Types +import ToySolver.SAT.MUS.Types -- | Options for 'findMUSAssumptions' function data Options @@ -31,6 +34,9 @@ , optLitPrinter :: Lit -> String } +instance Default Options where + def = defaultOptions + -- | default 'Options' value defaultOptions :: Options defaultOptions = @@ -41,18 +47,17 @@ } -- | Find a minimal set of assumptions that causes a conflict. --- Initial set of assumptions is taken from 'SAT.failedAssumptions'. +-- Initial set of assumptions is taken from 'SAT.getFailedAssumptions'. findMUSAssumptions :: SAT.Solver -> Options - -> IO [Lit] + -> IO MUS findMUSAssumptions solver opt = do log "computing a minimal unsatisfiable core" - core <- liftM IS.fromList $ SAT.failedAssumptions solver + core <- liftM IS.fromList $ SAT.getFailedAssumptions solver update $ IS.toList core log $ "core = " ++ showLits core - mus <- loop core IS.empty - return $ IS.toList mus + loop core IS.empty where log :: String -> IO () @@ -67,7 +72,7 @@ showLits :: IS.IntSet -> String showLits ls = "{" ++ intercalate ", " (map showLit (IS.toList ls)) ++ "}" - loop :: IS.IntSet -> IS.IntSet -> IO IS.IntSet + loop :: IS.IntSet -> IS.IntSet -> IO MUS loop ls1 fixed = do case IS.minView ls1 of Nothing -> do @@ -78,7 +83,7 @@ ret <- SAT.solveWith solver (IS.toList ls) if not ret then do - ls2 <- liftM IS.fromList $ SAT.failedAssumptions solver + ls2 <- liftM IS.fromList $ SAT.getFailedAssumptions solver let removed = ls1 `IS.difference` ls2 log $ "successed to remove " ++ showLits removed log $ "new core = " ++ showLits (ls2 `IS.union` fixed) diff --git a/src/ToySolver/SAT/MUS/CAMUS.hs b/src/ToySolver/SAT/MUS/CAMUS.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/MUS/CAMUS.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.MUS.CAMUS +-- Copyright : (c) Masahiro Sakai 2012-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- In this module, we assume each soft constraint /C_i/ is represented as a literal. +-- If a constraint /C_i/ is not a literal, we can represent it as a fresh variable /v/ +-- together with a hard constraint /v ⇒ C_i/. +-- +-- References: +-- +-- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal +-- unsatisfiable subsets of constraints, Journal of Automated Reasoning, +-- vol. 40, no. 1, pp. 1-33, Jan. 2008. +-- +-- +-- * [HYCAM] A. Gregoire, B. Mazure, and C. Piette, Boosting a complete +-- technique to find MSS and MUS: thanks to a local search oracle, in +-- Proceedings of the 20th international joint conference on Artifical +-- intelligence, ser. IJCAI'07. San Francisco, CA, USA: Morgan Kaufmann +-- Publishers Inc., 2007, pp. 2300-2305. +-- +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.MUS.CAMUS + ( module ToySolver.SAT.MUS.Types + , Options (..) + , defaultOptions + , allMCSAssumptions + , allMUSAssumptions + , enumMCSAssumptions + , camus + ) where + +import Control.Monad +import Data.Array.IArray +import Data.Default.Class +import qualified Data.IntSet as IS +import Data.List +import Data.IORef +import qualified ToySolver.Combinatorial.HittingSet.Simple as HittingSet +import qualified ToySolver.SAT as SAT +import ToySolver.SAT.Types +import ToySolver.SAT.MUS.Types + +-- | Options for 'enumMCSAssumptions', 'allMCSAssumptions', 'allMUSAssumptions' +data Options + = Options + { optLogger :: String -> IO () + , optOnMCSFound :: MCS -> IO () + , optOnMUSFound :: MUS -> IO () + , optKnownMCSes :: [MCS] + , optKnownMUSes :: [MUS] + , optKnownCSes :: [CS] + -- ^ MCS candidates (see HYCAM paper for details). + -- A MCS candidate must be a superset of a real MCS. + } + +instance Default Options where + def = defaultOptions + +-- | default 'Options' value +defaultOptions :: Options +defaultOptions = + Options + { optLogger = \_ -> return () + , optOnMCSFound = \_ -> return () + , optOnMUSFound = \_ -> return () + , optKnownMCSes = [] + , optKnownMUSes = [] + , optKnownCSes = [] + } + +enumMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO () +enumMCSAssumptions solver sels opt = do + candRef <- newIORef [(IS.size cs, cs) | cs <- optKnownCSes opt] + loop candRef 1 + + where + log :: String -> IO () + log = optLogger opt + + mcsFound :: MCS -> IO () + mcsFound mcs = do + optOnMCSFound opt mcs + SAT.addClause solver (IS.toList mcs) + + loop :: IORef [(Int, LitSet)] -> Int -> IO () + loop candRef k = do + log $ "CAMUS: k = " ++ show k + cand <- readIORef candRef + + ret <- if not (null cand) then return True else SAT.solve solver + when ret $ do + forM_ cand $ \(size,cs) -> do + when (size == k) $ do + -- If a candidate MCS is not superset of already obtained MCS, + -- we are sure that it is actually an MCS. + mcsFound cs + writeIORef candRef [(size,cs) | (size,cs) <- cand, size /= k] + + vk <- SAT.newVar solver + SAT.addPBAtMostSoft solver vk [(1,-sel) | sel <- sels] (fromIntegral k) + let loop2 = do + ret2 <- SAT.solveWith solver [vk] + when ret2 $ do + m <- SAT.getModel solver + let mcs = IS.fromList [sel | sel <- sels, not (evalLit m sel)] + mcsFound mcs + modifyIORef candRef (filter (\(_,cs) -> not (mcs `IS.isSubsetOf` cs))) + loop2 + loop2 + SAT.addClause solver [-vk] + loop candRef (k+1) + +allMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MCS] +allMCSAssumptions solver sels opt = do + ref <- newIORef [] + let opt2 = + opt + { optOnMCSFound = \mcs -> do + modifyIORef ref (mcs:) + optOnMCSFound opt mcs + } + enumMCSAssumptions solver sels opt2 + readIORef ref + +allMUSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MUS] +allMUSAssumptions solver sels opt = do + (muses, _mcses) <- camus solver sels opt + return $ muses + +camus :: SAT.Solver -> [Lit] -> Options -> IO ([MUS], [MCS]) +camus solver sels opt = do + log "CAMUS: MCS enumeration begins" + mcses <- allMCSAssumptions solver sels opt + log "CAMUS: MCS enumeration done" + let muses = HittingSet.minimalHittingSets mcses + mapM_ (optOnMUSFound opt) muses + return (muses, mcses) + where + log :: String -> IO () + log = optLogger opt diff --git a/src/ToySolver/SAT/MUS/DAA.hs b/src/ToySolver/SAT/MUS/DAA.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/MUS/DAA.hs @@ -0,0 +1,132 @@ +{-# OPTIONS_GHC -Wall #-} + +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.MUS.DAA +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- "Dualize and Advance" algorithm for finding minimal unsatisfiable sets. +-- +-- * [DAA] J. Bailey and P. Stuckey, Discovery of minimal unsatisfiable +-- subsets of constraints using hitting set dualization," in Practical +-- Aspects of Declarative Languages, pp. 174-186, 2005. +-- +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.MUS.DAA + ( module ToySolver.SAT.MUS.Types + , Options (..) + , defaultOptions + , allMCSAssumptions + , allMUSAssumptions + , daa + ) where + +import Control.Monad +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Set (Set) +import qualified Data.Set as Set +import qualified ToySolver.Combinatorial.HittingSet.Simple as HittingSet +import qualified ToySolver.SAT as SAT +import ToySolver.SAT.Types +import ToySolver.SAT.MUS.Types +import ToySolver.SAT.MUS.CAMUS (Options (..), defaultOptions) + +allMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MCS] +allMCSAssumptions solver sels opt = do + (_, mcses) <- daa solver sels opt + return mcses + +allMUSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MUS] +allMUSAssumptions solver sels opt = do + (muses, _) <- daa solver sels opt + return muses + +daa :: SAT.Solver -> [Lit] -> Options -> IO ([MUS], [MCS]) +daa solver sels opt = + loop (Set.fromList (optKnownMUSes opt)) (Set.fromList (optKnownMCSes opt)) + where + selsSet :: LitSet + selsSet = IntSet.fromList sels + + loop :: Set LitSet -> Set LitSet -> IO ([MUS], [MCS]) + loop muses mcses = do + let f muses [] = return (Set.toList muses, Set.toList mcses) + f muses (xs:xss) = do + ret <- findMSS xs + case ret of + Just mss -> do + let mcs = selsSet `IntSet.difference` mss + optOnMCSFound opt mcs + loop muses (Set.insert mcs mcses) + Nothing -> do + let mus = xs + optOnMUSFound opt mus + SAT.addClause solver [-l | l <- IntSet.toList mus] -- lemma + f (Set.insert mus muses) xss + f muses (Set.toList (hst mcses `Set.difference` muses)) + + hst :: Set LitSet -> Set LitSet + hst = Set.fromList . HittingSet.minimalHittingSets . Set.toList + + findMSS :: LitSet -> IO (Maybe LitSet) + findMSS xs = do + forM_ sels $ \l -> do + SAT.setVarPolarity solver (litVar l) (litPolarity l) + b <- SAT.solveWith solver (IntSet.toList xs) + if b then do + m <- SAT.getModel solver + liftM Just $ grow $ IntSet.fromList [l | l <- sels, evalLit m l] + else + return Nothing + + grow :: LitSet -> IO LitSet + grow xs = loop xs (selsSet `IntSet.difference` xs) + where + loop xs ys = + case IntSet.minView ys of + Nothing -> return xs + Just (c, ys') -> do + b <- SAT.solveWith solver (c : IntSet.toList xs) + if b then do + m <- SAT.getModel solver + let cs = IntSet.fromList [l | l <- sels, evalLit m l] + loop (xs `IntSet.union` cs) (ys' `IntSet.difference` cs) + else do + zs <- SAT.getFailedAssumptions solver + SAT.addClause solver [-l | l <- zs] -- lemma + loop xs ys' + +{- +daa_min_unsat(U) + bA := ∅ + bX := ∅ + X := ∅ + repeat + M := grow(X,U); + bX := bX ∪ {U - M} + bN := HST (X) + X := ∅ + for (S ∈ bN - bA) + if (sat(S)) + X := S + break + else bA := bA ∪ {S} + endfor + until (X = ∅) + return (bA) + +grow(S,U) + for (c ∈ U - S) + if (sat(S ∪ {c})) S := S ∪ {c} + endfor + return(S) + +Fig. 1. Dualize and advance algorithm for finding minimal unsatisfiable sets. +-} diff --git a/src/ToySolver/SAT/MUS/Types.hs b/src/ToySolver/SAT/MUS/Types.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/MUS/Types.hs @@ -0,0 +1,66 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.MUS.Types +-- Copyright : (c) Masahiro Sakai 2012-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- In this module, we assume each soft constraint /C_i/ is represented as a literal. +-- If a constraint /C_i/ is not a literal, we can represent it as a fresh variable /v/ +-- together with a hard constraint /v ⇒ C_i/. +-- +-- References: +-- +-- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal +-- unsatisfiable subsets of constraints, Journal of Automated Reasoning, +-- vol. 40, no. 1, pp. 1-33, Jan. 2008. +-- +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.MUS.Types + ( US + , MUS + , CS + , MCS + , SS + , MSS + ) where + +import ToySolver.SAT.Types + +-- | Unsatisfiable Subset of constraints (US). +-- +-- A subset U ⊆ C is an US if U is unsatisfiable. +type US = LitSet + +-- | Minimal Unsatisfiable Subset of constraints (MUS). +-- +-- A subset U ⊆ C is an MUS if U is unsatisfiable and ∀C_i ∈ U, U\\{C_i} is satisfiable [CAMUS]. +type MUS = LitSet + +-- | Correction Subset of constraints (CS). +-- +-- A subset M ⊆ C is a CS if C\\M is satisfiable. +-- A CS is the complement of a 'SS'. +type CS = LitSet + +-- | Minimal Correction Subset of constraints (MCS). +-- +-- A subset M ⊆ C is an MCS if C\\M is satisfiable and ∀C_i ∈ M, C\\(M\\{C_i}) is unsatisfiable [CAMUS]. +-- A MCS is the complement of an 'MSS' and also known as a CoMSS. +type MCS = LitSet + +-- | Satisfiable Subset (SS). +-- +-- A subset S ⊆ C is a SS if S is satisfiable. +-- A SS is the complement of a 'CS'. +type SS = LitSet + +-- | Maximal Satisfiable Subset (MSS). +-- +-- A subset S ⊆ C is an MSS if S is satisfiable and ∀C_i ∈ U\\S, S∪{C_i} is unsatisfiable [CAMUS]. +-- A MSS is the complement of an 'MCS'. +type MSS = LitSet diff --git a/src/ToySolver/SAT/PBO.hs b/src/ToySolver/SAT/PBO.hs --- a/src/ToySolver/SAT/PBO.hs +++ b/src/ToySolver/SAT/PBO.hs @@ -49,6 +49,7 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Default.Class import Data.IORef import qualified Data.Set as Set import qualified Data.Map as Map @@ -72,6 +73,9 @@ | BCD | BCD2 +instance Default SearchStrategy where + def = defaultSearchStrategy + defaultSearchStrategy :: SearchStrategy defaultSearchStrategy = LinearSearch @@ -87,7 +91,7 @@ newOptimizer :: SAT.Solver -> SAT.PBLinSum -> IO Optimizer newOptimizer solver obj = do cxt <- C.newSimpleContext obj - strategyRef <- newIORef defaultSearchStrategy + strategyRef <- newIORef def heuristicsRef <- newIORef defaultEnableObjFunVarsHeuristics trialLimitRef <- newIORef defaultTrialLimitConf return $ @@ -115,7 +119,7 @@ BC -> BC.solve cxt solver BCD -> BCD.solve cxt solver BCD2 -> do - let opt2 = BCD2.defaultOptions + let opt2 = def BCD2.solve cxt solver opt2 _ -> do SAT.setEnableBackwardSubsumptionRemoval solver True @@ -129,7 +133,7 @@ if not result then C.setFinished cxt else do - m <- SAT.model solver + m <- SAT.getModel solver C.addSolution cxt m join $ atomically $ do @@ -214,7 +218,7 @@ loop = do result <- SAT.solve solver if result then do - m <- SAT.model solver + m <- SAT.getModel solver let val = SAT.evalPBLinSum m obj let ub = val - 1 C.addSolution cxt m @@ -243,7 +247,7 @@ SAT.addPBAtMostSoft solver sel obj mid ret <- SAT.solveWith solver [sel] if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let v = SAT.evalPBLinSum m obj let ub' = v - 1 C.logMessage cxt $ printf "Binary Search: updating upper bound: %d -> %d" ub ub' @@ -281,7 +285,7 @@ C.logMessage cxt $ printf "Adaptive Search: %d <= obj <= %d" lb ub result <- SAT.solve solver if result then do - m <- SAT.model solver + m <- SAT.getModel solver let v = SAT.evalPBLinSum m obj let ub' = v - 1 C.addSolution cxt m @@ -304,7 +308,7 @@ Right ret -> do let fraction' = min 0.5 (fraction + 0.1) if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let v = SAT.evalPBLinSum m obj let ub' = v - 1 C.logMessage cxt $ printf "Adaptive Search: updating upper bound: %d -> %d" ub ub' diff --git a/src/ToySolver/SAT/PBO/BC.hs b/src/ToySolver/SAT/PBO/BC.hs --- a/src/ToySolver/SAT/PBO/BC.hs +++ b/src/ToySolver/SAT/PBO/BC.hs @@ -60,7 +60,7 @@ SAT.addPBAtMostSoft solver sel [(weights IntMap.! lit, -lit) | lit <- IntSet.toList relaxed] mid ret <- SAT.solveWith solver (sel : IntSet.toList unrelaxed) if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let val = SAT.evalPBLinSum m obj let ub' = val - 1 C.logMessage cxt $ printf "BC: updating upper bound: %d -> %d" ub ub' @@ -69,7 +69,7 @@ SAT.addPBAtMost solver obj ub' loop (unrelaxed, relaxed) (lb, ub') else do - core <- SAT.failedAssumptions solver + core <- SAT.getFailedAssumptions solver SAT.addClause solver [-sel] -- delete temporary constraint let core2 = IntSet.fromList core `IntSet.intersection` unrelaxed if IntSet.null core2 then do diff --git a/src/ToySolver/SAT/PBO/BCD.hs b/src/ToySolver/SAT/PBO/BCD.hs --- a/src/ToySolver/SAT/PBO/BCD.hs +++ b/src/ToySolver/SAT/PBO/BCD.hs @@ -96,7 +96,7 @@ ret <- SAT.solveWith solver (IntMap.keys sels ++ IntSet.toList unrelaxed) if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let val = SAT.evalPBLinSum m obj let ub' = val - 1 C.logMessage cxt $ printf "BCD: updating upper bound: %d -> %d" ub ub' @@ -105,7 +105,7 @@ let cores' = map (\info -> info{ coreUB = SAT.evalPBLinSum m (coreCostFun info) }) cores cont (unrelaxed, relaxed) cores' ub' else do - core <- SAT.failedAssumptions solver + core <- SAT.getFailedAssumptions solver case core of [] -> return () [sel] | Just info <- IntMap.lookup sel sels -> do diff --git a/src/ToySolver/SAT/PBO/BCD2.hs b/src/ToySolver/SAT/PBO/BCD2.hs --- a/src/ToySolver/SAT/PBO/BCD2.hs +++ b/src/ToySolver/SAT/PBO/BCD2.hs @@ -34,12 +34,13 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad +import Data.Default.Class import qualified Data.IntSet as IntSet import qualified Data.IntMap as IntMap import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.PBO.Context as C -import qualified ToySolver.Knapsack as Knapsack +import qualified ToySolver.Combinatorial.Knapsack.BB as Knapsack import Text.Printf data Options @@ -49,6 +50,9 @@ , optSolvingNormalFirst :: Bool } +instance Default Options where + def = defaultOptions + defaultOptions :: Options defaultOptions = Options @@ -81,7 +85,7 @@ | optSolvingNormalFirst opt -> do ret <- SAT.solve solver if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let val = SAT.evalPBLinSum m obj let ub' = val - 1 C.logMessage cxt $ printf "BCD2: updating upper bound: %d -> %d" (SAT.pbUpperBound obj) ub' @@ -132,7 +136,7 @@ ret <- SAT.solveWith solver (IntMap.keys sels ++ IntSet.toList unrelaxed) if ret then do - m <- SAT.model solver + m <- SAT.getModel solver let val = SAT.evalPBLinSum m obj let ub' = val - 1 C.logMessage cxt $ printf "BCD2: updating upper bound: %d -> %d" ub ub' @@ -140,7 +144,7 @@ SAT.addPBAtMost solver obj ub' cont (unrelaxed, relaxed, hardened) deductedWeight cores ub' (Just m) (nsat+1,nunsat) else do - core <- SAT.failedAssumptions solver + core <- SAT.getFailedAssumptions solver case core of [] -> C.setFinished cxt [sel] | Just (info,mid) <- IntMap.lookup sel sels -> do diff --git a/src/ToySolver/SAT/PBO/MSU4.hs b/src/ToySolver/SAT/PBO/MSU4.hs --- a/src/ToySolver/SAT/PBO/MSU4.hs +++ b/src/ToySolver/SAT/PBO/MSU4.hs @@ -55,14 +55,14 @@ loop (unrelaxed, relaxed) lb = do ret <- SAT.solveWith solver (IS.toList unrelaxed) if ret then do - currModel <- SAT.model solver + currModel <- SAT.getModel solver C.addSolution cxt currModel let violated = [weights IM.! l | l <- IS.toList relaxed, SAT.evalLit currModel l == False] currVal = sum violated SAT.addPBAtMost solver [(c,-l) | (l,c) <- sels] (currVal - 1) cont (unrelaxed, relaxed) lb else do - core <- SAT.failedAssumptions solver + core <- SAT.getFailedAssumptions solver let ls = IS.fromList core `IS.intersection` unrelaxed if IS.null ls then do C.setFinished cxt diff --git a/src/ToySolver/SAT/PBO/UnsatBased.hs b/src/ToySolver/SAT/PBO/UnsatBased.hs --- a/src/ToySolver/SAT/PBO/UnsatBased.hs +++ b/src/ToySolver/SAT/PBO/UnsatBased.hs @@ -45,12 +45,12 @@ ret <- SAT.solveWith solver (IntMap.keys sels) if ret then do - m <- SAT.model solver + m <- SAT.getModel solver -- モデルから余計な変数を除去する? C.addSolution cxt m return () else do - core <- SAT.failedAssumptions solver + core <- SAT.getFailedAssumptions solver case core of [] -> C.setFinished cxt _ -> do diff --git a/src/ToySolver/SAT/TseitinEncoder.hs b/src/ToySolver/SAT/TseitinEncoder.hs --- a/src/ToySolver/SAT/TseitinEncoder.hs +++ b/src/ToySolver/SAT/TseitinEncoder.hs @@ -42,7 +42,7 @@ , encSolver -- * Encoding of boolean formula - , Formula (..) + , Formula , evalFormula , addFormula , encodeConj @@ -56,28 +56,16 @@ import qualified Data.Map as Map import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet +import ToySolver.Data.Boolean +import ToySolver.Data.BoolExpr import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT -- | Arbitrary formula not restricted to CNF -data Formula - = Lit SAT.Lit - | And [Formula] - | Or [Formula] - | Not Formula - | Imply Formula Formula - | Equiv Formula Formula - deriving (Show, Eq, Ord) +type Formula = BoolExpr SAT.Lit evalFormula :: SAT.IModel m => m -> Formula -> Bool -evalFormula m = e - where - e (Lit l) = SAT.evalLit m l - e (And fs) = and (map e fs) - e (Or fs) = or (map e fs) - e (Not f) = not (e f) - e (Imply f1 f2) = not (e f1) || e f2 - e (Equiv f1 f2) = e f1 == e f2 +evalFormula m = fold (SAT.evalLit m) -- | Encoder instance data Encoder = @@ -116,8 +104,8 @@ SAT.addClause solver [SAT.litNot lit1, lit2] -- a→b SAT.addClause solver [SAT.litNot lit2, lit1] -- b→a Not (Not a) -> addFormula encoder a - Not (Or xs) -> addFormula encoder (And (map Not xs)) - Not (Imply a b) -> addFormula encoder (And [a, Not b]) + Not (Or xs) -> addFormula encoder (andB (map notB xs)) + Not (Imply a b) -> addFormula encoder (a .&&. notB b) Not (Equiv a b) -> do lit1 <- encodeToLit encoder a lit2 <- encodeToLit encoder b @@ -136,9 +124,9 @@ return $ concat cs Not (Not x) -> encodeToClause encoder x Not (And xs) -> do - encodeToClause encoder (Or (map Not xs)) + encodeToClause encoder (orB (map notB xs)) Imply a b -> do - encodeToClause encoder (Or [Not a, b]) + encodeToClause encoder (notB a .||. b) _ -> do l <- encodeToLit encoder formula return [l] @@ -146,19 +134,17 @@ encodeToLit :: Encoder -> Formula -> IO SAT.Lit encodeToLit encoder formula = do case formula of - Lit l -> return l + Atom l -> return l And xs -> encodeConj encoder =<< mapM (encodeToLit encoder) xs Or xs -> encodeDisj encoder =<< mapM (encodeToLit encoder) xs Not x -> liftM SAT.litNot $ encodeToLit encoder x Imply x y -> do - encodeToLit encoder (Or [Not x, y]) + encodeToLit encoder (notB x .||. y) Equiv x y -> do lit1 <- encodeToLit encoder x lit2 <- encodeToLit encoder y encodeToLit encoder $ - And [ Imply (Lit lit1) (Lit lit2) - , Imply (Lit lit2) (Lit lit1) - ] + (Atom lit1 .=>. Atom lit2) .&&. (Atom lit2 .=>. Atom lit1) -- | Return an literal which is equivalent to a given conjunction. encodeConj :: Encoder -> [SAT.Lit] -> IO SAT.Lit @@ -202,4 +188,4 @@ getDefinitions :: Encoder -> IO [(SAT.Lit, Formula)] getDefinitions encoder = do t <- readIORef (encConjTable encoder) - return $ [(l, And [Lit l1 | l1 <- IntSet.toList ls]) | (ls, l) <- Map.toList t] + return $ [(l, andB [Atom l1 | l1 <- IntSet.toList ls]) | (ls, l) <- Map.toList t] diff --git a/src/ToySolver/SAT/Types.hs b/src/ToySolver/SAT/Types.hs --- a/src/ToySolver/SAT/Types.hs +++ b/src/ToySolver/SAT/Types.hs @@ -28,6 +28,7 @@ , normalizeClause , clauseSubsume , evalClause + , clauseToPBLinAtLeast -- * Cardinality Constraint , AtLeast @@ -51,6 +52,11 @@ , pbLowerBound , pbUpperBound , pbSubsume + + -- * XOR Clause + , XORClause + , normalizeXORClause + , evalXORClause ) where import Control.Monad @@ -157,6 +163,9 @@ evalClause :: IModel m => m -> Clause -> Bool evalClause m cl = any (evalLit m) cl +clauseToPBLinAtLeast :: Clause -> PBLinAtLeast +clauseToPBLinAtLeast xs = ([(1,l) | l <- xs], 1) + type AtLeast = ([Lit], Int) normalizeAtLeast :: AtLeast -> AtLeast @@ -208,7 +217,7 @@ -- | normalizing PB constraint of the form /c1 x1 + c2 cn ... cn xn >= b/. normalizePBLinAtLeast :: PBLinAtLeast -> PBLinAtLeast normalizePBLinAtLeast a = -　case step1 a of + case step1 a of (xs,n) | n > 0 -> step3 (saturate n xs, n) | otherwise -> ([], 0) -- trivially true @@ -302,3 +311,39 @@ rhs1 >= rhs2 && and [di >= ci | (ci,li) <- lhs1, let di = IntMap.findWithDefault 0 li lhs2'] where lhs2' = IntMap.fromList [(l,c) | (c,l) <- lhs2] + + +-- | XOR clause +-- +-- '([l1,l2..ln], b)' means l1 ⊕ l2 ⊕ ⋯ ⊕ ln = b. +-- +-- Note that: +-- +-- * True can be represented as ([], False) +-- +-- * False can be represented as ([], True) +-- +type XORClause = ([Lit], Bool) + +-- | Normalize XOR clause +normalizeXORClause :: XORClause -> XORClause +normalizeXORClause (lits, b) = + case IntMap.keys m of + 0:xs -> (xs, not b) + xs -> (xs, b) + where + m = IntMap.filter id $ IntMap.unionsWith xor [f lit | lit <- lits] + xor = (/=) + + f 0 = IntMap.singleton 0 True + f lit = + if litPolarity lit + then IntMap.singleton lit True + else IntMap.fromList [(litVar lit, True), (0, True)] -- ¬x = x ⊕ 1 + +evalXORClause :: IModel m => m -> XORClause -> Bool +evalXORClause m (lits, rhs) = foldl' xor False (map f lits) == rhs + where + xor = (/=) + f 0 = True + f lit = evalLit m lit diff --git a/src/ToySolver/Simplex.hs b/src/ToySolver/Simplex.hs deleted file mode 100644 --- a/src/ToySolver/Simplex.hs +++ /dev/null @@ -1,366 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Simplex --- Copyright : (c) Masahiro Sakai 2011 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) --- --- Naïve implementation of Simplex method --- --- Reference: --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.Simplex - ( - -- * The @Tableau@ type - Tableau - , RowIndex - , ColIndex - , Row - , emptyTableau - , objRowIndex - , pivot - , lookupRow - , addRow - , setObjFun - - -- * Optimization direction - , module Data.OptDir - - -- * Reading status - , currentValue - , currentObjValue - , isFeasible - , isOptimal - - -- * High-level solving functions - , simplex - , dualSimplex - , phaseI - , primalDualSimplex - - -- * For debugging - , isValidTableau - , toCSV - ) where - -import Data.Ord -import Data.List -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.OptDir -import Data.VectorSpace -import Control.Exception - -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.Var - --- --------------------------------------------------------------------------- - -type Tableau r = VarMap (Row r) -{- -tbl ! v == (m, val) -==> -var v .+. m .==. constant val --} - --- | Basic variables -type RowIndex = Int - --- | Non-basic variables -type ColIndex = Int - -type Row r = (VarMap r, r) - -data PivotResult r = PivotUnbounded | PivotFinished | PivotSuccess (Tableau r) - deriving (Show, Eq, Ord) - -emptyTableau :: Tableau r -emptyTableau = IM.empty - -objRowIndex :: RowIndex -objRowIndex = -1 - -pivot :: (Fractional r, Eq r) => RowIndex -> ColIndex -> Tableau r -> Tableau r -{-# INLINE pivot #-} -{-# SPECIALIZE pivot :: RowIndex -> ColIndex -> Tableau Rational -> Tableau Rational #-} -{-# SPECIALIZE pivot :: RowIndex -> ColIndex -> Tableau Double -> Tableau Double #-} -pivot r s tbl = - assert (isValidTableau tbl) $ -- precondition - assert (isValidTableau tbl') $ -- postcondition - tbl' - where - tbl' = IM.insert s row_s $ IM.map f $ IM.delete r $ tbl - f orig@(row_i, row_i_val) = - case IM.lookup s row_i of - Nothing -> orig - Just c -> - ( IM.filter (0/=) $ IM.unionWith (+) (IM.delete s row_i) (IM.map (negate c *) row_r') - , row_i_val - c*row_r_val' - ) - (row_r, row_r_val) = lookupRow r tbl - a_rs = row_r IM.! s - row_r' = IM.map (/ a_rs) $ IM.insert r 1 $ IM.delete s row_r - row_r_val' = row_r_val / a_rs - row_s = (row_r', row_r_val') - --- | Lookup a row by basic variable -lookupRow :: RowIndex -> Tableau r -> Row r -lookupRow r m = m IM.! r - --- 行の基底変数の列が0になるように変形 -normalizeRow :: (Num r, Eq r) => Tableau r -> Row r -> Row r -normalizeRow a (row0,val0) = obj' - where - obj' = g $ foldl' f (IM.empty, val0) $ - [ case IM.lookup j a of - Nothing -> (IM.singleton j x, 0) - Just (row,val) -> (IM.map ((-x)*) (IM.delete j row), -x*val) - | (j,x) <- IM.toList row0 ] - f (m1,v1) (m2,v2) = (IM.unionWith (+) m1 m2, v1+v2) - g (m,v) = (IM.filter (0/=) m, v) - -setRow :: (Num r, Eq r) => Tableau r -> RowIndex -> Row r -> Tableau r -setRow tbl i row = assert (isValidTableau tbl) $ assert (isValidTableau tbl') $ tbl' - where - tbl' = IM.insert i (normalizeRow tbl row) tbl - -addRow :: (Num r, Eq r) => Tableau r -> RowIndex -> Row r -> Tableau r -addRow tbl i row = assert (i `IM.notMember` tbl) $ setRow tbl i row - -setObjFun :: (Num r, Eq r) => Tableau r -> LA.Expr r -> Tableau r -setObjFun tbl e = addRow tbl objRowIndex row - where - row = - case LA.extract LA.unitVar e of - (c, e') -> (LA.coeffMap (negateV e'), c) - -copyObjRow :: (Num r, Eq r) => Tableau r -> Tableau r -> Tableau r -copyObjRow from to = - case IM.lookup objRowIndex from of - Nothing -> IM.delete objRowIndex to - Just row -> addRow to objRowIndex row - -currentValue :: Num r => Tableau r -> Var -> r -currentValue tbl v = - case IM.lookup v tbl of - Nothing -> 0 - Just (_, val) -> val - -currentObjValue :: Num r => Tableau r -> r -currentObjValue = snd . lookupRow objRowIndex - -isValidTableau :: Tableau r -> Bool -isValidTableau tbl = - and [v `IM.notMember` m | (v, (m,_)) <- IM.toList tbl, v /= objRowIndex] && - and [IS.null (IM.keysSet m `IS.intersection` vs) | (m,_) <- IM.elems tbl'] - where - tbl' = IM.delete objRowIndex tbl - vs = IM.keysSet tbl' - -isFeasible :: Real r => Tableau r -> Bool -isFeasible tbl = - and [val >= 0 | (v, (_,val)) <- IM.toList tbl, v /= objRowIndex] - -isOptimal :: Real r => OptDir -> Tableau r -> Bool -isOptimal optdir tbl = - and [not (cmp cj) | cj <- IM.elems (fst (lookupRow objRowIndex tbl))] - where - cmp = case optdir of - OptMin -> (0<) - OptMax -> (0>) - -isImproving :: Real r => OptDir -> Tableau r -> Tableau r -> Bool -isImproving OptMin from to = currentObjValue to <= currentObjValue from -isImproving OptMax from to = currentObjValue to >= currentObjValue from - --- --------------------------------------------------------------------------- --- primal simplex - -simplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) -{-# SPECIALIZE simplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} -{-# SPECIALIZE simplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} -simplex optdir = go - where - go tbl = assert (isFeasible tbl) $ - case primalPivot optdir tbl of - PivotFinished -> assert (isOptimal optdir tbl) (True, tbl) - PivotUnbounded -> (False, tbl) - PivotSuccess tbl' -> assert (isImproving optdir tbl tbl') $ go tbl' - -primalPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> PivotResult r -{-# INLINE primalPivot #-} -primalPivot optdir tbl - | null cs = PivotFinished - | null rs = PivotUnbounded - | otherwise = PivotSuccess (pivot r s tbl) - where - cmp = case optdir of - OptMin -> (0<) - OptMax -> (0>) - cs = [(j,cj) | (j,cj) <- IM.toList (fst (lookupRow objRowIndex tbl)), cmp cj] - -- smallest subscript rule - s = fst $ head cs - -- classical rule - --s = fst $ (if optdir==OptMin then maximumBy else minimumBy) (compare `on` snd) cs - rs = [ (i, y_i0 / y_is) - | (i, (row_i, y_i0)) <- IM.toList tbl, i /= objRowIndex - , let y_is = IM.findWithDefault 0 s row_i, y_is > 0 - ] - r = fst $ minimumBy (comparing snd) rs - --- --------------------------------------------------------------------------- --- dual simplex - -dualSimplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) -{-# SPECIALIZE dualSimplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} -{-# SPECIALIZE dualSimplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} -dualSimplex optdir = go - where - go tbl = assert (isOptimal optdir tbl) $ - case dualPivot optdir tbl of - PivotFinished -> assert (isFeasible tbl) $ (True, tbl) - PivotUnbounded -> (False, tbl) - PivotSuccess tbl' -> assert (isImproving optdir tbl' tbl) $ go tbl' - -dualPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> PivotResult r -{-# INLINE dualPivot #-} -dualPivot optdir tbl - | null rs = PivotFinished - | null cs = PivotUnbounded - | otherwise = PivotSuccess (pivot r s tbl) - where - rs = [(i, row_i) | (i, (row_i, y_i0)) <- IM.toList tbl, i /= objRowIndex, 0 > y_i0] - (r, row_r) = head rs - cs = [ (j, if optdir==OptMin then y_0j / y_rj else - y_0j / y_rj) - | (j, y_rj) <- IM.toList row_r - , y_rj < 0 - , let y_0j = IM.findWithDefault 0 j obj - ] - s = fst $ minimumBy (comparing snd) cs - (obj,_) = lookupRow objRowIndex tbl - --- --------------------------------------------------------------------------- --- phase I of the two-phased method - -phaseI :: (Real r, Fractional r) => Tableau r -> VarSet -> (Bool, Tableau r) -{-# SPECIALIZE phaseI :: Tableau Rational -> VarSet -> (Bool, Tableau Rational) #-} -{-# SPECIALIZE phaseI :: Tableau Double -> VarSet -> (Bool, Tableau Double) #-} -phaseI tbl avs - | currentObjValue tbl1' /= 0 = (False, tbl1') - | otherwise = (True, copyObjRow tbl $ removeArtificialVariables avs $ tbl1') - where - optdir = OptMax - tbl1 = setObjFun tbl $ negateV $ sumV [LA.var v | v <- IS.toList avs] - tbl1' = go tbl1 - go tbl2 - | currentObjValue tbl2 == 0 = tbl2 - | otherwise = - case primalPivot optdir tbl2 of - PivotSuccess tbl2' -> assert (isImproving optdir tbl2 tbl2') $ go tbl2' - PivotFinished -> assert (isOptimal optdir tbl2) tbl2 - PivotUnbounded -> error "phaseI: should not happen" - --- post-processing of phaseI --- pivotを使ってartificial variablesを基底から除いて、削除 -removeArtificialVariables :: (Real r, Fractional r) => VarSet -> Tableau r -> Tableau r -removeArtificialVariables avs tbl0 = tbl2 - where - tbl1 = foldl' f (IM.delete objRowIndex tbl0) (IS.toList avs) - tbl2 = IM.map (\(row,val) -> (IM.filterWithKey (\j _ -> j `IS.notMember` avs) row, val)) tbl1 - f tbl i = - case IM.lookup i tbl of - Nothing -> tbl - Just row -> - case [j | (j,c) <- IM.toList (fst row), c /= 0, j `IS.notMember` avs] of - [] -> IM.delete i tbl - j:_ -> pivot i j tbl - --- --------------------------------------------------------------------------- --- primal-dual simplex - -data PDResult = PDUnsat | PDOptimal | PDUnbounded - -primalDualSimplex :: (Real r, Fractional r) => OptDir -> Tableau r -> (Bool, Tableau r) -{-# SPECIALIZE primalDualSimplex :: OptDir -> Tableau Rational -> (Bool, Tableau Rational) #-} -{-# SPECIALIZE primalDualSimplex :: OptDir -> Tableau Double -> (Bool, Tableau Double) #-} -primalDualSimplex optdir = go - where - go tbl = - case pdPivot optdir tbl of - Left PDOptimal -> assert (isFeasible tbl) $ assert (isOptimal optdir tbl) $ (True, tbl) - Left PDUnsat -> assert (not (isFeasible tbl)) $ (False, tbl) - Left PDUnbounded -> assert (not (isOptimal optdir tbl)) $ (False, tbl) - Right tbl' -> go tbl' - -pdPivot :: (Real r, Fractional r) => OptDir -> Tableau r -> Either PDResult (Tableau r) -pdPivot optdir tbl - | null ps && null qs = Left PDOptimal -- optimal - | otherwise = - case ret of - Left p -> -- primal update - let rs = [ (i, (bi - t) / y_ip) - | (i, (row_i, bi)) <- IM.toList tbl, i /= objRowIndex - , let y_ip = IM.findWithDefault 0 p row_i, y_ip > 0 - ] - q = fst $ minimumBy (comparing snd) rs - in if null rs - then Left PDUnsat - else Right (pivot q p tbl) - Right q -> -- dual update - let (row_q, _bq) = (tbl IM.! q) - cs = [ (j, (cj'-t) / (-y_qj)) - | (j, y_qj) <- IM.toList row_q - , y_qj < 0 - , let cj = IM.findWithDefault 0 j obj - , let cj' = if optdir==OptMax then cj else -cj - ] - p = fst $ maximumBy (comparing snd) cs - (obj,_) = lookupRow objRowIndex tbl - in if null cs - then Left PDUnbounded -- dual infeasible - else Right (pivot q p tbl) - where - qs = [ (Right i, bi) | (i, (row_i, bi)) <- IM.toList tbl, i /= objRowIndex, 0 > bi ] - ps = [ (Left j, cj') - | (j,cj) <- IM.toList (fst (lookupRow objRowIndex tbl)) - , let cj' = if optdir==OptMax then cj else -cj - , 0 > cj' ] - (ret, t) = minimumBy (comparing snd) (qs ++ ps) - --- --------------------------------------------------------------------------- - -toCSV :: (Num r, Eq r, Show r) => (r -> String) -> Tableau r -> String -toCSV showCell tbl = unlines . map (concat . intersperse ",") $ header : body - where - header :: [String] - header = "" : map colName cols ++ [""] - - body :: [[String]] - body = [showRow i (lookupRow i tbl) | i <- rows] - - rows :: [RowIndex] - rows = IM.keys (IM.delete objRowIndex tbl) ++ [objRowIndex] - - cols :: [ColIndex] - cols = [0..colMax] - where - colMax = maximum (-1 : [c | (row, _) <- IM.elems tbl, c <- IM.keys row]) - - rowName :: RowIndex -> String - rowName i = if i==objRowIndex then "obj" else "x" ++ show i - - colName :: ColIndex -> String - colName j = "x" ++ show j - - showRow i (row, row_val) = rowName i : [showCell (IM.findWithDefault 0 j row') | j <- cols] ++ [showCell row_val] - where row' = IM.insert i 1 row - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Simplex2.hs b/src/ToySolver/Simplex2.hs deleted file mode 100644 --- a/src/ToySolver/Simplex2.hs +++ /dev/null @@ -1,1029 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Simplex2 --- Copyright : (c) Masahiro Sakai 2012 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP) --- --- Naïve implementation of Simplex method --- --- Reference: --- --- * --- --- * Bruno Dutertre and Leonardo de Moura. --- A Fast Linear-Arithmetic Solver for DPLL(T). --- Computer Aided Verification In Computer Aided Verification, Vol. 4144 (2006), pp. 81-94. --- --- --- * Bruno Dutertre and Leonardo de Moura. --- Integrating Simplex with DPLL(T). --- CSL Technical Report SRI-CSL-06-01. 2006. --- --- ------------------------------------------------------------------------------ -module ToySolver.Simplex2 - ( - -- * The @Solver@ type - Solver - , GenericSolver - , SolverValue (..) - , newSolver - , cloneSolver - - -- * Problem specification - , Var - , newVar - , RelOp (..) - , (.<=.), (.>=.), (.==.), (.<.), (.>.) - , Atom (..) - , assertAtom - , assertAtomEx - , assertLower - , assertUpper - , setObj - , getObj - , OptDir (..) - , setOptDir - , getOptDir - - -- * Solving - , check - , Options (..) - , defaultOptions - , OptResult (..) - , optimize - , dualSimplex - - -- * Extract results - , Model - , model - , RawModel - , rawModel - , getValue - , getObjValue - - -- * Reading status - , getTableau - , getRow - , getCol - , getCoeff - , nVars - , isBasicVariable - , isNonBasicVariable - , isFeasible - , isOptimal - , getLB - , getUB - - -- * Configulation - , setLogger - , clearLogger - , PivotStrategy (..) - , setPivotStrategy - - -- * Debug - , dump - ) where - -import Prelude hiding (log) -import Control.Exception -import Control.Monad -import Data.Ord -import Data.IORef -import Data.List -import Data.Maybe -import Data.Ratio -import Data.Map (Map) -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Text.Printf -import Data.Time -import Data.OptDir -import Data.VectorSpace -import System.CPUTime - -import qualified ToySolver.Data.LA as LA -import ToySolver.Data.LA (Atom (..)) -import ToySolver.Data.ArithRel -import ToySolver.Data.Delta -import ToySolver.Internal.Util (showRational) - -{-------------------------------------------------------------------- - The @Solver@ type ---------------------------------------------------------------------} - -type Var = Int - -data GenericSolver v - = GenericSolver - { svTableau :: !(IORef (IntMap (LA.Expr Rational))) - , svLB :: !(IORef (IntMap v)) - , svUB :: !(IORef (IntMap v)) - , svModel :: !(IORef (IntMap v)) - , svVCnt :: !(IORef Int) - , svOk :: !(IORef Bool) - , svOptDir :: !(IORef OptDir) - - , svDefDB :: !(IORef (Map (LA.Expr Rational) Var)) - - , svLogger :: !(IORef (Maybe (String -> IO ()))) - , svPivotStrategy :: !(IORef PivotStrategy) - , svNPivot :: !(IORef Int) - } - -type Solver = GenericSolver Rational - --- special basic variable -objVar :: Int -objVar = -1 - -newSolver :: SolverValue v => IO (GenericSolver v) -newSolver = do - t <- newIORef (IntMap.singleton objVar zeroV) - l <- newIORef IntMap.empty - u <- newIORef IntMap.empty - m <- newIORef (IntMap.singleton objVar zeroV) - v <- newIORef 0 - ok <- newIORef True - dir <- newIORef OptMin - defs <- newIORef Map.empty - logger <- newIORef Nothing - pivot <- newIORef PivotStrategyBlandRule - npivot <- newIORef 0 - return $ - GenericSolver - { svTableau = t - , svLB = l - , svUB = u - , svModel = m - , svVCnt = v - , svOk = ok - , svOptDir = dir - , svDefDB = defs - , svLogger = logger - , svNPivot = npivot - , svPivotStrategy = pivot - } - -cloneSolver :: GenericSolver v -> IO (GenericSolver v) -cloneSolver solver = do - t <- newIORef =<< readIORef (svTableau solver) - l <- newIORef =<< readIORef (svLB solver) - u <- newIORef =<< readIORef (svUB solver) - m <- newIORef =<< readIORef (svModel solver) - v <- newIORef =<< readIORef (svVCnt solver) - ok <- newIORef =<< readIORef (svOk solver) - dir <- newIORef =<< readIORef (svOptDir solver) - defs <- newIORef =<< readIORef (svDefDB solver) - logger <- newIORef =<< readIORef (svLogger solver) - pivot <- newIORef =<< readIORef (svPivotStrategy solver) - npivot <- newIORef =<< readIORef (svNPivot solver) - return $ - GenericSolver - { svTableau = t - , svLB = l - , svUB = u - , svModel = m - , svVCnt = v - , svOk = ok - , svOptDir = dir - , svDefDB = defs - , svLogger = logger - , svNPivot = npivot - , svPivotStrategy = pivot - } - -class (VectorSpace v, Scalar v ~ Rational, Ord v) => SolverValue v where - toValue :: Rational -> v - showValue :: Bool -> v -> String - model :: GenericSolver v -> IO Model - -instance SolverValue Rational where - toValue = id - showValue = showRational - model = rawModel - -instance SolverValue (Delta Rational) where - toValue = fromReal - showValue = showDelta - model solver = do - xs <- variables solver - ys <- liftM concat $ forM xs $ \x -> do - Delta p q <- getValue solver x - lb <- getLB solver x - ub <- getUB solver x - return $ - [(p - c) / (k - q) | Just (Delta c k) <- return lb, c < p, k > q] ++ - [(d - p) / (q - h) | Just (Delta d h) <- return ub, p < d, q > h] - let delta0 :: Rational - delta0 = if null ys then 0.1 else minimum ys - f :: Delta Rational -> Rational - f (Delta r k) = r + k * delta0 - liftM (IntMap.map f) $ readIORef (svModel solver) - -{- -Largest coefficient rule: original rule suggested by G. Dantzig. -Largest increase rule: computationally more expensive in comparison with Largest coefficient, but locally maximizes the progress. -Steepest edge rule: best pivot rule in practice, an efficient approximate implementation is "Devex". -Bland’s rule: avoids cycling but one of the slowest rules. -Random edge rule: Randomized have lead to the current best provable bounds for the number of pivot steps of the simplex method. -Lexicographic rule: used for avoiding cyclying. --} -data PivotStrategy - = PivotStrategyBlandRule - | PivotStrategyLargestCoefficient --- | PivotStrategySteepestEdge - deriving (Eq, Ord, Enum, Show, Read) - -setPivotStrategy :: GenericSolver v -> PivotStrategy -> IO () -setPivotStrategy solver ps = writeIORef (svPivotStrategy solver) ps - -{-------------------------------------------------------------------- - problem description ---------------------------------------------------------------------} - -newVar :: SolverValue v => GenericSolver v -> IO Var -newVar solver = do - v <- readIORef (svVCnt solver) - writeIORef (svVCnt solver) $! v+1 - modifyIORef (svModel solver) (IntMap.insert v zeroV) - return v - -assertAtom :: Solver -> LA.Atom Rational -> IO () -assertAtom solver atom = do - (v,op,rhs') <- simplifyAtom solver atom - case op of - Le -> assertUpper solver v (toValue rhs') - Ge -> assertLower solver v (toValue rhs') - Eql -> do - assertLower solver v (toValue rhs') - assertUpper solver v (toValue rhs') - _ -> error "unsupported" - return () - -assertAtomEx :: GenericSolver (Delta Rational) -> LA.Atom Rational -> IO () -assertAtomEx solver atom = do - (v,op,rhs') <- simplifyAtom solver atom - case op of - Le -> assertUpper solver v (toValue rhs') - Ge -> assertLower solver v (toValue rhs') - Lt -> assertUpper solver v (toValue rhs' ^-^ delta) - Gt -> assertLower solver v (toValue rhs' ^+^ delta) - Eql -> do - assertLower solver v (toValue rhs') - assertUpper solver v (toValue rhs') - return () - -simplifyAtom :: SolverValue v => GenericSolver v -> LA.Atom Rational -> IO (Var, RelOp, Rational) -simplifyAtom solver (Rel lhs op rhs) = do - let (lhs',rhs') = - case LA.extract LA.unitVar (lhs ^-^ rhs) of - (n,e) -> (e, -n) - case LA.terms lhs' of - [(1,v)] -> return (v, op, rhs') - [(-1,v)] -> return (v, flipOp op, -rhs') - _ -> do - defs <- readIORef (svDefDB solver) - let (c,lhs'') = scale lhs' -- lhs' = lhs'' / c = rhs' - rhs'' = c *^ rhs' - op'' = if c < 0 then flipOp op else op - case Map.lookup lhs'' defs of - Just v -> do - return (v,op'',rhs'') - Nothing -> do - v <- newVar solver - setRow solver v lhs'' - modifyIORef (svDefDB solver) $ Map.insert lhs'' v - return (v,op'',rhs'') - where - scale :: LA.Expr Rational -> (Rational, LA.Expr Rational) - scale e = (c, c *^ e) - where - c = c1 * c2 - c1 = fromIntegral $ foldl' lcm 1 [denominator c | (c, _) <- LA.terms e] - c2 = signum $ head ([c | (c,x) <- LA.terms e] ++ [1]) - -assertLower :: SolverValue v => GenericSolver v -> Var -> v -> IO () -assertLower solver x l = do - l0 <- getLB solver x - u0 <- getUB solver x - case (l0,u0) of - (Just l0', _) | l <= l0' -> return () - (_, Just u0') | u0' < l -> markBad solver - _ -> do - modifyIORef (svLB solver) (IntMap.insert x l) - b <- isNonBasicVariable solver x - v <- getValue solver x - when (b && not (l <= v)) $ update solver x l - checkNBFeasibility solver - -assertUpper :: SolverValue v => GenericSolver v -> Var -> v -> IO () -assertUpper solver x u = do - l0 <- getLB solver x - u0 <- getUB solver x - case (l0,u0) of - (_, Just u0') | u0' <= u -> return () - (Just l0', _) | u < l0' -> markBad solver - _ -> do - modifyIORef (svUB solver) (IntMap.insert x u) - b <- isNonBasicVariable solver x - v <- getValue solver x - when (b && not (v <= u)) $ update solver x u - checkNBFeasibility solver - --- FIXME: 式に定数項が含まれる可能性を考えるとこれじゃまずい? -setObj :: SolverValue v => GenericSolver v -> LA.Expr Rational -> IO () -setObj solver e = setRow solver objVar e - -getObj :: SolverValue v => GenericSolver v -> IO (LA.Expr Rational) -getObj solver = getRow solver objVar - -setRow :: SolverValue v => GenericSolver v -> Var -> LA.Expr Rational -> IO () -setRow solver v e = do - modifyIORef (svTableau solver) $ \t -> - IntMap.insert v (LA.applySubst t e) t - modifyIORef (svModel solver) $ \m -> - IntMap.insert v (LA.evalLinear m (toValue 1) e) m - -setOptDir :: GenericSolver v -> OptDir -> IO () -setOptDir solver dir = writeIORef (svOptDir solver) dir - -getOptDir :: GenericSolver v -> IO OptDir -getOptDir solver = readIORef (svOptDir solver) - -{-------------------------------------------------------------------- - Status ---------------------------------------------------------------------} - -nVars :: GenericSolver v -> IO Int -nVars solver = readIORef (svVCnt solver) - -isBasicVariable :: GenericSolver v -> Var -> IO Bool -isBasicVariable solver v = do - t <- readIORef (svTableau solver) - return $ v `IntMap.member` t - -isNonBasicVariable :: GenericSolver v -> Var -> IO Bool -isNonBasicVariable solver x = liftM not (isBasicVariable solver x) - -isFeasible :: SolverValue v => GenericSolver v -> IO Bool -isFeasible solver = do - xs <- variables solver - liftM and $ forM xs $ \x -> do - v <- getValue solver x - l <- getLB solver x - u <- getUB solver x - return (testLB l v && testUB u v) - -isOptimal :: SolverValue v => GenericSolver v -> IO Bool -isOptimal solver = do - obj <- getRow solver objVar - ret <- selectEnteringVariable solver - return $! isNothing ret - -{-------------------------------------------------------------------- - Satisfiability solving ---------------------------------------------------------------------} - -check :: SolverValue v => GenericSolver v -> IO Bool -check solver = do - let - loop :: IO Bool - loop = do - m <- selectViolatingBasicVariable solver - - case m of - Nothing -> return True - Just xi -> do - li <- getLB solver xi - ui <- getUB solver xi - isLBViolated <- do - vi <- getValue solver xi - return $ not (testLB li vi) - let q = if isLBViolated - then -- select the smallest non-basic variable xj such that - -- (aij > 0 and β(xj) < uj) or (aij < 0 and β(xj) > lj) - canIncrease solver - else -- select the smallest non-basic variable xj such that - -- (aij < 0 and β(xj) < uj) or (aij > 0 and β(xj) > lj) - canDecrease solver - xi_def <- getRow solver xi - r <- liftM (fmap snd) $ findM q (LA.terms xi_def) - case r of - Nothing -> markBad solver >> return False - Just xj -> do - pivotAndUpdate solver xi xj (fromJust (if isLBViolated then li else ui)) - loop - - ok <- readIORef (svOk solver) - if not ok - then return False - else do - log solver "check" - result <- recordTime solver loop - when result $ checkFeasibility solver - return result - -selectViolatingBasicVariable :: SolverValue v => GenericSolver v -> IO (Maybe Var) -selectViolatingBasicVariable solver = do - let - p :: Var -> IO Bool - p x | x == objVar = return False - p xi = do - li <- getLB solver xi - ui <- getUB solver xi - vi <- getValue solver xi - return $ not (testLB li vi) || not (testUB ui vi) - vs <- basicVariables solver - - ps <- readIORef (svPivotStrategy solver) - case ps of - PivotStrategyBlandRule -> - findM p vs - PivotStrategyLargestCoefficient -> do - xs <- filterM p vs - case xs of - [] -> return Nothing - _ -> do - xs2 <- forM xs $ \xi -> do - vi <- getValue solver xi - li <- getLB solver xi - ui <- getUB solver xi - if not (testLB li vi) - then return (xi, fromJust li ^-^ vi) - else return (xi, vi ^-^ fromJust ui) - return $ Just $ fst $ maximumBy (comparing snd) xs2 - -{-------------------------------------------------------------------- - Optimization ---------------------------------------------------------------------} - --- | results of optimization -data OptResult = Optimum | Unsat | Unbounded | ObjLimit - deriving (Show, Eq, Ord) - -data Options - = Options - { objLimit :: Maybe Rational - } - deriving (Show, Eq, Ord) - -defaultOptions :: Options -defaultOptions - = Options - { objLimit = Nothing - } - -optimize :: Solver -> Options -> IO OptResult -optimize solver opt = do - ret <- do - is_fea <- isFeasible solver - if is_fea then return True else check solver - if not ret - then return Unsat -- unsat - else do - log solver "optimize" - result <- recordTime solver loop - when (result == Optimum) $ checkOptimality solver - return result - where - loop :: IO OptResult - loop = do - checkFeasibility solver - ret <- selectEnteringVariable solver - case ret of - Nothing -> return Optimum - Just (c,xj) -> do - dir <- getOptDir solver - r <- if dir==OptMin - then if c > 0 - then decreaseNB solver xj -- xj を小さくして目的関数を小さくする - else increaseNB solver xj -- xj を大きくして目的関数を小さくする - else if c > 0 - then increaseNB solver xj -- xj を大きくして目的関数を大きくする - else decreaseNB solver xj -- xj を小さくして目的関数を大きくする - if r - then loop - else return Unbounded - -selectEnteringVariable :: SolverValue v => GenericSolver v -> IO (Maybe (Rational, Var)) -selectEnteringVariable solver = do - ps <- readIORef (svPivotStrategy solver) - obj_def <- getRow solver objVar - case ps of - PivotStrategyBlandRule -> - findM canEnter (LA.terms obj_def) - PivotStrategyLargestCoefficient -> do - ts <- filterM canEnter (LA.terms obj_def) - case ts of - [] -> return Nothing - _ -> return $ Just $ snd $ maximumBy (comparing fst) [(abs c, (c,xj)) | (c,xj) <- ts] - where - canEnter :: (Rational, Var) -> IO Bool - canEnter (_,xj) | xj == LA.unitVar = return False - canEnter (c,xj) = do - dir <- getOptDir solver - if dir==OptMin - then canDecrease solver (c,xj) - else canIncrease solver (c,xj) - -canIncrease :: SolverValue v => GenericSolver v -> (Rational,Var) -> IO Bool -canIncrease solver (a,x) = - case compare a 0 of - EQ -> return False - GT -> canIncrease1 solver x - LT -> canDecrease1 solver x - -canDecrease :: SolverValue v => GenericSolver v -> (Rational,Var) -> IO Bool -canDecrease solver (a,x) = - case compare a 0 of - EQ -> return False - GT -> canDecrease1 solver x - LT -> canIncrease1 solver x - -canIncrease1 :: SolverValue v => GenericSolver v -> Var -> IO Bool -canIncrease1 solver x = do - u <- getUB solver x - v <- getValue solver x - case u of - Nothing -> return True - Just uv -> return $! (v < uv) - -canDecrease1 :: SolverValue v => GenericSolver v -> Var -> IO Bool -canDecrease1 solver x = do - l <- getLB solver x - v <- getValue solver x - case l of - Nothing -> return True - Just lv -> return $! (lv < v) - --- | feasibility を保ちつつ non-basic variable xj の値を大きくする -increaseNB :: Solver -> Var -> IO Bool -increaseNB solver xj = do - col <- getCol solver xj - - -- Upper bounds of θ - -- NOTE: xj 自体の上限も考慮するのに注意 - ubs <- liftM concat $ forM ((xj,1) : IntMap.toList col) $ \(xi,aij) -> do - v1 <- getValue solver xi - li <- getLB solver xi - ui <- getUB solver xi - return [ assert (theta >= zeroV) ((xi,v2), theta) - | Just v2 <- [ui | aij > 0] ++ [li | aij < 0] - , let theta = (v2 ^-^ v1) ^/ aij ] - - -- β(xj) := β(xj) + θ なので θ を大きく - case ubs of - [] -> return False -- unbounded - _ -> do - let (xi, v) = fst $ minimumBy (comparing snd) ubs - pivotAndUpdate solver xi xj v - return True - --- | feasibility を保ちつつ non-basic variable xj の値を小さくする -decreaseNB :: Solver -> Var -> IO Bool -decreaseNB solver xj = do - col <- getCol solver xj - - -- Lower bounds of θ - -- NOTE: xj 自体の下限も考慮するのに注意 - lbs <- liftM concat $ forM ((xj,1) : IntMap.toList col) $ \(xi,aij) -> do - v1 <- getValue solver xi - li <- getLB solver xi - ui <- getUB solver xi - return [ assert (theta <= zeroV) ((xi,v2), theta) - | Just v2 <- [li | aij > 0] ++ [ui | aij < 0] - , let theta = (v2 ^-^ v1) ^/ aij ] - - -- β(xj) := β(xj) + θ なので θ を小さく - case lbs of - [] -> return False -- unbounded - _ -> do - let (xi, v) = fst $ maximumBy (comparing snd) lbs - pivotAndUpdate solver xi xj v - return True - -dualSimplex :: Solver -> Options -> IO OptResult -dualSimplex solver opt = do - let - loop :: IO OptResult - loop = do - checkOptimality solver - - p <- prune solver opt - if p - then return ObjLimit - else do - m <- selectViolatingBasicVariable solver - case m of - Nothing -> return Optimum - Just xi -> do - xi_def <- getRow solver xi - li <- getLB solver xi - ui <- getUB solver xi - isLBViolated <- do - vi <- getValue solver xi - return $ not (testLB li vi) - r <- dualRTest solver xi_def isLBViolated - case r of - Nothing -> markBad solver >> return Unsat -- dual unbounded - Just xj -> do - pivotAndUpdate solver xi xj (fromJust (if isLBViolated then li else ui)) - loop - - ok <- readIORef (svOk solver) - if not ok - then return Unsat - else do - log solver "dual simplex" - result <- recordTime solver loop - when (result == Optimum) $ checkFeasibility solver - return result - -dualRTest :: Solver -> LA.Expr Rational -> Bool -> IO (Maybe Var) -dualRTest solver row isLBViolated = do - -- normalize to the cases of minimization - obj_def <- do - def <- getRow solver objVar - dir <- getOptDir solver - return $ - case dir of - OptMin -> def - OptMax -> negateV def - -- normalize to the cases of lower bound violation - let xi_def = - if isLBViolated - then row - else negateV row - ws <- do - -- select non-basic variable xj such that - -- (aij > 0 and β(xj) < uj) or (aij < 0 and β(xj) > lj) - liftM concat $ forM (LA.terms xi_def) $ \(aij, xj) -> do - b <- canIncrease solver (aij, xj) - if b - then do - let cj = LA.coeff xj obj_def - let ratio = cj / aij - return [(xj, ratio) | ratio >= 0] - else - return [] - case ws of - [] -> return Nothing - _ -> return $ Just $ fst $ minimumBy (comparing snd) ws - -prune :: Solver -> Options -> IO Bool -prune solver opt = - case objLimit opt of - Nothing -> return False - Just lim -> do - o <- getObjValue solver - dir <- getOptDir solver - case dir of - OptMin -> return $! (lim <= o) - OptMax -> return $! (lim >= o) - -{-------------------------------------------------------------------- - Extract results ---------------------------------------------------------------------} - -type RawModel v = IntMap v - -rawModel :: GenericSolver v -> IO (RawModel v) -rawModel solver = do - xs <- variables solver - liftM IntMap.fromList $ forM xs $ \x -> do - val <- getValue solver x - return (x,val) - -getObjValue :: GenericSolver v -> IO v -getObjValue solver = getValue solver objVar - -type Model = IntMap Rational - -{-------------------------------------------------------------------- - major function ---------------------------------------------------------------------} - -update :: SolverValue v => GenericSolver v -> Var -> v -> IO () -update solver xj v = do - -- log solver $ printf "before update x%d (%s)" xj (show v) - -- dump solver - - v0 <- getValue solver xj - let diff = v ^-^ v0 - - aj <- getCol solver xj - modifyIORef (svModel solver) $ \m -> - let m2 = IntMap.map (\aij -> aij *^ diff) aj - in IntMap.insert xj v $ IntMap.unionWith (^+^) m2 m - - -- log solver $ printf "after update x%d (%s)" xj (show v) - -- dump solver - -pivot :: SolverValue v => GenericSolver v -> Var -> Var -> IO () -pivot solver xi xj = do - modifyIORef' (svNPivot solver) (+1) - modifyIORef' (svTableau solver) $ \defs -> - case LA.solveFor (LA.var xi .==. (defs IntMap.! xi)) xj of - Just (Eql, xj_def) -> - IntMap.insert xj xj_def . IntMap.map (LA.applySubst1 xj xj_def) . IntMap.delete xi $ defs - _ -> error "pivot: should not happen" - -pivotAndUpdate :: SolverValue v => GenericSolver v -> Var -> Var -> v -> IO () -pivotAndUpdate solver xi xj v | xi == xj = update solver xi v -- xi = xj is non-basic variable -pivotAndUpdate solver xi xj v = do - -- xi is basic variable - -- xj is non-basic varaible - - -- log solver $ printf "before pivotAndUpdate x%d x%d (%s)" xi xj (show v) - -- dump solver - - m <- readIORef (svModel solver) - - aj <- getCol solver xj - let aij = aj IntMap.! xi - let theta = (v ^-^ (m IntMap.! xi)) ^/ aij - - let m' = IntMap.fromList $ - [(xi, v), (xj, (m IntMap.! xj) ^+^ theta)] ++ - [(xk, (m IntMap.! xk) ^+^ (akj *^ theta)) | (xk, akj) <- IntMap.toList aj, xk /= xi] - writeIORef (svModel solver) (IntMap.union m' m) -- note that 'IntMap.union' is left biased. - - pivot solver xi xj - - -- log solver $ printf "after pivotAndUpdate x%d x%d (%s)" xi xj (show v) - -- dump solver - -getLB :: GenericSolver v -> Var -> IO (Maybe v) -getLB solver x = do - lb <- readIORef (svLB solver) - return $ IntMap.lookup x lb - -getUB :: GenericSolver v -> Var -> IO (Maybe v) -getUB solver x = do - ub <- readIORef (svUB solver) - return $ IntMap.lookup x ub - -getTableau :: GenericSolver v -> IO (IntMap (LA.Expr Rational)) -getTableau solver = do - t <- readIORef (svTableau solver) - return $ IntMap.delete objVar t - -getValue :: GenericSolver v -> Var -> IO v -getValue solver x = do - m <- readIORef (svModel solver) - return $ m IntMap.! x - -getRow :: GenericSolver v -> Var -> IO (LA.Expr Rational) -getRow solver x = do - -- x should be basic variable or 'objVar' - t <- readIORef (svTableau solver) - return $! (t IntMap.! x) - --- aijが非ゼロの列も全部探しているのは効率が悪い -getCol :: SolverValue v => GenericSolver v -> Var -> IO (IntMap Rational) -getCol solver xj = do - t <- readIORef (svTableau solver) - return $ IntMap.mapMaybe (LA.lookupCoeff xj) t - -getCoeff :: GenericSolver v -> Var -> Var -> IO Rational -getCoeff solver xi xj = do - xi_def <- getRow solver xi - return $! LA.coeff xj xi_def - -markBad :: GenericSolver v -> IO () -markBad solver = writeIORef (svOk solver) False - -{-------------------------------------------------------------------- - utility ---------------------------------------------------------------------} - -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -findM _ [] = return Nothing -findM p (x:xs) = do - r <- p x - if r - then return (Just x) - else findM p xs - -testLB :: SolverValue v => Maybe v -> v -> Bool -testLB Nothing _ = True -testLB (Just l) x = l <= x - -testUB :: SolverValue v => Maybe v -> v -> Bool -testUB Nothing _ = True -testUB (Just u) x = x <= u - -variables :: GenericSolver v -> IO [Var] -variables solver = do - vcnt <- nVars solver - return [0..vcnt-1] - -basicVariables :: GenericSolver v -> IO [Var] -basicVariables solver = do - t <- readIORef (svTableau solver) - return (IntMap.keys t) - -#if !MIN_VERSION_base(4,6,0) - -modifyIORef' :: IORef a -> (a -> a) -> IO () -modifyIORef' ref f = do - x <- readIORef ref - writeIORef ref $! f x - -#endif - -recordTime :: SolverValue v => GenericSolver v -> IO a -> IO a -recordTime solver act = do - dumpSize solver - writeIORef (svNPivot solver) 0 - - startCPU <- getCPUTime - startWC <- getCurrentTime - - result <- act - - endCPU <- getCPUTime - endWC <- getCurrentTime - - (log solver . printf "cpu time = %.3fs") (fromIntegral (endCPU - startCPU) / 10^(12::Int) :: Double) - (log solver . printf "wall clock time = %.3fs") (realToFrac (endWC `diffUTCTime` startWC) :: Double) - (log solver . printf "#pivot = %d") =<< readIORef (svNPivot solver) - return result - -showDelta :: Bool -> Delta Rational -> String -showDelta asRatio v = - case v of - (Delta r k) -> - f r ++ - case compare k 0 of - EQ -> "" - GT -> " + " ++ f k ++ " delta" - LT -> " - " ++ f (abs k) ++ " delta" - where - f = showRational asRatio - -{-------------------------------------------------------------------- - Logging ---------------------------------------------------------------------} - --- | set callback function for receiving messages. -setLogger :: GenericSolver v -> (String -> IO ()) -> IO () -setLogger solver logger = do - writeIORef (svLogger solver) (Just logger) - -clearLogger :: GenericSolver v -> IO () -clearLogger solver = writeIORef (svLogger solver) Nothing - -log :: GenericSolver v -> String -> IO () -log solver msg = logIO solver (return msg) - -logIO :: GenericSolver v -> IO String -> IO () -logIO solver action = do - m <- readIORef (svLogger solver) - case m of - Nothing -> return () - Just logger -> action >>= logger - -{-------------------------------------------------------------------- - debug and tests ---------------------------------------------------------------------} - -test4 :: IO () -test4 = do - solver <- newSolver - setLogger solver putStrLn - x0 <- newVar solver - x1 <- newVar solver - - writeIORef (svTableau solver) (IntMap.fromList [(x1, LA.var x0)]) - writeIORef (svLB solver) (IntMap.fromList [(x0, toValue 0), (x1, toValue 0)]) - writeIORef (svUB solver) (IntMap.fromList [(x0, toValue 2), (x1, toValue 3)]) - setObj solver (LA.fromTerms [(-1, x0)]) - - ret <- optimize solver defaultOptions - print ret - dump solver - -test5 :: IO () -test5 = do - solver <- newSolver - setLogger solver putStrLn - x0 <- newVar solver - x1 <- newVar solver - - writeIORef (svTableau solver) (IntMap.fromList [(x1, LA.var x0)]) - writeIORef (svLB solver) (IntMap.fromList [(x0, toValue 0), (x1, toValue 0)]) - writeIORef (svUB solver) (IntMap.fromList [(x0, toValue 2), (x1, toValue 0)]) - setObj solver (LA.fromTerms [(-1, x0)]) - - checkFeasibility solver - - ret <- optimize solver defaultOptions - print ret - dump solver - -test6 :: IO () -test6 = do - solver <- newSolver - setLogger solver putStrLn - x0 <- newVar solver - - assertAtom solver (LA.constant 1 .<. LA.var x0) - assertAtom solver (LA.constant 2 .>. LA.var x0) - - ret <- check solver - print ret - dump solver - - m <- model solver - print m - -dumpSize :: SolverValue v => GenericSolver v -> IO () -dumpSize solver = do - t <- readIORef (svTableau solver) - let nrows = IntMap.size t - 1 -- -1 is objVar - xs <- variables solver - let ncols = length xs - nrows - let nnz = sum [IntMap.size $ LA.coeffMap xi_def | (xi,xi_def) <- IntMap.toList t, xi /= objVar] - log solver $ printf "%d rows, %d columns, %d non-zeros" nrows ncols nnz - -dump :: SolverValue v => GenericSolver v -> IO () -dump solver = do - log solver "=============" - - log solver "Tableau:" - t <- readIORef (svTableau solver) - log solver $ printf "obj = %s" (show (t IntMap.! objVar)) - forM_ (IntMap.toList t) $ \(xi, e) -> do - when (xi /= objVar) $ log solver $ printf "x%d = %s" xi (show e) - - log solver "" - - log solver "Assignments and Bounds:" - objVal <- getValue solver objVar - log solver $ printf "beta(obj) = %s" (showValue True objVal) - xs <- variables solver - forM_ xs $ \x -> do - l <- getLB solver x - u <- getUB solver x - v <- getValue solver x - let f Nothing = "Nothing" - f (Just x) = showValue True x - log solver $ printf "beta(x%d) = %s; %s <= x%d <= %s" x (showValue True v) (f l) x (f u) - - log solver "" - log solver "Status:" - is_fea <- isFeasible solver - is_opt <- isOptimal solver - log solver $ printf "Feasible: %s" (show is_fea) - log solver $ printf "Optimal: %s" (show is_opt) - - log solver "=============" - -checkFeasibility :: SolverValue v => GenericSolver v -> IO () -checkFeasibility _ | True = return () -checkFeasibility solver = do - xs <- variables solver - forM_ xs $ \x -> do - v <- getValue solver x - l <- getLB solver x - u <- getUB solver x - let f Nothing = "Nothing" - f (Just x) = showValue True x - unless (testLB l v) $ - error (printf "(%s) <= x%d is violated; x%d = (%s)" (f l) x x (showValue True v)) - unless (testUB u v) $ - error (printf "x%d <= (%s) is violated; x%d = (%s)" x (f u) x (showValue True v)) - return () - -checkNBFeasibility :: SolverValue v => GenericSolver v -> IO () -checkNBFeasibility _ | True = return () -checkNBFeasibility solver = do - xs <- variables solver - forM_ xs $ \x -> do - b <- isNonBasicVariable solver x - when b $ do - v <- getValue solver x - l <- getLB solver x - u <- getUB solver x - let f Nothing = "Nothing" - f (Just x) = showValue True x - unless (testLB l v) $ - error (printf "checkNBFeasibility: (%s) <= x%d is violated; x%d = (%s)" (f l) x x (showValue True v)) - unless (testUB u v) $ - error (printf "checkNBFeasibility: x%d <= (%s) is violated; x%d = (%s)" x (f u) x (showValue True v)) - -checkOptimality :: Solver -> IO () -checkOptimality _ | True = return () -checkOptimality solver = do - ret <- selectEnteringVariable solver - case ret of - Nothing -> return () -- optimal - Just (_,x) -> error (printf "checkOptimality: not optimal (x%d can be changed)" x) diff --git a/src/ToySolver/Text/LPFile.hs b/src/ToySolver/Text/LPFile.hs --- a/src/ToySolver/Text/LPFile.hs +++ b/src/ToySolver/Text/LPFile.hs @@ -24,6 +24,7 @@ module ToySolver.Text.LPFile ( parseString , parseFile + , parser , render ) where @@ -38,9 +39,10 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.OptDir -import Text.ParserCombinators.Parsec hiding (label) +import Text.Parsec hiding (label) +import Text.Parsec.String -import qualified ToySolver.Data.MIP as MIP +import qualified ToySolver.Data.MIP.Base as MIP import ToySolver.Internal.Util (combineMaybe) import ToySolver.Internal.TextUtil (readUnsignedInteger) @@ -49,11 +51,11 @@ -- | Parse a string containing LP file data. -- The source name is only | used in error messages and may be the empty string. parseString :: SourceName -> String -> Either ParseError MIP.Problem -parseString = parse lpfile +parseString = parse parser -- | Parse a file containing LP file data. parseFile :: FilePath -> IO (Either ParseError MIP.Problem) -parseFile = parseFromFile lpfile +parseFile = parseFromFile parser -- --------------------------------------------------------------------------- @@ -110,8 +112,9 @@ -- --------------------------------------------------------------------------- -lpfile :: Parser MIP.Problem -lpfile = do +-- | LP file parser +parser :: Parser MIP.Problem +parser = do sep (flag, obj) <- problem @@ -410,17 +413,22 @@ -- --------------------------------------------------------------------------- --- | Render a problem into a string. -render :: MIP.Problem -> Maybe String -render mip = fmap ($ "") $ execWriterT $ render' $ removeEmptyExpr mip +type M a = Writer ShowS a -type M a = WriterT ShowS Maybe a +execM :: M a -> String +execM m = execWriter m "" writeString :: String -> M () writeString s = tell $ showString s writeChar :: Char -> M () writeChar c = tell $ showChar c + +-- --------------------------------------------------------------------------- + +-- | Render a problem into a string. +render :: MIP.Problem -> Either String String +render mip = Right $ execM $ render' $ removeEmptyExpr mip writeVar :: MIP.Var -> M () writeVar v = writeString $ MIP.fromVar v diff --git a/src/ToySolver/Text/MPSFile.hs b/src/ToySolver/Text/MPSFile.hs --- a/src/ToySolver/Text/MPSFile.hs +++ b/src/ToySolver/Text/MPSFile.hs @@ -25,6 +25,7 @@ module ToySolver.Text.MPSFile ( parseString , parseFile + , parser , render ) where @@ -39,12 +40,13 @@ import Data.Interned import Data.Interned.String -import qualified Text.ParserCombinators.Parsec as P -import Text.ParserCombinators.Parsec hiding (spaces, newline, Column) +import qualified Text.Parsec as P +import Text.Parsec hiding (spaces, newline, Column) +import Text.Parsec.String import Text.Printf import Data.OptDir -import qualified ToySolver.Data.MIP as MIP +import qualified ToySolver.Data.MIP.Base as MIP import ToySolver.Internal.TextUtil (readUnsignedInteger) type Column = MIP.Var @@ -66,14 +68,14 @@ -- --------------------------------------------------------------------------- --- | Parse a string containing LP file data. +-- | Parse a string containing MPS file data. -- The source name is only | used in error messages and may be the empty string. parseString :: SourceName -> String -> Either ParseError MIP.Problem -parseString = parse mpsfile +parseString = parse parser --- | Parse a file containing LP file data. +-- | Parse a file containing MPS file data. parseFile :: FilePath -> IO (Either ParseError MIP.Problem) -parseFile = parseFromFile mpsfile +parseFile = parseFromFile parser -- --------------------------------------------------------------------------- @@ -149,8 +151,9 @@ -- --------------------------------------------------------------------------- -mpsfile :: Parser MIP.Problem -mpsfile = do +-- | MPS file parser +parser :: Parser MIP.Problem +parser = do many commentline _name <- nameSection @@ -202,7 +205,7 @@ case objsense of Nothing -> OptMin Just d -> d - vs = Map.keysSet cols + vs = Map.keysSet cols `Set.union` Set.fromList [col | (_,col,_) <- bnds] intvs2 = Set.fromList [col | (t,col,_) <- bnds, t `elem` [BV,LI,UI]] scvs = Set.fromList [col | (SC,col,_) <- bnds] sivs = Set.fromList [col | (SI,col,_) <- bnds] @@ -274,9 +277,9 @@ rowCoeffs = Map.fromListWith Map.union [(row, Map.singleton col coeff) | (col,m) <- Map.toList cols, (row,coeff) <- Map.toList m] let f :: Bool -> (Maybe MIP.RelOp, Row) -> [MIP.Constraint] - f _isLazy (Nothing, _row) = mzero + f _isLazy (Nothing, _row) = [] f isLazy (Just op, row) = do - let lhs = [MIP.Term c　[col] | (col,c) <- Map.toList (Map.findWithDefault Map.empty row rowCoeffs)] + let lhs = [MIP.Term c [col] | (col,c) <- Map.toList (Map.findWithDefault Map.empty row rowCoeffs)] ++ Map.findWithDefault [] row qterms let rhs = Map.findWithDefault 0 row rhss (op2,rhs2) <- @@ -563,13 +566,23 @@ -- --------------------------------------------------------------------------- -render :: MIP.Problem -> Maybe String -render mip = fmap ($ "") $ execWriterT $ do - guard $ checkAtMostQuadratic mip - render' $ nameRows $ mip +type M a = Writer ShowS a -type M a = WriterT ShowS Maybe a +execM :: M a -> String +execM m = execWriter m "" +writeString :: String -> M () +writeString s = tell $ showString s + +writeChar :: Char -> M () +writeChar c = tell $ showChar c + +-- --------------------------------------------------------------------------- + +render :: MIP.Problem -> Either String String +render mip | not (checkAtMostQuadratic mip) = Left "Expression must be atmost quadratic" +render mip = Right $ execM $ render' $ nameRows mip + render' :: MIP.Problem -> M () render' mip = do let probName = "" @@ -647,9 +660,9 @@ -- BOUNDS section writeSectionHeader "BOUNDS" - forM_ (Map.keys cols) $ \col -> do - let (lb,ub) = MIP.getBounds mip col - vt = MIP.getVarType mip col + forM_ (Map.toList (MIP.varInfo mip)) $ \(col, vinfo) -> do + let (lb,ub) = MIP.varBounds vinfo + vt = MIP.varType vinfo case (lb,ub) of (MIP.NegInf, MIP.PosInf) -> do -- free variable (no lower or upper bound) @@ -737,12 +750,6 @@ -- ENDATA section writeSectionHeader "ENDATA" -writeString :: String -> M () -writeString s = tell $ showString s - -writeChar :: Char -> M () -writeChar c = tell $ showChar c - writeSectionHeader :: String -> M () writeSectionHeader s = writeString s >> writeChar '\n' @@ -788,7 +795,7 @@ -- columns 50- f6 [] = return () f6 [x] = writeString x - f6 _ = mzero + f6 _ = error "MPSFile: >6 fields (this should not happen)" showValue :: Rational -> String showValue c = diff --git a/src/ToySolver/Text/PBFile.hs b/src/ToySolver/Text/PBFile.hs --- a/src/ToySolver/Text/PBFile.hs +++ b/src/ToySolver/Text/PBFile.hs @@ -41,19 +41,20 @@ , parseWBOFile -- * Show .opb files - , showOPB + , renderOPB -- * Show .wbo files - , showWBO + , renderWBO ) where import Prelude hiding (sum) +import Control.Exception (assert) import Control.Monad -import Data.Maybe import Data.List hiding (sum) -import Text.ParserCombinators.Parsec +import Data.Maybe import Data.Word -import Control.Exception (assert) +import Text.Parsec +import Text.Parsec.String import Text.Printf import ToySolver.Internal.TextUtil @@ -317,6 +318,12 @@ parseWBOFile :: FilePath -> IO (Either ParseError SoftFormula) parseWBOFile = parseFromFile softformula + +renderOPB :: Formula -> String +renderOPB opb = showOPB opb "" + +renderWBO :: SoftFormula -> String +renderWBO wbo = showWBO wbo "" showOPB :: Formula -> ShowS showOPB opb = (size . part1 . part2) diff --git a/src/ToySolver/Text/SDPFile.hs b/src/ToySolver/Text/SDPFile.hs --- a/src/ToySolver/Text/SDPFile.hs +++ b/src/ToySolver/Text/SDPFile.hs @@ -50,7 +50,8 @@ import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap -import Text.ParserCombinators.Parsec +import Text.Parsec +import Text.Parsec.String -- --------------------------------------------------------------------------- -- problem description diff --git a/src/ToySolver/Wang.hs b/src/ToySolver/Wang.hs --- a/src/ToySolver/Wang.hs +++ b/src/ToySolver/Wang.hs @@ -1,17 +1,18 @@ -module ToySolver.Wang where +{-# OPTIONS_GHC -Wall #-} +module ToySolver.Wang + ( Formula + , Sequent + , isValid + ) where import Control.Monad (guard,msum) import Data.List (intersect) import Data.Maybe (isJust, listToMaybe) -data Formula x - = Atom x - | Not !(Formula x) - | Imply !(Formula x) !(Formula x) - | And !(Formula x) !(Formula x) - | Or !(Formula x) !(Formula x) - deriving Eq +import ToySolver.Data.Boolean +import ToySolver.Data.BoolExpr +type Formula a = BoolExpr a type Sequent x = ([Formula x], [Formula x]) isValid :: Eq x => Sequent x -> Bool @@ -29,16 +30,21 @@ return [(l,p:r)] , do (Imply p q, r) <- pick r return [(p:l,q:r)] - , do (Or p q, r) <- pick r - return [(l,p:q:r)] - , do (And p q, l) <- pick l - return [(p:q:l,r)] - , do (Or p q, l) <- pick l - return [(p:l,r), (q:l,r)] - , do (And p q, r) <- pick r - return [(l,p:r), (l,q:r)] + , do (Or ps, r) <- pick r + return [(l,ps++r)] + , do (And ps, l) <- pick l + return [(ps++l,r)] + , do (Or ps, l) <- pick l + return [(p:l,r) | p <- ps] + , do (And ps, r) <- pick r + return [(l,p:r) | p <- ps] , do (Imply p q, l) <- pick l return [(q:l,r), (l,p:r)] + + , do (Equiv p q, l) <- pick l + return [(Imply p q : Imply q p : l, r)] + , do (Equiv p q, r) <- pick r + return [(l, Imply p q : Imply q p : r)] ] mapM_ isValid' xs return () diff --git a/test/TestAReal.hs b/test/TestAReal.hs --- a/test/TestAReal.hs +++ b/test/TestAReal.hs @@ -15,7 +15,7 @@ import ToySolver.Data.AlgebraicNumber.Real import ToySolver.Data.AlgebraicNumber.Root -import Data.Interval (Interval, EndPoint (..), (<=..<=), (<..<=), (<=..<), (<..<)) +import Data.Interval (Interval, Extended (..), (<=..<=), (<..<=), (<=..<), (<..<)) import qualified Data.Interval as Interval import Control.Monad diff --git a/test/TestArith.hs b/test/TestArith.hs new file mode 100644 --- /dev/null +++ b/test/TestArith.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main (main) where + +import Control.Monad +import Data.List +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.VectorSpace +import Test.HUnit hiding (Test) +import Test.QuickCheck hiding ((.&&.), (.||.)) +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Monadic as QM +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.TH +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +import qualified Data.Interval as Interval +import Data.OptDir + +import ToySolver.Data.AlgebraicNumber.Real +import ToySolver.Data.ArithRel +import ToySolver.Data.FOL.Arith +import qualified ToySolver.Data.LA as LA +import qualified ToySolver.Data.Polynomial as P +import ToySolver.Data.Var + +import qualified ToySolver.Arith.FourierMotzkin as FourierMotzkin +import qualified ToySolver.Arith.FourierMotzkin.Optimization as FMOpt +import qualified ToySolver.Arith.OmegaTest as OmegaTest +import qualified ToySolver.Arith.OmegaTest.Base as OmegaTest +import qualified ToySolver.Arith.Cooper as Cooper +import qualified ToySolver.Arith.CAD as CAD +import qualified ToySolver.Arith.Simplex2 as Simplex2 +import qualified ToySolver.Arith.ContiTraverso as ContiTraverso +import qualified ToySolver.Arith.VirtualSubstitution as VirtualSubstitution + +------------------------------------------------------------------------ + +{- +Example from the OmegaTest paper + +7x + 12y + 31z = 17 +3x + 5y + 14z = 7 +1 ≤ x ≤ 40 +-50 ≤ y ≤ 50 + +satisfiable in R +satisfiable in Z + +(declare-fun x () Int) +(declare-fun y () Int) +(declare-fun z () Int) +(assert (= (+ (* 7 x) (* 12 y) (* 31 z)) 17)) +(assert (= (+ (* 3 x) (* 5 y) (* 14 z)) 7)) +(assert (<= 1 x)) +(assert (<= x 40)) +(assert (<= (- 50) y)) +(assert (<= y 50)) +(check-sat) ; => sat +(get-model) + +Just (DNF {unDNF = [[Nonneg (fromTerms [(-17,-1),(7,0),(12,1),(31,2)]),Nonneg (fromTerms [(17,-1),(-7,0),(-12,1),(-31,2)]),Nonneg (fromTerms [(-7,-1),(3,0),(5,1),(14,2)]),Nonneg (fromTerms [(7,-1),(-3,0),(-5,1),(-14,2)]),Nonneg (fromTerms [(-1,-1),(1,0)]),Nonneg (fromTerms [(40,-1),(-1,0)]),Nonneg (fromTerms [(50,-1),(1,1)]),Nonneg (fromTerms [(50,-1),(-1,1)])]]}) + +7x+12y+31z - 17 >= 0 +-7x-12y-31z + 17 >= 0 +3x+5y+14z - 7 >= 0 +-3x-5y-14z + 7 >= 0 +x - 1 >= 0 +-x + 40 >= 0 +y + 50 >= 0 +-y + 50 >= 0 +-} +test1 :: Formula (Atom Rational) +test1 = c1 .&&. c2 .&&. c3 .&&. c4 + where + x = Var 0 + y = Var 1 + z = Var 2 + c1 = 7*x + 12*y + 31*z .==. 17 + c2 = 3*x + 5*y + 14*z .==. 7 + c3 = 1 .<=. x .&&. x .<=. 40 + c4 = (-50) .<=. y .&&. y .<=. 50 + +test1' :: (VarSet, [LA.Atom Rational]) +test1' = (IS.fromList [0,1,2], [c1, c2] ++ c3 ++ c4) + where + x = LA.var 0 + y = LA.var 1 + z = LA.var 2 + c1 = 7*^x ^+^ 12*^y ^+^ 31*^z .==. LA.constant 17 + c2 = 3*^x ^+^ 5*^y ^+^ 14*^z .==. LA.constant 7 + c3 = [LA.constant 1 .<=. x, x .<=. LA.constant 40] + c4 = [LA.constant (-50) .<=. y, y .<=. LA.constant 50] + + +{- +Example from the OmegaTest paper + +27 ≤ 11x+13y ≤ 45 +-10 ≤ 7x-9y ≤ 4 + +satisfiable in R +but unsatisfiable in Z + +(declare-fun x () Int) +(declare-fun y () Int) +(define-fun t1 () Int (+ (* 11 x) (* 13 y))) +(define-fun t2 () Int (- (* 7 x) (* 9 y))) +(assert (<= 27 t1)) +(assert (<= t1 45)) +(assert (<= (- 10) t2)) +(assert (<= t2 4)) +(check-sat) ; unsat +(get-model) +-} +test2 :: Formula (Atom Rational) +test2 = c1 .&&. c2 + where + x = Var 0 + y = Var 1 + t1 = 11*x + 13*y + t2 = 7*x - 9*y + c1 = 27 .<=. t1 .&&. t1 .<=. 45 + c2 = (-10) .<=. t2 .&&. t2 .<=. 4 + +test2' :: (VarSet, [LA.Atom Rational]) +test2' = + ( IS.fromList [0,1] + , [ LA.constant 27 .<=. t1 + , t1 .<=. LA.constant 45 + , LA.constant (-10) .<=. t2 + , t2 .<=. LA.constant 4 + ] + ) + where + x = LA.var 0 + y = LA.var 1 + t1 = 11*^x ^+^ 13*^y + t2 = 7*^x ^-^ 9*^y + + +genLAExpr :: [Var] -> Gen (LA.Expr Rational) +genLAExpr vs = do + size <- choose (0,3) + liftM LA.fromTerms $ replicateM size $ do + x <- elements (LA.unitVar : vs) + c <- arbitrary + return (c,x) + +genLAExprSmallInt :: [Var] -> Gen (LA.Expr Rational) +genLAExprSmallInt vs = do + size <- choose (0,3) + liftM LA.fromTerms $ replicateM size $ do + x <- elements (LA.unitVar : vs) + c <- choose (-10,10) + return (fromInteger c,x) + +genQFLAConj :: Gen (VarSet, [LA.Atom Rational]) +genQFLAConj = do + nv <- choose (0, 5) + nc <- choose (0, 5) + let vs = IS.fromList [1..nv] + cs <- replicateM nc $ do + op <- elements [Lt, Le, Ge, Gt, Eql] -- , NEq + lhs <- genLAExpr [1..nv] + rhs <- genLAExpr [1..nv] + return $ arithRel op lhs rhs + return (vs, cs) + +genQFLAConjSmallInt :: Gen (VarSet, [LA.Atom Rational]) +genQFLAConjSmallInt = do + nv <- choose (0, 3) + nc <- choose (0, 3) + let vs = IS.fromList [1..nv] + cs <- replicateM nc $ do + op <- elements [Lt, Le, Ge, Gt, Eql] -- , NEq + lhs <- genLAExprSmallInt [1..nv] + rhs <- genLAExprSmallInt [1..nv] + return $ arithRel op lhs rhs + return (vs, cs) + +genModel :: Arbitrary a => VarSet -> Gen (Model a) +genModel xs = do + liftM IM.fromList $ forM (IS.toList xs) $ \x -> do + val <- arbitrary + return (x,val) + +------------------------------------------------------------------------ + +prop_FourierMotzkin_solve :: Property +prop_FourierMotzkin_solve = + forAll genQFLAConj $ \(vs,cs) -> + case FourierMotzkin.solve vs cs of + Nothing -> forAll (genModel vs) $ \m -> all (LA.evalAtom m) cs == False + Just m -> property $ all (LA.evalAtom m) cs + +case_FourierMotzkin_test1 :: IO () +case_FourierMotzkin_test1 = + case uncurry FourierMotzkin.solve test1' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ (snd test1') $ \a -> do + LA.evalAtom m a @?= True + +case_FourierMotzkin_test2 :: IO () +case_FourierMotzkin_test2 = + case uncurry FourierMotzkin.solve test2' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ (snd test2') $ \a -> do + LA.evalAtom m a @?= True + +{- +Maximize + obj: x1 + 2 x2 + 3 x3 + x4 +Subject To + c1: - x1 + x2 + x3 + 10 x4 <= 20 + c2: x1 - 3 x2 + x3 <= 30 + c3: x2 - 3.5 x4 = 0 +Bounds + 0 <= x1 <= 40 + 2 <= x4 <= 3 +End +-} +case_FourierMotzkinOptimization_test1 :: IO () +case_FourierMotzkinOptimization_test1 = do + Interval.upperBound' i @?= (3005/24, True) + and [LA.evalAtom m c | c <- cs] @?= True + where + (i, f) = FMOpt.optimize (IS.fromList vs) OptMax obj cs + m = f (3005/24) + + vs@[x1,x2,x3,x4] = [1..4] + obj = LA.fromTerms [(1,x1), (2,x2), (3,x3), (1,x4)] + cs = [ LA.fromTerms [(-1,x1), (1,x2), (1,x3), (10,x4)] .<=. LA.constant 20 + , LA.fromTerms [(1,x1), (-3,x2), (1,x3)] .<=. LA.constant 30 + , LA.fromTerms [(1,x2), (-3.5,x4)] .==. LA.constant 0 + , LA.fromTerms [(1,x1)] .>=. LA.constant 0 + , LA.fromTerms [(1,x1)] .<=. LA.constant 40 + , LA.fromTerms [(1,x2)] .>=. LA.constant 0 + , LA.fromTerms [(1,x3)] .>=. LA.constant 0 + , LA.fromTerms [(1,x4)] .>=. LA.constant 2 + , LA.fromTerms [(1,x4)] .<=. LA.constant 3 + ] + +------------------------------------------------------------------------ + +prop_VirtualSubstitution_solve :: Property +prop_VirtualSubstitution_solve = + forAll genQFLAConj $ \(vs,cs) -> + case VirtualSubstitution.solve vs cs of + Nothing -> forAll (genModel vs) $ \m -> all (LA.evalAtom m) cs == False + Just m -> property $ all (LA.evalAtom m) cs + +case_VirtualSubstitution_test1 :: IO () +case_VirtualSubstitution_test1 = + case uncurry VirtualSubstitution.solve test1' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ (snd test1') $ \a -> do + LA.evalAtom m a @?= True + +case_VirtualSubstitution_test2 :: IO () +case_VirtualSubstitution_test2 = + case uncurry VirtualSubstitution.solve test2' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ (snd test2') $ \a -> do + LA.evalAtom m a @?= True + +------------------------------------------------------------------------ + +-- too slow +disabled_prop_CAD_solve :: Property +disabled_prop_CAD_solve = + forAll genQFLAConj $ \(vs,cs) -> + let vs' = Set.fromAscList $ IS.toAscList vs + cs' = map toPRel cs + in case CAD.solve vs' cs' of + Nothing -> + forAll (genModel vs) $ \m -> + let m' = Map.fromAscList [(x, fromRational v) | (x,v) <- IM.toAscList m] + in all (evalPAtom m') cs' == False + Just m -> property $ all (evalPAtom m) cs' + +case_CAD_test1 :: IO () +case_CAD_test1 = + case CAD.solve vs cs of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ cs $ \a -> do + evalPAtom m a @?= True + where + vs = Set.fromAscList $ IS.toAscList $ fst test1' + cs = map toPRel $ snd test1' + +case_CAD_test2 :: IO () +case_CAD_test2 = + case CAD.solve vs cs of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ cs $ \a -> do + evalPAtom m a @?= True + where + vs = Set.fromAscList $ IS.toAscList $ fst test2' + cs = map toPRel $ snd test2' + +case_CAD_test_nonlinear_multivariate :: IO () +case_CAD_test_nonlinear_multivariate = + case CAD.solve vs cs of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> + forM_ cs $ \a -> do + evalPAtom m a @?= True + where + vs = Set.fromList [0,1] + cs = [x^2 - y^2 - 2 .==. 0, 2*y*x .==. 0] + x = P.var (0::Int) + y = P.var 1 + +toP :: LA.Expr Rational -> P.Polynomial Rational Int +toP e = P.fromTerms [(c, if x == LA.unitVar then P.mone else P.var x) | (c,x) <- LA.terms e] + +toPRel :: LA.Atom Rational -> ArithRel (P.Polynomial Rational Int) +toPRel = fmap toP + +evalP :: Map.Map Int AReal -> P.Polynomial Rational Int -> AReal +evalP m p = P.eval (m Map.!) $ P.mapCoeff fromRational p + +evalPAtom :: Map.Map Int AReal -> ArithRel (P.Polynomial Rational Int) -> Bool +evalPAtom m (ArithRel lhs op rhs) =　evalOp op (evalP m lhs) (evalP m rhs) + +------------------------------------------------------------------------ + +prop_OmegaTest_solve :: Property +prop_OmegaTest_solve = + forAll genQFLAConjSmallInt $ \(vs,cs) -> + case OmegaTest.solve OmegaTest.defaultOptions vs cs of + Nothing -> forAll (genModel vs) $ \m -> all (LA.evalAtom (fmap fromInteger m)) cs == False + Just m -> property $ all (LA.evalAtom (fmap fromInteger m)) cs + +case_OmegaTest_test1 :: IO () +case_OmegaTest_test1 = + case uncurry (OmegaTest.solve OmegaTest.defaultOptions) test1' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> do + forM_ (snd test1') $ \a -> do + LA.evalAtom (IM.map fromInteger m) a @?= True + +case_OmegaTest_test2 :: IO () +case_OmegaTest_test2 = + case uncurry (OmegaTest.solve OmegaTest.defaultOptions) test2' of + Just _ -> assertFailure "expected: Nothing\n but got: Just" + Nothing -> return () + +prop_OmegaTest_zmod = + forAll arbitrary $ \a -> + forAll arbitrary $ \b -> + b /= 0 ==> + let c = a `OmegaTest.zmod` b + in (a - c) `mod` b == 0 && abs c <= abs b `div` 2 + +------------------------------------------------------------------------ + +prop_Cooper_solve :: Property +prop_Cooper_solve = + forAll genQFLAConjSmallInt $ \(vs,cs) -> + case Cooper.solve vs cs of + Nothing -> + (forAll (genModel vs) $ \m -> all (LA.evalAtom (fmap fromInteger m)) cs == False) QC..&&. + property (OmegaTest.solve OmegaTest.defaultOptions vs cs == Nothing) + Just m -> property $ all (LA.evalAtom (fmap fromInteger m)) cs + +case_Cooper_test1 :: IO () +case_Cooper_test1 = + case uncurry Cooper.solve test1' of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> do + forM_ (snd test1') $ \a -> do + LA.evalAtom (IM.map fromInteger m) a @?= True + +case_Cooper_test2 :: IO () +case_Cooper_test2 = + case uncurry Cooper.solve test2' of + Just _ -> assertFailure "expected: Nothing\n but got: Just" + Nothing -> return () + +------------------------------------------------------------------------ + +prop_Simplex2_solve :: Property +prop_Simplex2_solve = QM.monadicIO $ do + (vs,cs) <- QM.pick genQFLAConj + join $ QM.run $ do + solver <- Simplex2.newSolver + m <- liftM IM.fromList $ forM (IS.toList vs) $ \v -> do + v2 <- Simplex2.newVar solver + return (v, LA.var v2) + let cs' = map (LA.applySubstAtom m) cs + forM_ cs' $ \c -> do + Simplex2.assertAtomEx solver c + ret <- Simplex2.check solver + if ret then do + m <- Simplex2.getModel solver + return $ forM_ cs' $ \c -> QM.assert (LA.evalAtom m c) + else do + return $ return () + +case_Simplex2_test1 :: IO () +case_Simplex2_test1 = do + solver <- Simplex2.newSolver + forM_ (IS.toList (fst test1')) $ \_ -> Simplex2.newVar solver + mapM_ (Simplex2.assertAtomEx solver) (snd test1') + ret <- Simplex2.check solver + ret @?= True + +case_Simplex2_test2 :: IO () +case_Simplex2_test2 = do + solver <- Simplex2.newSolver + forM_ (IS.toList (fst test2')) $ \_ -> Simplex2.newVar solver + mapM_ (Simplex2.assertAtomEx solver) (snd test2') + ret <- Simplex2.check solver + ret @?= True + +------------------------------------------------------------------------ + +-- Too slow + +disabled_case_ContiTraverso_test1 :: IO () +disabled_case_ContiTraverso_test1 = + case ContiTraverso.solve P.grlex (fst test1') OptMin (LA.constant 0) (snd test1') of + Nothing -> assertFailure "expected: Just\n but got: Nothing" + Just m -> do + forM_ (snd test1') $ \a -> do + LA.evalAtom (IM.map fromInteger m) a @?= True + +disabled_case_ContiTraverso_test2 :: IO () +disabled_case_ContiTraverso_test2 = + case ContiTraverso.solve P.grlex (fst test2') OptMin (LA.constant 0) (snd test2') of + Just _ -> assertFailure "expected: Nothing\n but got: Just" + Nothing -> return () + +------------------------------------------------------------------------ +-- Test harness + +main :: IO () +main = $(defaultMainGenerator) diff --git a/test/TestContiTraverso.hs b/test/TestContiTraverso.hs --- a/test/TestContiTraverso.hs +++ b/test/TestContiTraverso.hs @@ -14,7 +14,7 @@ import Data.OptDir -import ToySolver.ContiTraverso +import ToySolver.Arith.ContiTraverso import ToySolver.Data.ArithRel import qualified ToySolver.Data.LA as LA diff --git a/test/TestLPFile.hs b/test/TestLPFile.hs --- a/test/TestLPFile.hs +++ b/test/TestLPFile.hs @@ -47,8 +47,8 @@ Left err -> assertFailure $ show err Right lp -> case render lp of - Nothing -> assertFailure "render failure" - Just _ -> return () + Left err -> assertFailure ("render failure: " ++ err) + Right _ -> return () checkString :: String -> String -> IO () checkString name str = do @@ -56,8 +56,8 @@ Left err -> assertFailure $ show err Right lp -> case render lp of - Nothing -> assertFailure "render failure" - Just _ -> return () + Left err -> assertFailure ("render failure: " ++ err) + Right _ -> return () ------------------------------------------------------------------------ -- Test harness diff --git a/test/TestMIPSolver2.hs b/test/TestMIPSolver2.hs --- a/test/TestMIPSolver2.hs +++ b/test/TestMIPSolver2.hs @@ -14,9 +14,9 @@ import Text.Printf import qualified ToySolver.Data.LA as LA -import qualified ToySolver.Simplex2 as Simplex2 -import ToySolver.Simplex2 -import qualified ToySolver.MIPSolver2 as MIPSolver2 +import qualified ToySolver.Arith.Simplex2 as Simplex2 +import ToySolver.Arith.Simplex2 +import qualified ToySolver.Arith.MIPSolver2 as MIPSolver2 ------------------------------------------------------------------------ diff --git a/test/TestPBFile.hs b/test/TestPBFile.hs --- a/test/TestPBFile.hs +++ b/test/TestPBFile.hs @@ -129,15 +129,13 @@ testOPB s = sf == sf2 where Right sf = parseOPBString "-" s - s2 = showOPB sf "" - Right sf2 = parseOPBString "-" s2 + Right sf2 = parseOPBString "-" (renderOPB sf) testWBO :: String -> Bool testWBO s = sf == sf2 where Right sf = parseWBOString "-" s - s2 = showWBO sf "" - Right sf2 = parseWBOString "-" s2 + Right sf2 = parseWBOString "-" (renderWBO sf) ------------------------------------------------------------------------ -- Test harness diff --git a/test/TestQE.hs b/test/TestQE.hs deleted file mode 100644 --- a/test/TestQE.hs +++ /dev/null @@ -1,275 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main (main) where - -import Control.Monad -import Data.List -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.VectorSpace -import Test.HUnit hiding (Test) -import Test.Framework (Test, defaultMain, testGroup) -import Test.Framework.TH -import Test.Framework.Providers.HUnit - -import Data.OptDir - -import ToySolver.Data.AlgebraicNumber.Real -import ToySolver.Data.ArithRel -import ToySolver.Data.FOL.Arith -import qualified ToySolver.Data.LA as LA -import qualified ToySolver.Data.Polynomial as P -import ToySolver.Data.Var - -import qualified ToySolver.FourierMotzkin as FourierMotzkin -import qualified ToySolver.OmegaTest as OmegaTest -import qualified ToySolver.Cooper as Cooper -import qualified ToySolver.CAD as CAD -import qualified ToySolver.Simplex2 as Simplex2 -import qualified ToySolver.ContiTraverso as ContiTraverso - ------------------------------------------------------------------------- - -{- -Example from the OmegaTest paper - -7x + 12y + 31z = 17 -3x + 5y + 14z = 7 -1 ≤ x ≤ 40 --50 ≤ y ≤ 50 - -satisfiable in R -satisfiable in Z - -(declare-fun x () Int) -(declare-fun y () Int) -(declare-fun z () Int) -(assert (= (+ (* 7 x) (* 12 y) (* 31 z)) 17)) -(assert (= (+ (* 3 x) (* 5 y) (* 14 z)) 7)) -(assert (<= 1 x)) -(assert (<= x 40)) -(assert (<= (- 50) y)) -(assert (<= y 50)) -(check-sat) ; => sat -(get-model) - -Just (DNF {unDNF = [[Nonneg (fromTerms [(-17,-1),(7,0),(12,1),(31,2)]),Nonneg (fromTerms [(17,-1),(-7,0),(-12,1),(-31,2)]),Nonneg (fromTerms [(-7,-1),(3,0),(5,1),(14,2)]),Nonneg (fromTerms [(7,-1),(-3,0),(-5,1),(-14,2)]),Nonneg (fromTerms [(-1,-1),(1,0)]),Nonneg (fromTerms [(40,-1),(-1,0)]),Nonneg (fromTerms [(50,-1),(1,1)]),Nonneg (fromTerms [(50,-1),(-1,1)])]]}) - -7x+12y+31z - 17 >= 0 --7x-12y-31z + 17 >= 0 -3x+5y+14z - 7 >= 0 --3x-5y-14z + 7 >= 0 -x - 1 >= 0 --x + 40 >= 0 -y + 50 >= 0 --y + 50 >= 0 --} -test1 :: Formula (Atom Rational) -test1 = c1 .&&. c2 .&&. c3 .&&. c4 - where - x = Var 0 - y = Var 1 - z = Var 2 - c1 = 7*x + 12*y + 31*z .==. 17 - c2 = 3*x + 5*y + 14*z .==. 7 - c3 = 1 .<=. x .&&. x .<=. 40 - c4 = (-50) .<=. y .&&. y .<=. 50 - -test1' :: (VarSet, [LA.Atom Rational]) -test1' = (IS.fromList [0,1,2], [c1, c2] ++ c3 ++ c4) - where - x = LA.var 0 - y = LA.var 1 - z = LA.var 2 - c1 = 7*^x ^+^ 12*^y ^+^ 31*^z .==. LA.constant 17 - c2 = 3*^x ^+^ 5*^y ^+^ 14*^z .==. LA.constant 7 - c3 = [LA.constant 1 .<=. x, x .<=. LA.constant 40] - c4 = [LA.constant (-50) .<=. y, y .<=. LA.constant 50] - - -{- -Example from the OmegaTest paper - -27 ≤ 11x+13y ≤ 45 --10 ≤ 7x-9y ≤ 4 - -satisfiable in R -but unsatisfiable in Z - -(declare-fun x () Int) -(declare-fun y () Int) -(define-fun t1 () Int (+ (* 11 x) (* 13 y))) -(define-fun t2 () Int (- (* 7 x) (* 9 y))) -(assert (<= 27 t1)) -(assert (<= t1 45)) -(assert (<= (- 10) t2)) -(assert (<= t2 4)) -(check-sat) ; unsat -(get-model) --} -test2 :: Formula (Atom Rational) -test2 = c1 .&&. c2 - where - x = Var 0 - y = Var 1 - t1 = 11*x + 13*y - t2 = 7*x - 9*y - c1 = 27 .<=. t1 .&&. t1 .<=. 45 - c2 = (-10) .<=. t2 .&&. t2 .<=. 4 - -test2' :: (VarSet, [LA.Atom Rational]) -test2' = - ( IS.fromList [0,1] - , [ LA.constant 27 .<=. t1 - , t1 .<=. LA.constant 45 - , LA.constant (-10) .<=. t2 - , t2 .<=. LA.constant 4 - ] - ) - where - x = LA.var 0 - y = LA.var 1 - t1 = 11*^x ^+^ 13*^y - t2 = 7*^x ^-^ 9*^y - ------------------------------------------------------------------------- - -case_FourierMotzkin_test1 :: IO () -case_FourierMotzkin_test1 = - case uncurry FourierMotzkin.solve test1' of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> - forM_ (snd test1') $ \a -> do - LA.evalAtom m a @?= True - -case_FourierMotzkin_test2 :: IO () -case_FourierMotzkin_test2 = - case uncurry FourierMotzkin.solve test2' of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> - forM_ (snd test2') $ \a -> do - LA.evalAtom m a @?= True - ------------------------------------------------------------------------- - -case_CAD_test1 :: IO () -case_CAD_test1 = - case CAD.solve vs cs of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> - forM_ cs $ \a -> do - evalPAtom m a @?= True - where - vs = Set.fromAscList $ IS.toAscList $ fst test1' - cs = map toPRel $ snd test1' - -case_CAD_test2 :: IO () -case_CAD_test2 = - case CAD.solve vs cs of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> - forM_ cs $ \a -> do - evalPAtom m a @?= True - where - vs = Set.fromAscList $ IS.toAscList $ fst test2' - cs = map toPRel $ snd test2' - -case_CAD_test_nonlinear_multivariate :: IO () -case_CAD_test_nonlinear_multivariate = - case CAD.solve vs cs of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> - forM_ cs $ \a -> do - evalPAtom m a @?= True - where - vs = Set.fromList [0,1] - cs = [x^2 - y^2 - 2 .==. 0, 2*y*x .==. 0] - x = P.var (0::Int) - y = P.var 1 - -toP :: LA.Expr Rational -> P.Polynomial Rational Int -toP e = P.fromTerms [(c, if x == LA.unitVar then P.mone else P.var x) | (c,x) <- LA.terms e] - -toPRel :: LA.Atom Rational -> Rel (P.Polynomial Rational Int) -toPRel (Rel lhs op rhs) = Rel (toP lhs) op (toP rhs) - -evalP :: Map.Map Int AReal -> P.Polynomial Rational Int -> AReal -evalP m p = P.eval (m Map.!) $ P.mapCoeff fromRational p - -evalPAtom :: Map.Map Int AReal -> Rel (P.Polynomial Rational Int) -> Bool -evalPAtom m (Rel lhs op rhs) =　evalOp op (evalP m lhs) (evalP m rhs) - ------------------------------------------------------------------------- - -case_OmegaTest_test1 :: IO () -case_OmegaTest_test1 = - case uncurry (OmegaTest.solve OmegaTest.defaultOptions) test1' of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> do - forM_ (snd test1') $ \a -> do - LA.evalAtom (IM.map fromInteger m) a @?= True - -case_OmegaTest_test2 :: IO () -case_OmegaTest_test2 = - case uncurry (OmegaTest.solve OmegaTest.defaultOptions) test2' of - Just _ -> assertFailure "expected: Nothing\n but got: Just" - Nothing -> return () - ------------------------------------------------------------------------- - -case_Cooper_test1 :: IO () -case_Cooper_test1 = - case uncurry Cooper.solve test1' of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> do - forM_ (snd test1') $ \a -> do - LA.evalAtom (IM.map fromInteger m) a @?= True - -case_Cooper_test2 :: IO () -case_Cooper_test2 = - case uncurry Cooper.solve test2' of - Just _ -> assertFailure "expected: Nothing\n but got: Just" - Nothing -> return () - ------------------------------------------------------------------------- - -case_Simplex2_test1 :: IO () -case_Simplex2_test1 = do - solver <- Simplex2.newSolver - forM_ (IS.toList (fst test1')) $ \_ -> Simplex2.newVar solver - mapM_ (Simplex2.assertAtomEx solver) (snd test1') - ret <- Simplex2.check solver - ret @?= True - -case_Simplex2_test2 :: IO () -case_Simplex2_test2 = do - solver <- Simplex2.newSolver - forM_ (IS.toList (fst test2')) $ \_ -> Simplex2.newVar solver - mapM_ (Simplex2.assertAtomEx solver) (snd test2') - ret <- Simplex2.check solver - ret @?= True - ------------------------------------------------------------------------- - --- Too slow - -disabled_case_ContiTraverso_test1 :: IO () -disabled_case_ContiTraverso_test1 = - case ContiTraverso.solve P.grlex (fst test1') OptMin (LA.constant 0) (snd test1') of - Nothing -> assertFailure "expected: Just\n but got: Nothing" - Just m -> do - forM_ (snd test1') $ \a -> do - LA.evalAtom (IM.map fromInteger m) a @?= True - -disabled_case_ContiTraverso_test2 :: IO () -disabled_case_ContiTraverso_test2 = - case ContiTraverso.solve P.grlex (fst test2') OptMin (LA.constant 0) (snd test2') of - Just _ -> assertFailure "expected: Nothing\n but got: Just" - Nothing -> return () - ------------------------------------------------------------------------- --- Test harness - -main :: IO () -main = $(defaultMainGenerator) diff --git a/test/TestSAT.hs b/test/TestSAT.hs --- a/test/TestSAT.hs +++ b/test/TestSAT.hs @@ -9,21 +9,150 @@ import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Test.HUnit hiding (Test) -import Test.QuickCheck +import Test.QuickCheck hiding ((.&&.), (.||.)) +import qualified Test.QuickCheck.Monadic as QM import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.TH import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 -import ToySolver.HittingSet as HittingSet +import ToySolver.Data.LBool +import ToySolver.Data.BoolExpr +import ToySolver.Data.Boolean import ToySolver.SAT import ToySolver.SAT.Types import qualified ToySolver.SAT.TseitinEncoder as Tseitin -import ToySolver.SAT.TseitinEncoder (Formula (..)) import qualified ToySolver.SAT.MUS as MUS -import qualified ToySolver.SAT.CAMUS as CAMUS +import qualified ToySolver.SAT.MUS.CAMUS as CAMUS +import qualified ToySolver.SAT.MUS.DAA as DAA import qualified ToySolver.SAT.PBO as PBO +prop_solveCNF :: Property +prop_solveCNF = QM.monadicIO $ do + cnf@(nv,_) <- QM.pick arbitraryCNF + ret <- QM.run $ solveCNF cnf + case ret of + Just m -> QM.assert $ evalCNF m cnf == True + Nothing -> do + forM_ [array (1,nv) (zip [1..nv] xs) | xs <- replicateM nv [True,False]] $ \m -> do + QM.assert $ evalCNF m cnf == False + +solveCNF :: (Int,[Clause]) -> IO (Maybe Model) +solveCNF (nv,cs) = do + solver <- newSolver + setCheckModel solver True + newVars_ solver nv + forM_ cs $ \c -> addClause solver c + ret <- solve solver + if ret then do + m <- getModel solver + return (Just m) + else do + return Nothing + +arbitraryCNF :: Gen (Int,[Clause]) +arbitraryCNF = do + nv <- choose (0,10) + nc <- choose (0,50) + cs <- replicateM nc $ do + len <- choose (0,10) + if nv == 0 then + return [] + else + replicateM len $ choose (-nv, nv) `suchThat` (/= 0) + return (nv, cs) + +evalCNF :: Model -> (Int,[Clause]) -> Bool +evalCNF m (_,cs) = all (evalClause m) cs + + +prop_solvePB :: Property +prop_solvePB = QM.monadicIO $ do + prob@(nv,_) <- QM.pick arbitraryPB + ret <- QM.run $ solvePB prob + case ret of + Just m -> QM.assert $ evalPB m prob == True + Nothing -> do + forM_ [array (1,nv) (zip [1..nv] xs) | xs <- replicateM nv [True,False]] $ \m -> do + QM.assert $ evalPB m prob == False + +solvePB :: (Int,[PBLinAtLeast]) -> IO (Maybe Model) +solvePB (nv,cs) = do + solver <- newSolver + setCheckModel solver True + newVars_ solver nv + forM_ cs $ \c -> addPBAtLeast solver (fst c) (snd c) + ret <- solve solver + if ret then do + m <- getModel solver + return (Just m) + else do + return Nothing + +arbitraryPB :: Gen (Int,[PBLinAtLeast]) +arbitraryPB = do + nv <- choose (0,10) + nc <- choose (0,50) + cs <- replicateM nc $ do + len <- choose (0,10) + lhs <- + if nv == 0 then + return [] + else + replicateM len $ do + l <- choose (-nv, nv) `suchThat` (/= 0) + c <- arbitrary + return (c,l) + rhs <- arbitrary + return (lhs,rhs) + return (nv, cs) + +evalPB :: Model -> (Int,[PBLinAtLeast]) -> Bool +evalPB m (_,cs) = all (evalPBLinAtLeast m) cs + + +prop_solveXOR :: Property +prop_solveXOR = QM.monadicIO $ do + prob@(nv,_) <- QM.pick arbitraryXOR + ret <- QM.run $ solveXOR prob + case ret of + Just m -> QM.assert $ evalXOR m prob == True + Nothing -> do + forM_ [array (1,nv) (zip [1..nv] xs) | xs <- replicateM nv [True,False]] $ \m -> do + QM.assert $ evalXOR m prob == False + +solveXOR :: (Int,[XORClause]) -> IO (Maybe Model) +solveXOR (nv,cs) = do + solver <- newSolver + setCheckModel solver True + newVars_ solver nv + forM_ cs $ \c -> addXORClause solver (fst c) (snd c) + ret <- solve solver + if ret then do + m <- getModel solver + return (Just m) + else do + return Nothing + +arbitraryXOR :: Gen (Int,[XORClause]) +arbitraryXOR = do + nv <- choose (0,10) + nc <- choose (0,50) + cs <- replicateM nc $ do + len <- choose (0,10) + lhs <- + if nv == 0 then + return [] + else + replicateM len $ choose (-nv, nv) `suchThat` (/= 0) + rhs <- arbitrary + return (lhs,rhs) + return (nv, cs) + +evalXOR :: Model -> (Int,[XORClause]) -> Bool +evalXOR m (_,cs) = all (evalXORClause m) cs + + -- should be SAT case_solve_SAT :: IO () case_solve_SAT = do @@ -287,6 +416,27 @@ ret <- solveWith solver [-x2] ret @?= False +case_getVarFixed :: IO () +case_getVarFixed = do + solver <- newSolver + x1 <- newVar solver + x2 <- newVar solver + addClause solver [x1,x2] + + ret <- getVarFixed solver x1 + ret @?= lUndef + + addClause solver [-x1] + + ret <- getVarFixed solver x1 + ret @?= lFalse + + ret <- getLitFixed solver (-x1) + ret @?= lTrue + + ret <- getLitFixed solver x2 + ret @?= lTrue + ------------------------------------------------------------------------ -- -4*(not x1) + 3*x1 + 10*(not x2) @@ -368,6 +518,69 @@ ------------------------------------------------------------------------ +case_normalizeXORClause_False = + normalizeXORClause ([],True) @?= ([],True) + +case_normalizeXORClause_True = + normalizeXORClause ([],False) @?= ([],False) + +-- x ⊕ y ⊕ x = y +case_normalizeXORClause_case1 = + normalizeXORClause ([1,2,1],True) @?= ([2],True) + +-- x ⊕ ¬x = x ⊕ x ⊕ 1 = 1 +case_normalizeXORClause_case2 = + normalizeXORClause ([1,-1],True) @?= ([],False) + +case_evalXORClause_case1 = + evalXORClause (array (1,2) [(1,True),(2,True)] :: Array Int Bool) ([1,2], True) @?= False + +case_evalXORClause_case2 = + evalXORClause (array (1,2) [(1,False),(2,True)] :: Array Int Bool) ([1,2], True) @?= True + +case_xor_case1 = do + solver <- newSolver + setCheckModel solver True + x1 <- newVar solver + x2 <- newVar solver + x3 <- newVar solver + addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True + addXORClause solver [x2, x3] True -- x2 ⊕ x3 = True + addXORClause solver [x3, x1] True -- x3 ⊕ x1 = True + ret <- solve solver + ret @?= False + +case_xor_case2 = do + solver <- newSolver + setCheckModel solver True + x1 <- newVar solver + x2 <- newVar solver + x3 <- newVar solver + addXORClause solver [x1, x2] True -- x1 ⊕ x2 = True + addXORClause solver [x1, x3] True -- x1 ⊕ x3 = True + addClause solver [x2] + + ret <- solve solver + ret @?= True + m <- getModel solver + m ! x1 @?= False + m ! x2 @?= True + m ! x3 @?= True + +case_xor_case3 = do + solver <- newSolver + setCheckModel solver True + x1 <- newVar solver + x2 <- newVar solver + x3 <- newVar solver + x4 <- newVar solver + addXORClause solver [x1,x2,x3,x4] True + addAtLeast solver [x1,x2,x3,x4] 2 + ret <- solve solver + ret @?= True + +------------------------------------------------------------------------ + -- from "Pueblo: A Hybrid Pseudo-Boolean SAT Solver" -- clauseがunitになるレベルで、PB制約が違反状態のままという例。 case_hybridLearning_1 :: IO () @@ -439,31 +652,39 @@ solver <- newSolver enc <- Tseitin.newEncoder solver - [x1,x2,x3,x4,x5] <- replicateM 5 $ liftM Lit $ newVar solver - Tseitin.addFormula enc $ Or [Imply x1 (And [x3,x4]), Imply x2 (And [x3,x5])] + [x1,x2,x3,x4,x5] <- replicateM 5 $ liftM Atom $ newVar solver + Tseitin.addFormula enc $ orB [x1 .=>. x3 .&&. x4, x2 .=>. x3 .&&. x5] -- x6 = x3 ∧ x4 -- x7 = x3 ∧ x5 - Tseitin.addFormula enc $ Or [x1, x2] - Tseitin.addFormula enc $ Imply x4 (Not x5) + Tseitin.addFormula enc $ x1 .||. x2 + Tseitin.addFormula enc $ x4 .=>. notB x5 ret <- solve solver ret @?= True - Tseitin.addFormula enc $ Equiv x2 x4 + Tseitin.addFormula enc $ x2 .<=>. x4 ret <- solve solver ret @?= True - Tseitin.addFormula enc $ Equiv x1 x5 + Tseitin.addFormula enc $ x1 .<=>. x5 ret <- solve solver ret @?= True - Tseitin.addFormula enc $ Imply (Not x1) (And [x3,x5]) + Tseitin.addFormula enc $ notB x1 .=>. x3 .&&. x5 ret <- solve solver ret @?= True - Tseitin.addFormula enc $ Imply (Not x2) (And [x3,x4]) + Tseitin.addFormula enc $ notB x2 .=>. x3 .&&. x4 ret <- solve solver ret @?= False +case_addFormula_Peirces_Law = do + solver <- newSolver + enc <- Tseitin.newEncoder solver + [x1,x2] <- replicateM 2 $ liftM Atom $ newVar solver + Tseitin.addFormula enc $ notB $ ((x1 .=>. x2) .=>. x1) .=>. x1 + ret <- solve solver + ret @?= False + case_encodeConj = do solver <- newSolver enc <- Tseitin.newEncoder solver @@ -473,14 +694,14 @@ ret <- solveWith solver [x3] ret @?= True - m <- model solver + m <- getModel solver evalLit m x1 @?= True evalLit m x2 @?= True evalLit m x3 @?= True ret <- solveWith solver [-x3] ret @?= True - m <- model solver + m <- getModel solver (evalLit m x1 && evalLit m x2) @?= False evalLit m x3 @?= False @@ -493,13 +714,13 @@ ret <- solveWith solver [x3] ret @?= True - m <- model solver + m <- getModel solver (evalLit m x1 || evalLit m x2) @?= True evalLit m x3 @?= True ret <- solveWith solver [-x3] ret @?= True - m <- model solver + m <- getModel solver evalLit m x1 @?= False evalLit m x2 @?= False evalLit m x3 @?= False @@ -507,9 +728,9 @@ case_evalFormula = do solver <- newSolver xs <- newVars solver 5 - let f = Or [Imply x1 (And [x3,x4]), Imply x2 (And [x3,x5])] + let f = (x1 .=>. x3 .&&. x4) .||. (x2 .=>. x3 .&&. x5) where - [x1,x2,x3,x4,x5] = map Tseitin.Lit xs + [x1,x2,x3,x4,x5] = map Atom xs g m = (not x1 || (x3 && x4)) || (not x2 || (x3 && x5)) where [x1,x2,x3,x4,x5] = elems m @@ -535,7 +756,7 @@ ret @?= False actual <- MUS.findMUSAssumptions solver MUS.defaultOptions - let actual' = IntSet.fromList $ map (\x -> x-3) actual + let actual' = IntSet.map (\x -> x-3) actual expected = map IntSet.fromList [[1, 2], [1, 3, 4], [1, 5, 6]] actual' `elem` expected @?= True @@ -566,11 +787,27 @@ addClause solver [-y5, -x1, x3] addClause solver [-y6, -x3] actual <- CAMUS.allMCSAssumptions solver sels CAMUS.defaultOptions - let actual' = Set.fromList $ map IntSet.fromList actual - expected = [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]] - expected' = Set.fromList $ map (IntSet.fromList . map (+3)) expected + let actual' = Set.fromList actual + expected = map (IntSet.fromList . map (+3)) [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]] + expected' = Set.fromList expected actual' @?= expected' +case_DAA_allMCSAssumptions = do + solver <- newSolver + [x1,x2,x3] <- newVars solver 3 + sels@[y1,y2,y3,y4,y5,y6] <- newVars solver 6 + addClause solver [-y1, x1] + addClause solver [-y2, -x1] + addClause solver [-y3, -x1, x2] + addClause solver [-y4, -x2] + addClause solver [-y5, -x1, x3] + addClause solver [-y6, -x3] + actual <- DAA.allMCSAssumptions solver sels DAA.defaultOptions + let actual' = Set.fromList $ actual + expected = map (IntSet.fromList . map (+3)) [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]] + expected' = Set.fromList $ expected + actual' @?= expected' + case_camus_allMUSAssumptions = do solver <- newSolver [x1,x2,x3] <- newVars solver 3 @@ -582,41 +819,26 @@ addClause solver [-y5, -x1, x3] addClause solver [-y6, -x3] actual <- CAMUS.allMUSAssumptions solver sels CAMUS.defaultOptions - let actual' = Set.fromList $ map IntSet.fromList actual - expected = [[1,2], [1,3,4], [1,5,6]] - expected' = Set.fromList $ map (IntSet.fromList . map (+3)) expected + let actual' = Set.fromList $ actual + expected = map (IntSet.fromList . map (+3)) [[1,2], [1,3,4], [1,5,6]] + expected' = Set.fromList $ expected actual' @?= expected' -case_minimalHittingSets_1 = actual' @?= expected' - where - actual = HittingSet.minimalHittingSets [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]] - actual' = Set.fromList $ map IntSet.fromList actual - expected = [[1,2], [1,3,4], [1,5,6]] - expected' = Set.fromList $ map IntSet.fromList expected - --- an example from http://kuma-san.net/htcbdd.html -case_minimalHittingSets_2 = actual' @?= expected' - where - actual = HittingSet.minimalHittingSets [[2,4,7], [7,8], [9], [9,10]] - actual' = Set.fromList $ map IntSet.fromList actual - expected = [[7,9], [4,8,9], [2,8,9]] - expected' = Set.fromList $ map IntSet.fromList expected - -prop_minimalHittingSets_duality = - forAll hyperGraph $ \g -> - let h = HittingSet.minimalHittingSets g - in normalize h == normalize (HittingSet.minimalHittingSets (HittingSet.minimalHittingSets h)) - where - hyperGraph :: Gen [[Int]] - hyperGraph = do - nv <- choose (0, 10) - ne <- choose (0, 20) - replicateM ne $ do - n <- choose (1,nv) - liftM (IntSet.toList . IntSet.fromList) $ replicateM n $ choose (1, nv) - - normalize :: [[Int]] -> Set IntSet - normalize = Set.fromList . map IntSet.fromList +case_DAA_allMUSAssumptions = do + solver <- newSolver + [x1,x2,x3] <- newVars solver 3 + sels@[y1,y2,y3,y4,y5,y6] <- newVars solver 6 + addClause solver [-y1, x1] + addClause solver [-y2, -x1] + addClause solver [-y3, -x1, x2] + addClause solver [-y4, -x2] + addClause solver [-y5, -x1, x3] + addClause solver [-y6, -x3] + actual <- DAA.allMUSAssumptions solver sels DAA.defaultOptions + let actual' = Set.fromList $ actual + expected = map (IntSet.fromList . map (+3)) [[1,2], [1,3,4], [1,5,6]] + expected' = Set.fromList $ expected + actual' @?= expected' {- Boosting a Complete Technique to Find MSS and MUS thanks to a Local Search Oracle @@ -686,8 +908,8 @@ assertBool (show core ++ " should be satisfiable") ret actual <- CAMUS.allMUSAssumptions solver sels CAMUS.defaultOptions - let actual' = Set.fromList $ map IntSet.fromList actual - expected' = Set.fromList $ map IntSet.fromList cores + let actual' = Set.fromList actual + expected' = Set.fromList $ map IntSet.fromList $ cores actual' @?= expected' case_HYCAM_allMUSAssumptions = do @@ -756,9 +978,63 @@ ret <- solveWith solver [y0,y1,y2,y4,y5,y6,y7,y9,y11,y12] assertBool "failed to prove the bug of HYCAM paper" (not ret) - let cand = [[y5], [y3,y2], [y0,y1,y2]] - actual <- CAMUS.allMUSAssumptions solver sels CAMUS.defaultOptions{ CAMUS.optMCSCandidates = cand } - let actual' = Set.fromList $ map IntSet.fromList actual + let cand = map IntSet.fromList [[y5], [y3,y2], [y0,y1,y2]] + actual <- CAMUS.allMUSAssumptions solver sels CAMUS.defaultOptions{ CAMUS.optKnownCSes = cand } + let actual' = Set.fromList $ actual + expected' = Set.fromList $ map IntSet.fromList cores + actual' @?= expected' + +case_DAA_allMUSAssumptions_2 = do + solver <- newSolver + [a,b,c,d,e] <- newVars solver 5 + sels@[y0,y1,y2,y3,y4,y5,y6,y7,y8,y9,y10,y11,y12] <- newVars solver 13 + addClause solver [-y0, d] + addClause solver [-y1, b, c] + addClause solver [-y2, a, b] + addClause solver [-y3, a, -c] + addClause solver [-y4, -b, -e] + addClause solver [-y5, -a, -b] + addClause solver [-y6, a, e] + addClause solver [-y7, -a, -e] + addClause solver [-y8, b, e] + addClause solver [-y9, -a, b, -c] + addClause solver [-y10, -a, b, -d] + addClause solver [-y11, a, -b, c] + addClause solver [-y12, a, -b, -d] + + -- Only three of the MUSes (marked with asterisks) are on the paper. + let cores = + [ [y0,y1,y2,y5,y9,y12] + , [y0,y1,y3,y4,y5,y6,y10] + , [y0,y1,y3,y5,y7,y8,y12] + , [y0,y1,y3,y5,y9,y12] + , [y0,y1,y3,y5,y10,y11] + , [y0,y1,y3,y5,y10,y12] + , [y0,y2,y3,y5,y10,y11] + , [y0,y2,y4,y5,y6,y10] + , [y0,y2,y5,y7,y8,y12] + , [y0,y2,y5,y10,y12] -- (*) + , [y1,y2,y4,y5,y6,y9] + , [y1,y3,y4,y5,y6,y7,y8] + , [y1,y3,y4,y5,y6,y9] + , [y1,y3,y5,y7,y8,y11] + , [y1,y3,y5,y9,y11] -- (*) + , [y2,y3,y5,y7,y8,y11] + , [y2,y4,y5,y6,y7,y8] -- (*) + ] + + let remove1 :: [a] -> [[a]] + remove1 [] = [] + remove1 (x:xs) = xs : [x : ys | ys <- remove1 xs] + forM_ cores $ \core -> do + ret <- solveWith solver core + assertBool (show core ++ " should be a core") (not ret) + forM (remove1 core) $ \xs -> do + ret <- solveWith solver xs + assertBool (show core ++ " should be satisfiable") ret + + actual <- DAA.allMUSAssumptions solver sels DAA.defaultOptions + let actual' = Set.fromList actual expected' = Set.fromList $ map IntSet.fromList cores actual' @?= expected' diff --git a/test/TestSimplex.hs b/test/TestSimplex.hs --- a/test/TestSimplex.hs +++ b/test/TestSimplex.hs @@ -17,8 +17,8 @@ import qualified ToySolver.Data.LA as LA import ToySolver.Data.LA ((.<=.)) -import ToySolver.Simplex -import qualified ToySolver.LPSolver as LP +import ToySolver.Arith.Simplex +import qualified ToySolver.Arith.LPSolver as LP example_3_2 :: Tableau Rational example_3_2 = IntMap.fromList diff --git a/test/TestSimplex2.hs b/test/TestSimplex2.hs --- a/test/TestSimplex2.hs +++ b/test/TestSimplex2.hs @@ -12,7 +12,7 @@ import Text.Printf import qualified ToySolver.Data.LA as LA -import ToySolver.Simplex2 +import ToySolver.Arith.Simplex2 case_test1 :: IO () case_test1 = do diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,17 +1,28 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} module Main (main) where +import Control.Applicative import Control.Monad +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet +import Data.Set (Set) +import qualified Data.Set as Set import Test.HUnit hiding (Test) -import Test.QuickCheck +import Test.QuickCheck hiding ((.&&.), (.||.)) +import Test.QuickCheck.Function import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.TH import Test.Framework.Providers.QuickCheck2 import Test.Framework.Providers.HUnit -import qualified ToySolver.Data.Vec as Vec +import ToySolver.Data.Boolean +import ToySolver.Data.BoolExpr +import qualified ToySolver.Internal.Data.Vec as Vec import ToySolver.Internal.Util import ToySolver.Internal.TextUtil -import qualified ToySolver.Knapsack as Knapsack +import qualified ToySolver.Combinatorial.Knapsack.BB as KnapsackBB +import qualified ToySolver.Combinatorial.Knapsack.DP as KnapsackDP +import qualified ToySolver.Combinatorial.HittingSet.Simple as HittingSet +import qualified ToySolver.Wang as Wang case_showRationalAsDecimal :: IO () case_showRationalAsDecimal = do @@ -35,12 +46,91 @@ forAll (choose (0, 2^128)) $ \i -> readUnsignedInteger (show i) == i +-- --------------------------------------------------------------------- +-- Knapsack problems + case_knapsack_1 :: IO () -case_knapsack_1 = Knapsack.solve [(5,4), (6,5), (3,2)] 9 @?= (11, 9, [True,True,False]) +case_knapsack_1 = KnapsackBB.solve [(5,4), (6,5), (3,2)] 9 @?= (11, 9, [True,True,False]) case_knapsack_2 :: IO () -case_knapsack_2 = Knapsack.solve [(16,2), (19,3), (23,4), (28,5)] 7 @?= (44, 7, [True,False,False,True]) +case_knapsack_2 = KnapsackBB.solve [(16,2), (19,3), (23,4), (28,5)] 7 @?= (44, 7, [True,False,False,True]) +case_knapsack_DP_1 :: IO () +case_knapsack_DP_1 = KnapsackDP.solve [(5,4), (6,5), (3,2)] 9 @?= (11, 9, [True,True,False]) + +case_knapsack_DP_2 :: IO () +case_knapsack_DP_2 = KnapsackDP.solve [(16,2), (19,3), (23,4), (28,5)] 7 @?= (44, 7, [True,False,False,True]) + +prop_knapsack_DP_equals_BB = + forAll knapsackProblems $ \(items,lim) -> + let items' = [(v, fromIntegral w) | (v,w) <- items] + lim' = fromIntegral lim + (v1,_,_) = KnapsackBB.solve items' lim' + (v2,_,_) = KnapsackDP.solve items lim + in v1 == v2 + +knapsackProblems :: Gen ([(KnapsackDP.Value, KnapsackDP.Weight)], KnapsackDP.Weight) +knapsackProblems = do + lim <- choose (0,30) + items <- listOf $ do + v <- liftM abs arbitrary + w <- choose (1,30) + return (v,w) + return (items, lim) + +-- --------------------------------------------------------------------- +-- Hitting sets + +case_minimalHittingSets_1 = actual' @?= expected' + where + actual = HittingSet.minimalHittingSets $ map IntSet.fromList [[1], [2,3,5], [2,3,6], [2,4,5], [2,4,6]] + actual' = Set.fromList actual + expected = map IntSet.fromList [[1,2], [1,3,4], [1,5,6]] + expected' = Set.fromList expected + +-- an example from http://kuma-san.net/htcbdd.html +case_minimalHittingSets_2 = actual' @?= expected' + where + actual = HittingSet.minimalHittingSets $ map IntSet.fromList [[2,4,7], [7,8], [9], [9,10]] + actual' = Set.fromList actual + expected = map IntSet.fromList [[7,9], [4,8,9], [2,8,9]] + expected' = Set.fromList expected + +hyperGraph :: Gen [IntSet] +hyperGraph = do + nv <- choose (0, 10) + ne <- if nv==0 then return 0 else choose (0, 20) + replicateM ne $ do + n <- choose (1,nv) + liftM IntSet.fromList $ replicateM n $ choose (1, nv) + +isHittingSetOf :: IntSet -> [IntSet] -> Bool +isHittingSetOf s g = all (\e -> not (IntSet.null (s `IntSet.intersection` e))) g + +prop_minimalHittingSets_duality = + forAll hyperGraph $ \g -> + let h = HittingSet.minimalHittingSets g + in normalize h == normalize (HittingSet.minimalHittingSets (HittingSet.minimalHittingSets h)) + where + normalize :: [IntSet] -> Set IntSet + normalize = Set.fromList + +prop_minimalHittingSets_isHittingSet = + forAll hyperGraph $ \g -> + and [s `isHittingSetOf` g | s <- HittingSet.minimalHittingSets g] + +prop_minimalHittingSets_minimality = + forAll hyperGraph $ \g -> + forAll (elements (HittingSet.minimalHittingSets g)) $ \s -> + if IntSet.null s then + property True + else + forAll (elements (IntSet.toList s)) $ \v -> + not $ IntSet.delete v s `isHittingSetOf` g + +-- --------------------------------------------------------------------- +-- Vec + case_Vec :: IO () case_Vec = do (v::Vec.UVec Int) <- Vec.new @@ -60,6 +150,13 @@ ws <- Vec.getElems v ws @?= take 4 xs ++ [1,2,3] + x3 <- Vec.unsafePop v + x3 @?= 3 + s <- Vec.getSize v + s @?= 6 + ws <- Vec.getElems v + ws @?= take 4 xs ++ [1,2] + case_Vec_clone :: IO () case_Vec_clone = do (v::Vec.UVec Int) <- Vec.new @@ -72,6 +169,126 @@ b <- Vec.read v2 0 b @?= 1 + +-- --------------------------------------------------------------------- +-- BoolExpr + +instance Arbitrary a => Arbitrary (BoolExpr a) where + arbitrary = sized f + where + f n = + oneof + [ Atom <$> arbitrary + , And <$> list (n-1) + , Or <$> list (n-1) + , Not <$> (f (n-1)) + , uncurry Imply <$> pair (n-1) + , uncurry Equiv <$> pair (n-1) + ] + pair n | n <= 0 = do + a <- f 0 + b <- f 0 + return (a,b) + pair n = do + m <- choose (0,n) + a <- f m + b <- f (n-m) + return (a,b) + list n | n <= 0 = return [] + list n = oneof $ + [ return [] + , do m <- choose (0,n) + x <- f m + xs <- list (n-m-1) + return (x:xs) + ] + +prop_BoolExpr_Functor_identity = + forAll arbitrary $ \(b :: BoolExpr Int) -> + fmap id b == b + +prop_BoolExpr_Functor_compsition = + forAll arbitrary $ \(b :: BoolExpr Int) -> + forAll arbitrary $ \(f :: Fun Int Int) -> + forAll arbitrary $ \(g :: Fun Int Int) -> + fmap (apply f . apply g) b == fmap (apply f) (fmap (apply g) b) + +prop_BoolExpr_Applicative_identity = + forAll arbitrary $ \(b :: BoolExpr Int) -> + (pure id <*> b) == b + +prop_BoolExpr_Applicative_composition = + forAll arbitrary $ \(w :: BoolExpr Int) -> + forAll arbitrary $ \(u :: BoolExpr (Fun Int Int)) -> + forAll arbitrary $ \(v :: BoolExpr (Fun Int Int)) -> + (pure (.) <*> fmap apply u <*> fmap apply v <*> w) == (fmap apply u <*> (fmap apply v <*> w)) + +prop_BoolExpr_Applicative_homomorphism = + forAll arbitrary $ \(x :: Int) -> + forAll arbitrary $ \(f :: Fun Int Int) -> + (pure (apply f) <*> pure x) == (pure (apply f x) :: BoolExpr Int) + +prop_BoolExpr_Applicative_interchange = + forAll arbitrary $ \(y :: Int) -> + forAll arbitrary $ \(u :: BoolExpr (Fun Int Int)) -> + (fmap apply u <*> pure y) == (pure ($ y) <*> fmap apply u) + +prop_BoolExpr_Monad_left_identity = + forAll arbitrary $ \(b :: BoolExpr Int) -> + forAll arbitrary $ \(f :: Fun Int (BoolExpr Int)) -> + (b >>= (\x -> return x >>= apply f)) == (b >>= apply f) + +prop_BoolExpr_Monad_bind_right_identity = + forAll arbitrary $ \(b :: BoolExpr Int) -> + forAll arbitrary $ \(f :: Fun Int (BoolExpr Int)) -> + (b >>= (\x -> apply f x >>= return)) == (b >>= apply f) + +prop_BoolExpr_Monad_bind_associativity = + forAll arbitrary $ \(b :: BoolExpr Int) -> + forAll arbitrary $ \(f :: Fun Int (BoolExpr Int)) -> + forAll arbitrary $ \(g :: Fun Int (BoolExpr Int)) -> + (b >>= apply f >>= apply g) == (b >>= (\x -> apply f x >>= apply g)) + + +-- --------------------------------------------------------------------- +-- Wang + +-- (x1 ∨ x2) ∧ (x1 ∨ ¬x2) ∧ (¬x1 ∨ ¬x2) is satisfiable +-- ¬((x1 ∨ x2) ∧ (x1 ∨ ¬x2) ∧ (¬x1 ∨ ¬x2)) is invalid +case_Wang_1 = + Wang.isValid ([], [phi]) @?= False + where + phi = notB $ andB [x1 .||. x2, x1 .||. notB x2, notB x1 .||. notB x2] + x1 = Atom 1 + x2 = Atom 2 + +-- (x1 ∨ x2) ∧ (¬x1 ∨ x2) ∧ (x1 ∨ ¬x2) ∧ (¬x1 ∨ ¬x2) is unsatisfiable +-- ¬((x1 ∨ x2) ∧ (¬x1 ∨ x2) ∧ (x1 ∨ ¬x2) ∧ (¬x1 ∨ ¬x2)) is valid +case_Wang_2 = + Wang.isValid ([], [phi]) @?= True + where + phi = notB $ andB [x1 .||. x2, notB x1 .||. x2, x1 .||. notB x2, notB x1 .||. notB x2] + x1 = Atom 1 + x2 = Atom 2 + +case_Wang_EM = + Wang.isValid ([], [phi]) @?= True + where + phi = x1 .||. notB x1 + x1 = Atom 1 + +case_Wang_DNE = + Wang.isValid ([], [phi]) @?= True + where + phi = notB (notB x1) .<=>. x1 + x1 = Atom 1 + +case_Wang_Peirces_Law = + Wang.isValid ([], [phi]) @?= True + where + phi = ((x1 .=>. x2) .=>. x1) .=>. x1 + x1 = Atom 1 + x2 = Atom 2 ------------------------------------------------------------------------ -- Test harness diff --git a/toyfmf/toyfmf.hs b/toyfmf/toyfmf.hs --- a/toyfmf/toyfmf.hs +++ b/toyfmf/toyfmf.hs @@ -20,6 +20,7 @@ import System.Environment import System.IO import qualified Codec.TPTP as TPTP +import ToySolver.Data.Boolean import qualified ToySolver.FOLModelFinder as MF main :: IO () @@ -70,7 +71,7 @@ translateFormula :: TPTP.Formula -> MF.Formula translateFormula = TPTP.foldF neg quant binop eq rel where - neg phi = MF.Not $ translateFormula phi + neg phi = notB $ translateFormula phi quant q vs phi = foldr q' (translateFormula phi) [v | TPTP.V v <- vs] where q' = @@ -83,14 +84,14 @@ psi' = translateFormula psi op' = case op of - (TPTP.:<=>:) -> MF.Equiv - (TPTP.:=>:) -> MF.Imply - (TPTP.:<=:) -> flip MF.Imply - (TPTP.:&:) -> MF.And - (TPTP.:|:) -> MF.Or - (TPTP.:~&:) -> \a b -> MF.Not (a `MF.And` b) - (TPTP.:~|:) -> \a b -> MF.Not (a `MF.Or` b) - (TPTP.:<~>:) -> \a b -> MF.Not (a `MF.Equiv` b) + (TPTP.:<=>:) -> (.<=>.) + (TPTP.:=>:) -> (.=>.) + (TPTP.:<=:) -> flip (.=>.) + (TPTP.:&:) -> (.&&.) + (TPTP.:|:) -> (.||.) + (TPTP.:~&:) -> \a b -> notB (a .&&. b) + (TPTP.:~|:) -> \a b -> notB (a .||. b) + (TPTP.:<~>:) -> \a b -> notB (a .<=>. b) eq lhs op rhs = case op of (TPTP.:=:) -> MF.Atom $ MF.PApp "=" [lhs', rhs'] diff --git a/toysat/toysat.hs b/toysat/toysat.hs --- a/toysat/toysat.hs +++ b/toysat/toysat.hs @@ -21,7 +21,9 @@ import Control.Exception import Data.Array.IArray import qualified Data.ByteString.Lazy as BS +import Data.Default.Class import qualified Data.Set as Set +import qualified Data.IntSet as IntSet import Data.Map (Map) import qualified Data.Map as Map import Data.Char @@ -36,7 +38,9 @@ import System.IO import System.Environment import System.Exit -import System.Locale +#if !MIN_VERSION_time(1,5,0) +import System.Locale (defaultTimeLocale) +#endif import System.Console.GetOpt import System.CPUTime import System.FilePath @@ -63,7 +67,8 @@ import qualified ToySolver.SAT.Integer as Integer import qualified ToySolver.SAT.TseitinEncoder as Tseitin import qualified ToySolver.SAT.MUS as MUS -import qualified ToySolver.SAT.CAMUS as CAMUS +import qualified ToySolver.SAT.MUS.CAMUS as CAMUS +import qualified ToySolver.SAT.MUS.DAA as DAA import ToySolver.SAT.Printer import qualified ToySolver.Text.PBFile as PBFile import qualified ToySolver.Text.LPFile as LPFile @@ -80,6 +85,8 @@ data Mode = ModeHelp | ModeVersion | ModeSAT | ModeMUS | ModePB | ModeWBO | ModeMaxSAT | ModeMIP +data AllMUSMethod = AllMUSCAMUS | AllMUSDAA + data Options = Options { optMode :: Maybe Mode @@ -101,6 +108,7 @@ , optObjFunVarsHeuristics :: Bool , optLocalSearchInitial :: Bool , optAllMUSes :: Bool + , optAllMUSMethod :: AllMUSMethod , optPrintRational :: Bool , optCheckModel :: Bool , optTimeout :: Integer @@ -108,6 +116,9 @@ , optUBCSAT :: FilePath } +instance Default Options where + def = defaultOptions + defaultOptions :: Options defaultOptions = Options @@ -130,6 +141,7 @@ , optObjFunVarsHeuristics = PBO.defaultEnableObjFunVarsHeuristics , optLocalSearchInitial = False , optAllMUSes = False + , optAllMUSMethod = AllMUSCAMUS , optPrintRational = False , optCheckModel = False , optTimeout = 0 @@ -223,6 +235,9 @@ , Option [] ["all-mus"] (NoArg (\opt -> opt{ optAllMUSes = True })) "enumerate all MUSes" + , Option [] ["all-mus-daa"] + (NoArg (\opt -> opt{ optAllMUSes = True, optAllMUSMethod = AllMUSDAA })) + "enumerate all MUSes using DAA instead of CAMUS (experimental option)" , Option [] ["print-rational"] (NoArg (\opt -> opt{ optPrintRational = True })) @@ -292,7 +307,7 @@ exitFailure (o,args2,[]) -> do - let opt = foldl (flip id) defaultOptions o + let opt = foldl (flip id) def o mode = case optMode opt of Just m -> m @@ -472,7 +487,7 @@ result <- SAT.solve solver putSLine $ if result then "SATISFIABLE" else "UNSATISFIABLE" when result $ do - m <- SAT.model solver + m <- SAT.getModel solver satPrintModel stdout m (DIMACS.numVars cnf) writeSOLFile opt m Nothing (DIMACS.numVars cnf) @@ -521,30 +536,38 @@ putSLine $ if result then "SATISFIABLE" else "UNSATISFIABLE" if result then do - m <- SAT.model solver + m <- SAT.getModel solver satPrintModel stdout m (GCNF.numVars gcnf) writeSOLFile opt m Nothing (GCNF.numVars gcnf) else do if not (optAllMUSes opt) then do - let opt2 = MUS.defaultOptions + let opt2 = def { MUS.optLogger = putCommentLine , MUS.optLitPrinter = \lit -> show (sel2idx ! lit) } mus <- MUS.findMUSAssumptions solver opt2 - musPrintSol stdout (map (sel2idx !) mus) + let mus2 = sort $ map (sel2idx !) $ IntSet.toList mus + musPrintSol stdout mus2 else do - let opt2 = CAMUS.defaultOptions + counter <- newIORef 1 + let opt2 = def { CAMUS.optLogger = putCommentLine - , CAMUS.optCallback = \mcs -> do - let mcs2 = sort $ map (sel2idx !) mcs + , CAMUS.optOnMCSFound = \mcs -> do + let mcs2 = sort $ map (sel2idx !) $ IntSet.toList mcs putCommentLine $ "MCS found: " ++ show mcs2 + , CAMUS.optOnMUSFound = \mus -> do + i <- readIORef counter + modifyIORef' counter (+1) + putCommentLine $ "MUS #" ++ show (i :: Int) + let mus2 = sort $ map (sel2idx !) $ IntSet.toList mus + musPrintSol stdout mus2 } - muses <- CAMUS.allMUSAssumptions solver (map snd tbl) opt2 - forM_ (zip [(1::Int)..] muses) $ \(i, mus) -> do - putCommentLine $ "MUS #" ++ show i - musPrintSol stdout (sort (map (sel2idx !) mus)) + case optAllMUSMethod opt of + AllMUSCAMUS -> CAMUS.allMUSAssumptions solver (map snd tbl) opt2 + AllMUSDAA -> DAA.allMUSAssumptions solver (map snd tbl) opt2 + return () -- ------------------------------------------------------------------------ @@ -580,7 +603,7 @@ result <- SAT.solve solver putSLine $ if result then "SATISFIABLE" else "UNSATISFIABLE" when result $ do - m <- SAT.model solver + m <- SAT.getModel solver pbPrintModel stdout m nv writeSOLFile opt m Nothing nv @@ -769,25 +792,25 @@ mainMIP :: Options -> SAT.Solver -> [String] -> IO () mainMIP opt solver args = do - (fname,s) <- + mip <- case args of - ["-"] -> do + [fname@"-"] -> do s <- hGetContents stdin - return ("-", s) + case LPFile.parseString fname s of + Right mip -> return mip + Left err -> + case MPSFile.parseString fname s of + Right mip -> return mip + Left err2 -> do + hPrint stderr err + hPrint stderr err2 + exitFailure [fname] -> do - s <- readFile fname - return (fname, s) - _ -> showHelp stderr >> exitFailure - mip <- - case LPFile.parseString fname s of - Right mip -> return mip - Left err -> - case MPSFile.parseString fname s of + ret <- MIP.readFile fname + case ret of + Left err -> hPrint stderr err >> exitFailure Right mip -> return mip - Left err2 -> do - hPrint stderr err - hPrint stderr err2 - exitFailure + _ -> showHelp stderr >> exitFailure solveMIP opt solver mip solveMIP :: Options -> SAT.Solver -> MIP.Problem -> IO () @@ -922,3 +945,13 @@ Just fname -> do let m2 = Map.fromList [("x" ++ show x, if b then 1 else 0) | (x,b) <- assocs m, x <= nbvar] writeFile fname (GurobiSol.render (Map.map fromInteger m2) (fmap fromInteger obj)) + + +#if !MIN_VERSION_base(4,6,0) + +modifyIORef' :: IORef a -> (a -> a) -> IO () +modifyIORef' ref f = do + x <- readIORef ref + writeIORef ref $! f x + +#endif diff --git a/toysolver.cabal b/toysolver.cabal --- a/toysolver.cabal +++ b/toysolver.cabal @@ -1,5 +1,5 @@ Name: toysolver -Version: 0.1.0 +Version: 0.2.0 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) @@ -20,7 +20,6 @@ .travis.yml src/TseitinEncode.hs src/ToySolver/Data/Polyhedron.hs - src/ToySolver/Wang.hs samples/gcnf/*.cnf samples/gcnf/*.gcnf samples/lp/*.lp @@ -37,6 +36,11 @@ samples/smt/*.smt2 samples/smt/*.ys samples/qbf/*.qdimacs + samples/programs/sudoku/*.sdk + samples/programs/knapsack/README.md + samples/programs/knapsack/*.txt + samples/programs/htc/test1.dat + samples/programs/htc/test2.dat test/TestAReal2.hs benchmarks/UF250.1065.100/*.cnf benchmarks/UUF250.1065.100/*.cnf @@ -52,6 +56,11 @@ Default: False Manual: True +Flag BuildSamplePrograms + Description: build sample programs + Default: False + Manual: True + Flag BuildMiscPrograms Description: build misc programs Default: False @@ -65,6 +74,10 @@ Description: use random >=1.0.1.3 Manual: False +Flag Time15 + Description: use time >=1.5.0 + Manual: False + source-repository head type: git location: git://github.com/msakai/toysolver.git @@ -74,18 +87,18 @@ Hs-source-dirs: src Build-Depends: base >=4 && <5, - containers >= 0.4.2, unordered-containers >=0.2.3 && <0.3.0, mtl >=2.1.2, array, stm >=2.3, parsec, bytestring, filepath, deepseq, time, old-locale, primes, process >=1.1.0.2, + containers >= 0.4.2, unordered-containers >=0.2.3 && <0.3.0, mtl >=2.1.2, array >=0.4.0.0, stm >=2.3, parsec >=3.1.2 && <4, bytestring, filepath, deepseq, time, primes, process >=1.1.0.2, parse-dimacs, queue, heaps, unbounded-delays, vector-space >=0.8.6, multiset, prettyclass >=1.0.0, type-level-numbers >=0.1.1.0 && <0.2.0.0, hashable >=1.1.2.5 && <1.3.0.0, intern >=0.9.1.2 && <1.0.0.0, - loop >=0.2.0 && < 1.0.0, - OptDir, data-interval >=0.6.0 && <1.0.0, finite-field >=0.7.0 && <1.0.0, sign >=0.2.0 && <1.0.0 + loop >=0.2.0 && < 1.0.0, data-default-class, + OptDir, extended-reals >=0.1 && <1.0, data-interval >=1.0.1 && <1.3.0, finite-field >=0.7.0 && <1.0.0, sign >=0.2.0 && <1.0.0 -- NOTE: temporary-1.2.0.2 does not work with exceptions-0.6 if flag(Exceptions06) Build-Depends: temporary >1.2.0.2, exceptions >=0.6 - if !flag(Exceptions06) + else Build-Depends: temporary >=1.2, exceptions ==0.5 + -- NOTE: random-1.0.1.3 uses atomicModifyIORef' which is provided by base >=4.6.0.0. if flag(Random1013) - -- NOTE: random-1.0.1.3 uses atomicModifyIORef' which is provided by base >=4.6.0.0. Build-Depends: base >=4.6.0.0, random >=1.0.1.3 else Build-Depends: random <1.0.1.3 @@ -107,30 +120,33 @@ TypeSynonymInstances OverloadedStrings Exposed-Modules: - ToySolver.BoundsInference - ToySolver.CAD + ToySolver.Arith.BoundsInference + ToySolver.Arith.CAD + ToySolver.Arith.ContiTraverso + ToySolver.Arith.Cooper + ToySolver.Arith.Cooper.Base + ToySolver.Arith.Cooper.FOL + ToySolver.Arith.FourierMotzkin + ToySolver.Arith.FourierMotzkin.Base + ToySolver.Arith.FourierMotzkin.FOL + ToySolver.Arith.FourierMotzkin.Optimization + ToySolver.Arith.LPSolver + ToySolver.Arith.LPSolverHL + ToySolver.Arith.LPUtil + ToySolver.Arith.MIPSolverHL + ToySolver.Arith.MIPSolver2 + ToySolver.Arith.OmegaTest + ToySolver.Arith.OmegaTest.Base + ToySolver.Arith.Simplex + ToySolver.Arith.Simplex2 + ToySolver.Arith.VirtualSubstitution ToySolver.CongruenceClosure - ToySolver.ContiTraverso - ToySolver.Cooper - ToySolver.Cooper.Core - ToySolver.Cooper.FOL ToySolver.FOLModelFinder - ToySolver.FourierMotzkin - ToySolver.FourierMotzkin.Core - ToySolver.FourierMotzkin.FOL - ToySolver.HittingSet - ToySolver.HittingSet.HTCBDD - ToySolver.HittingSet.SHD - ToySolver.Knapsack - ToySolver.LPSolver - ToySolver.LPSolverHL - ToySolver.LPUtil - ToySolver.MIPSolverHL - ToySolver.MIPSolver2 - ToySolver.OmegaTest - ToySolver.OmegaTest.Misc - ToySolver.Simplex - ToySolver.Simplex2 + ToySolver.Combinatorial.HittingSet.Simple + ToySolver.Combinatorial.HittingSet.HTCBDD + ToySolver.Combinatorial.HittingSet.SHD + ToySolver.Combinatorial.Knapsack.BB + ToySolver.Combinatorial.Knapsack.DP ToySolver.Converter.ObjType ToySolver.Converter.MIP2SMT ToySolver.Converter.MaxSAT2IP @@ -150,6 +166,7 @@ ToySolver.Data.AlgebraicNumber.Sturm ToySolver.Data.ArithRel ToySolver.Data.Boolean + ToySolver.Data.BoolExpr ToySolver.Data.Delta ToySolver.Data.DNF ToySolver.Data.FOL.Arith @@ -158,6 +175,7 @@ ToySolver.Data.LA.FOL ToySolver.Data.LBool ToySolver.Data.MIP + ToySolver.Data.MIP.Base ToySolver.Data.Polynomial ToySolver.Data.Polynomial.Factorization.FiniteField ToySolver.Data.Polynomial.Factorization.Hensel @@ -169,12 +187,13 @@ ToySolver.Data.Polynomial.Factorization.Zassenhaus ToySolver.Data.Polynomial.GroebnerBasis ToySolver.Data.Polynomial.Interpolation.Lagrange - ToySolver.Data.Vec ToySolver.Data.Var ToySolver.SAT ToySolver.SAT.Integer ToySolver.SAT.MUS - ToySolver.SAT.CAMUS + ToySolver.SAT.MUS.CAMUS + ToySolver.SAT.MUS.DAA + ToySolver.SAT.MUS.Types ToySolver.SAT.PBO ToySolver.SAT.PBO.Context ToySolver.SAT.PBO.BC @@ -194,11 +213,14 @@ ToySolver.Text.PBFile ToySolver.Text.SDPFile ToySolver.Internal.Data.IndexedPriorityQueue + ToySolver.Internal.Data.IOURef ToySolver.Internal.Data.PriorityQueue ToySolver.Internal.Data.SeqQueue + ToySolver.Internal.Data.Vec ToySolver.Internal.ProcessUtil ToySolver.Internal.TextUtil ToySolver.Internal.Util + ToySolver.Wang ToySolver.Version Other-Modules: ToySolver.Data.AlgebraicNumber.Graeffe @@ -209,7 +231,7 @@ Executable toysolver Main-is: toysolver.hs HS-Source-Dirs: toysolver - Build-Depends: base >=4.4 && <5, containers, array, filepath, parsec, OptDir, parse-dimacs, toysolver + Build-Depends: base >=4.4 && <5, containers, array, data-default-class, filepath, parsec, OptDir, parse-dimacs, toysolver Default-Language: Haskell2010 if impl(ghc) GHC-Options: -threaded @@ -221,7 +243,11 @@ Main-is: toysat.hs Other-Modules: UBCSAT HS-Source-Dirs: toysat - Build-Depends: base >=4 && <5, random, containers >= 0.4.2, array, process >=1.1.0.2, parsec, bytestring, filepath, parse-dimacs, time, old-locale, unbounded-delays, vector-space >=0.8.6, toysolver + Build-Depends: base >=4 && <5, data-default-class, random, containers >= 0.4.2, array, process >=1.1.0.2, parsec, bytestring, filepath, parse-dimacs, unbounded-delays, vector-space >=0.8.6, toysolver + if flag(Time15) + Build-Depends: time >=1.5.0 + else + Build-Depends: time <1.5.0, old-locale Default-Language: Haskell2010 Other-Extensions: ScopedTypeVariables, CPP if impl(ghc >= 7) @@ -243,6 +269,8 @@ GHC-Options: -rtsopts GHC-Prof-Options: -auto-all +-- Converters + Executable lpconvert Main-is: lpconvert.hs HS-Source-Dirs: lpconvert @@ -255,6 +283,42 @@ Build-Depends: base >=4 && <5, containers, filepath, parse-dimacs, toysolver Default-Language: Haskell2010 +-- Sample Programs + +Executable sudoku + If !flag(BuildSamplePrograms) + Buildable: False + Main-is: sudoku.hs + HS-Source-Dirs: samples/programs/sudoku + Build-Depends: base, array, toysolver + Default-Language: Haskell2010 + +Executable nqueens + If !flag(BuildSamplePrograms) + Buildable: False + Main-is: nqueens.hs + HS-Source-Dirs: samples/programs/nqueens + Build-Depends: base, array, toysolver + Default-Language: Haskell2010 + +Executable knapsack + If !flag(BuildSamplePrograms) + Buildable: False + Main-is: knapsack.hs + HS-Source-Dirs: samples/programs/knapsack + Build-Depends: base, array, toysolver + Default-Language: Haskell2010 + +Executable htc + If !flag(BuildSamplePrograms) + Buildable: False + Main-is: htc.hs + HS-Source-Dirs: samples/programs/htc + Build-Depends: base, containers, toysolver + Default-Language: Haskell2010 + +-- Misc Programs + Executable pigeonhole If !flag(BuildMiscPrograms) Buildable: False @@ -277,6 +341,8 @@ Build-Depends: base >=4 && <5, array, containers, filepath, toysolver Default-Language: Haskell2010 +-- Test suites and benchmarks + Test-suite TestSAT Type: exitcode-stdio-1.0 HS-Source-Dirs: test @@ -325,11 +391,11 @@ Default-Language: Haskell2010 Other-Extensions: TemplateHaskell, ScopedTypeVariables -Test-suite TestQE +Test-suite TestArith Type: exitcode-stdio-1.0 HS-Source-Dirs: test - Main-is: TestQE.hs - Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2 >=0.2.12.3 && <0.4.0,HUnit,QuickCheck >=2.5 && <3 + Main-is: TestArith.hs + Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, data-interval, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2 >=0.2.12.3 && <0.4.0,HUnit,QuickCheck >=2.5 && <3 Default-Language: Haskell2010 Other-Extensions: TemplateHaskell @@ -385,7 +451,7 @@ Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestUtil.hs - Build-depends: base >=4 && <5, toysolver, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2 >=0.2.12.3 && <0.4.0,HUnit,QuickCheck >=2.5 && <3 + Build-depends: base >=4 && <5, containers, toysolver, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2 >=0.2.12.3 && <0.4.0,HUnit,QuickCheck >=2.5 && <3 Default-Language: Haskell2010 Other-Extensions: TemplateHaskell, ScopedTypeVariables @@ -393,5 +459,5 @@ type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: BenchmarkSATLIB.hs - build-depends: base >=4 && <5, array, containers, random, parse-dimacs, toysolver, criterion + build-depends: base >=4 && <5, array, containers, random, parse-dimacs, toysolver, criterion >=1.0 && <1.1 Default-Language: Haskell2010 diff --git a/toysolver/toysolver.hs b/toysolver/toysolver.hs --- a/toysolver/toysolver.hs +++ b/toysolver/toysolver.hs @@ -17,6 +17,7 @@ import Control.Concurrent import Data.Array.IArray import Data.Char +import Data.Default.Class import Data.List import Data.Maybe import Data.Ratio @@ -44,16 +45,13 @@ import qualified ToySolver.Data.Polynomial as P import qualified ToySolver.Data.AlgebraicNumber.Real as AReal import qualified ToySolver.Data.MIP as MIP -import qualified ToySolver.OmegaTest as OmegaTest -import qualified ToySolver.OmegaTest.Misc as OmegaTest -import qualified ToySolver.Cooper as Cooper -import qualified ToySolver.MIPSolverHL as MIPSolverHL -import qualified ToySolver.Simplex2 as Simplex2 -import qualified ToySolver.MIPSolver2 as MIPSolver2 -import qualified ToySolver.CAD as CAD -import qualified ToySolver.ContiTraverso as ContiTraverso -import qualified ToySolver.Text.LPFile as LPFile -import qualified ToySolver.Text.MPSFile as MPSFile +import qualified ToySolver.Arith.OmegaTest as OmegaTest +import qualified ToySolver.Arith.Cooper as Cooper +import qualified ToySolver.Arith.MIPSolverHL as MIPSolverHL +import qualified ToySolver.Arith.Simplex2 as Simplex2 +import qualified ToySolver.Arith.MIPSolver2 as MIPSolver2 +import qualified ToySolver.Arith.CAD as CAD +import qualified ToySolver.Arith.ContiTraverso as ContiTraverso import qualified ToySolver.Text.PBFile as PBFile import qualified ToySolver.Text.MaxSAT as MaxSAT import qualified ToySolver.Text.GurobiSol as GurobiSol @@ -94,7 +92,7 @@ , Option [] ["pivot-strategy"] (ReqArg PivotStrategy "[bland-rule|largest-coefficient]") "pivot strategy for simplex (default: bland-rule)" , Option [] ["threads"] (ReqArg (NThread . read) "INTEGER") "number of threads to use" - , Option [] ["omega-real"] (ReqArg OmegaReal "SOLVER") "fourier-motzkin (default), cad, simplex, none" + , Option [] ["omega-real"] (ReqArg OmegaReal "SOLVER") "fourier-motzkin (default), virtual-substitution (or vs), cad, simplex, none" , Option [] ["sat"] (NoArg (Mode ModeSAT)) "solve boolean satisfiability problem in .cnf file" , Option [] ["pb"] (NoArg (Mode ModePB)) "solve pseudo boolean problem in .opb file" @@ -157,7 +155,7 @@ MIP.Le -> Le MIP.Eql -> Eql case ind of - Nothing -> return (Rel (compileE lhs) rel2 (Const rhs)) + Nothing -> return (ArithRel (compileE lhs) rel2 (Const rhs)) Just _ -> error "indicator constraint is not supported yet" ivs @@ -184,19 +182,21 @@ printModel m2 where f = case solver of - "omega" -> OmegaTest.solveQFLA omegaOpt - "omega-test" -> OmegaTest.solveQFLA omegaOpt - "cooper" -> Cooper.solveQFLA + "omega" -> OmegaTest.solveQFLIRAConj omegaOpt + "omega-test" -> OmegaTest.solveQFLIRAConj omegaOpt + "cooper" -> Cooper.solveQFLIRAConj _ -> error "unknown solver" omegaOpt = - OmegaTest.defaultOptions + def { OmegaTest.optCheckReal = realSolver } where realSolver = case last ("fourier-motzkin" : [s | OmegaReal s <- opt]) of "fourier-motzkin" -> OmegaTest.checkRealByFM + "virtual-substitution" -> OmegaTest.checkRealByVS + "vs" -> OmegaTest.checkRealByVS "cad" -> OmegaTest.checkRealByCAD "simplex" -> OmegaTest.checkRealBySimplex "none" -> OmegaTest.checkRealNoCheck @@ -283,7 +283,7 @@ putCommentLine "integer variables are not supported by CAD" exitFailure | otherwise = do - let cs = map g $ cs1 ++ cs2 + let cs = map (fmap f) $ cs1 ++ cs2 vs3 = Set.fromAscList $ IntSet.toAscList vs2 case CAD.solve vs3 cs of Nothing -> do @@ -297,8 +297,6 @@ let m3 = Map.fromAscList [(v, m2 IntMap.! (nameToVar Map.! v)) | v <- Set.toList vs] printModel m3 where - g (Rel lhs rel rhs) = Rel (f lhs) rel (f rhs) - f (Const r) = P.constant r f (Var v) = P.var v f (e1 :+: e2) = f e1 + f e2 @@ -436,17 +434,10 @@ maxsatPrintModel stdout m2 0 writeSOLFileSAT o m2 ModeMIP -> do - ret <- LPFile.parseFile fname + ret <- MIP.readFile fname mip <- case ret of Right mip -> return mip - Left err -> do - ret <- MPSFile.parseFile fname - case ret of - Right mip -> return mip - Left err2 -> do - hPrint stderr err - hPrint stderr err2 - exitFailure + Left err -> hPrint stderr err >> exitFailure run (getSolver o) o mip $ \m -> do mipPrintModel stdout (PrintRational `elem` o) m writeSOLFileMIP o m