toysolver 0.0.3 → 0.0.4
raw patch · 81 files changed
+4171/−4673 lines, 81 filesdep +data-intervaldep +latticesdep +vector-spacedep ~basedep ~containersnew-component:exe:pbconvert
Dependencies added: data-interval, lattices, vector-space
Dependency ranges changed: base, containers
Files
- README.md +15/−0
- lpconvert/lpconvert.hs +24/−8
- pbconvert/pbconvert.hs +180/−0
- samples/gcnf/camus.cnf +11/−0
- samples/gcnf/uuf250-01.gcnf +0/−1073
- samples/gcnf/uuf50-01.gcnf +0/−226
- samples/gcnf/uuf50-01b.gcnf +0/−226
- samples/gcnf/uuf50-01c.gcnf +0/−226
- samples/maxsat/MML10.wcnf +8/−0
- samples/maxsat/file_rwpms_wcnf_L2_V150_C1000_H150_0.wcnf +1003/−0
- samples/wbo/example-lin.wbo +0/−6
- src/Algebra/Lattice/Boolean.hs +66/−0
- src/Algorithm/BoundsInference.hs +37/−13
- src/Algorithm/CAD.hs +14/−11
- src/Algorithm/ContiTraverso.hs +8/−11
- src/Algorithm/Cooper.hs +5/−399
- src/Algorithm/Cooper/Core.hs +449/−0
- src/Algorithm/Cooper/FOL.hs +54/−0
- src/Algorithm/FourierMotzkin.hs +5/−260
- src/Algorithm/FourierMotzkin/Core.hs +229/−0
- src/Algorithm/FourierMotzkin/FOL.hs +59/−0
- src/Algorithm/LPSolver.hs +28/−24
- src/Algorithm/LPSolverHL.hs +114/−126
- src/Algorithm/LPUtil.hs +11/−11
- src/Algorithm/MIPSolver2.hs +4/−4
- src/Algorithm/MIPSolverHL.hs +26/−44
- src/Algorithm/OmegaTest.hs +55/−28
- src/Algorithm/OmegaTest/Misc.hs +41/−0
- src/Algorithm/Simplex.hs +4/−4
- src/Algorithm/Simplex2.hs +26/−26
- src/Converter/CNF2LP.hs +0/−77
- src/Converter/MaxSAT2LP.hs +4/−67
- src/Converter/MaxSAT2NLPB.hs +28/−0
- src/Converter/MaxSAT2WBO.hs +32/−0
- src/Converter/PB2LP.hs +7/−11
- src/Converter/PB2LSP.hs +60/−0
- src/Converter/PB2SMP.hs +85/−0
- src/Converter/PB2WBO.hs +33/−0
- src/Converter/PBSetObj.hs +31/−0
- src/Converter/SAT2LP.hs +25/−0
- src/Converter/SAT2PB.hs +24/−0
- src/Converter/WBO2PB.hs +47/−0
- src/Data/AlgebraicNumber.hs +17/−17
- src/Data/ArithRel.hs +5/−2
- src/Data/DNF.hs +46/−0
- src/Data/Delta.hs +11/−9
- src/Data/Expr.hs +0/−118
- src/Data/FOL/Arith.hs +112/−0
- src/Data/FOL/Formula.hs +92/−0
- src/Data/Formula.hs +0/−112
- src/Data/Interval.hs +0/−481
- src/Data/LA.hs +30/−56
- src/Data/LA/FOL.hs +56/−0
- src/Data/Lattice.hs +0/−90
- src/Data/Linear.hs +0/−72
- src/Data/Polyhedron.hs +19/−8
- src/Data/Polynomial.hs +11/−10
- src/Data/Polynomial/Sturm.hs +10/−10
- src/Data/Var.hs +45/−0
- src/SAT.hs +154/−20
- src/SAT/Integer.hs +10/−6
- src/SAT/MUS.hs +3/−3
- src/SAT/PBO.hs +160/−77
- src/SAT/PBO/MSU4.hs +108/−0
- src/SAT/PBO/UnsatBased.hs +92/−0
- src/SAT/Types.hs +27/−35
- src/Text/GCNF.hs +4/−3
- src/Text/MaxSAT.hs +6/−4
- src/Text/PBFile.hs +2/−37
- src/Text/Util.hs +79/−0
- src/Version.hs +6/−0
- test/TestContiTraverso.hs +35/−30
- test/TestInterval.hs +0/−469
- test/TestMIPSolver2.hs +10/−11
- test/TestPolynomial.hs +10/−9
- test/TestQE.hs +18/−17
- test/TestSAT.hs +13/−0
- test/TestSimplex2.hs +1/−1
- toysat/toysat.hs +16/−21
- toysolver.cabal +42/−25
- toysolver/toysolver.hs +69/−39
README.md view
@@ -1,6 +1,8 @@ toysolver ========= +Assorted decision procedures for SAT, Max-SAT, PB, MIP, etc.+ Installation ------------ @@ -75,6 +77,19 @@ * Input formats: lp, mps, cnf, wcnf, opb, wbo * Output formats: lp, smt2, ys++### pbconvert++Converter between SAT/PB-related formats++Usage:++ pbconvert -o <outputile> <inputfile>++Supported formats:++* Input formats: cnf, wcnf, opb, wbo+* Output formats: opb wbo TODO ----
lpconvert/lpconvert.hs view
@@ -27,10 +27,12 @@ import qualified Text.MPSFile as MPSFile import qualified Text.PBFile as PBFile import Converter.ObjType-import qualified Converter.CNF2LP as CNF2LP import qualified Converter.LP2SMT as LP2SMT import qualified Converter.MaxSAT2LP as MaxSAT2LP+import qualified Converter.MaxSAT2NLPB as MaxSAT2NLPB import qualified Converter.PB2LP as PB2LP+import qualified Converter.PBSetObj as PBSetObj+import qualified Converter.SAT2PB as SAT2PB import Version data Flag@@ -43,6 +45,7 @@ | Optimize | NoCheck | NoProduceModel+ | MaxSATNonLinear deriving Eq options :: [OptDescr Flag]@@ -50,12 +53,13 @@ [ Option ['h'] ["help"] (NoArg Help) "show help" , Option ['v'] ["version"] (NoArg Version) "show version number" , Option ['o'] [] (ReqArg Output "FILE") "output filename"- , Option [] ["max-sat"] (NoArg AsMaxSAT) "treat *.cnf file as MAX-SAT problem"+ , Option [] ["maxsat"] (NoArg AsMaxSAT) "treat *.cnf file as MAX-SAT problem" , Option [] ["obj"] (ReqArg (ObjType . parseObjType) "STRING") "objective function for SAT/PBS: none (default), max-one, max-zero" , Option [] ["indicator"] (NoArg IndicatorConstraint) "use indicator constraints in output LP file" , Option [] ["smt-optimize"] (NoArg Optimize) "output optimiality condition which uses quantifiers" , Option [] ["smt-no-check"] (NoArg NoCheck) "do not output \"(check)\"" , Option [] ["smt-no-produce-model"] (NoArg NoProduceModel) "do not output \"(set-option :produce-models true)\"" + , Option [] ["maxsat-nonlinear"] (NoArg MaxSATNonLinear) "use non-linear formulation of Max-SAT" ] where parseObjType s =@@ -79,7 +83,6 @@ readLP :: [Flag] -> String -> IO LPFile.LP readLP o fname = do- let objType = last (ObjNone : [t | ObjType t <- o]) case map toLower (takeExtension fname) of ".cnf" | AsMaxSAT `elem` o -> readWCNF@@ -88,7 +91,8 @@ case ret of Left err -> hPrint stderr err >> exitFailure Right cnf -> do- let (lp, _) = CNF2LP.convert objType cnf+ let pb = transformPBFile o $ SAT2PB.convert cnf+ let (lp, _) = PB2LP.convert pb return lp ".wcnf" -> readWCNF ".opb" -> do@@ -96,7 +100,8 @@ case ret of Left err -> hPrint stderr err >> exitFailure Right formula -> do- let (lp, _) = PB2LP.convert objType formula+ let pb = transformPBFile o formula+ let (lp, _) = PB2LP.convert pb return lp ".wbo" -> do ret <- PBFile.parseWBOFile fname@@ -122,9 +127,20 @@ ret <- MaxSAT.parseWCNFFile fname case ret of Left err -> hPutStrLn stderr err >> exitFailure- Right wcnf -> do- let (lp, _) = MaxSAT2LP.convert wcnf- return lp+ Right wcnf+ | MaxSATNonLinear `elem` o -> do+ let pb = transformPBFile o $ MaxSAT2NLPB.convert wcnf+ (lp, _) = PB2LP.convert pb+ return lp+ | otherwise -> do+ let (lp, _) = MaxSAT2LP.convert (IndicatorConstraint `elem` o) wcnf+ return lp++transformPBFile :: [Flag] -> PBFile.Formula -> PBFile.Formula+transformPBFile o opb@(Nothing,_) = PBSetObj.setObj objType opb+ where+ objType = last (ObjNone : [t | ObjType t <- o])+transformPBFile _ opb = opb writeLP :: [Flag] -> LPFile.LP -> IO () writeLP o lp = do
+ pbconvert/pbconvert.hs view
@@ -0,0 +1,180 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : pbconvert+-- Copyright : (c) Masahiro Sakai 2012+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------++module Main where++import Data.Char+import qualified Data.Version as V+import System.Environment+import System.IO+import System.Exit+import System.FilePath+import System.Console.GetOpt+import qualified Language.CNF.Parse.ParseDIMACS as DIMACS++import qualified Text.LPFile as LPFile+import qualified Text.MaxSAT as MaxSAT+import qualified Text.PBFile as PBFile+import Converter.ObjType+import qualified Converter.SAT2PB as SAT2PB+import qualified Converter.LP2SMT as LP2SMT+import qualified Converter.MaxSAT2WBO as MaxSAT2WBO+import qualified Converter.MaxSAT2NLPB as MaxSAT2NLPB+import qualified Converter.PB2LP as PB2LP+import qualified Converter.PB2LSP as PB2LSP+import qualified Converter.PB2WBO as PB2WBO+import qualified Converter.PBSetObj as PBSetObj+import qualified Converter.PB2SMP as PB2SMP+import qualified Converter.WBO2PB as WBO2PB+import Version++data Flag+ = Help+ | Version+ | Output String+ | AsMaxSAT+ | ObjType ObjType+ | IndicatorConstraint+ | Optimize+ | NoCheck+ | NoProduceModel+ | MaxSATNonLinear+ deriving Eq++options :: [OptDescr Flag]+options =+ [ Option ['h'] ["help"] (NoArg Help) "show help"+ , Option ['v'] ["version"] (NoArg Version) "show version number"+ , Option ['o'] [] (ReqArg Output "FILE") "output filename"+ , Option [] ["maxsat"] (NoArg AsMaxSAT) "treat *.cnf file as MAX-SAT problem"+ , Option [] ["obj"] (ReqArg (ObjType . parseObjType) "STRING") "objective function for SAT/PBS: none (default), max-one, max-zero"+ , Option [] ["indicator"] (NoArg IndicatorConstraint) "use indicator constraints in output LP file"+ , Option [] ["smt-optimize"] (NoArg Optimize) "output optimiality condition which uses quantifiers"+ , Option [] ["smt-no-check"] (NoArg NoCheck) "do not output \"(check)\""+ , Option [] ["smt-no-produce-model"] (NoArg NoProduceModel) "do not output \"(set-option :produce-models true)\"" + , Option [] ["maxsat-nonlinear"] (NoArg MaxSATNonLinear) "use non-linear formulation of Max-SAT"+ ]+ where+ parseObjType s =+ case map toLower s of+ "none" -> ObjNone+ "max-one" -> ObjMaxOne+ "max-zero" -> ObjMaxZero+ _ -> error ("unknown obj: " ++ s)++header :: String+header = unlines+ [ "Usage:"+ , " pbconvert -o <outputfile> <inputfile>"+ , ""+ , "Supported formats:"+ , " input: .cnf .wcnf .opb .wbo"+ , " output: .opb .wbo"+ , ""+ , "Options:"+ ]++readPBFile :: [Flag] -> String -> IO (Either PBFile.Formula PBFile.SoftFormula)+readPBFile o fname = do+ case map toLower (takeExtension fname) of+ ".cnf"+ | AsMaxSAT `elem` o -> readWCNF+ | otherwise -> do+ ret <- DIMACS.parseFile fname+ case ret of+ Left err -> hPrint stderr err >> exitFailure+ Right cnf -> return $ Left $ SAT2PB.convert cnf+ ".wcnf" -> readWCNF+ ".opb" -> do+ ret <- PBFile.parseOPBFile fname+ case ret of+ Left err -> hPrint stderr err >> exitFailure+ Right opb -> return $ Left opb+ ".wbo" -> do+ ret <- PBFile.parseWBOFile fname+ case ret of+ Left err -> hPrint stderr err >> exitFailure+ Right wbo -> return $ Right wbo+ ext ->+ error $ "unknown file extension: " ++ show ext+ where+ readWCNF = do+ ret <- MaxSAT.parseWCNFFile fname+ case ret of+ Left err -> hPutStrLn stderr err >> exitFailure+ Right wcnf+ | MaxSATNonLinear `elem` o -> return $ Left $ MaxSAT2NLPB.convert wcnf+ | otherwise -> return $ Right $ MaxSAT2WBO.convert wcnf++transformPBFile :: [Flag] -> Either PBFile.Formula PBFile.SoftFormula -> Either PBFile.Formula PBFile.SoftFormula+transformPBFile o pb =+ case pb of+ Left opb@(Nothing,_) -> Left $ PBSetObj.setObj objType opb+ _ -> pb+ where+ objType = last (ObjNone : [t | ObjType t <- o])++writePBFile :: [Flag] -> Either PBFile.Formula PBFile.SoftFormula -> IO ()+writePBFile o pb = do+ let lp2smtOpt =+ LP2SMT.defaultOptions+ { LP2SMT.optCheckSAT = not (NoCheck `elem` o)+ , LP2SMT.optProduceModel = not (NoProduceModel `elem` o)+ , LP2SMT.optOptimize = Optimize `elem` o+ }+ 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 ""+ Just fname -> do+ let opb = case pb of+ Left opb -> opb+ Right wbo -> fst $ WBO2PB.convert wbo+ wbo = case pb of+ Left opb -> PB2WBO.convert opb+ Right wbo -> wbo+ lp = case pb of+ Left opb -> fst $ PB2LP.convert opb+ Right wbo -> fst $ PB2LP.convertWBO (IndicatorConstraint `elem` o) wbo+ case map toLower (takeExtension fname) of+ ".opb" -> writeFile fname (PBFile.showOPB opb "")+ ".wbo" -> writeFile fname (PBFile.showWBO wbo "")+ ".lsp" -> writeFile fname (PB2LSP.convert opb "")+ ".lp" -> do+ case LPFile.render lp of+ Nothing -> hPutStrLn stderr "conversion failure" >> exitFailure+ Just s -> writeFile fname s+ ".smp" -> do+ writeFile fname (PB2SMP.convert False opb "")+ ".smt2" -> do+ writeFile fname (LP2SMT.convert lp2smtOpt lp "")+ ".ys" -> do+ writeFile fname (LP2SMT.convert lp2smtOpt{ LP2SMT.optLanguage = LP2SMT.YICES } lp "")+ ext -> do+ error $ "unknown file extension: " ++ show ext+ +main :: IO ()+main = do+ args <- getArgs+ case getOpt Permute options args of+ (o,_,[])+ | Help `elem` o -> putStrLn (usageInfo header options)+ | Version `elem` o -> putStrLn (V.showVersion version)+ (o,[fname],[]) -> do+ pb <- readPBFile o fname+ let pb2 = transformPBFile o pb+ writePBFile o pb2+ (_,_,errs) -> do+ hPutStrLn stderr $ concat errs ++ usageInfo header options+ exitFailure
+ samples/gcnf/camus.cnf view
@@ -0,0 +1,11 @@+c http://sun.iwu.edu/~mliffito/publications/jar_liffiton_CAMUS.pdf+cφ= (x1) ∧ (¬x1) ∧ (¬x1∨x2) ∧ (¬x2) ∧ (¬x1∨x3) ∧ (¬x3)+c MUSes(φ) = {{C1, C2}, {C1, C3, C4}, {C1, C5, C6}}+c MCSes(φ) = {{C1}, {C2, C3, C5}, {C2, C3, C6}, {C2, C4, C5}, {C2, C4, C6}}+p cnf 3 6+1 0+-1 0+-1 2 0+-2 0+-1 3 0+-3 0
− samples/gcnf/uuf250-01.gcnf
@@ -1,1073 +0,0 @@-c This Formular is generated by mcnf-c-c horn? no -c forced? no -c mixed sat? no -c clause length = 3 -c-p gcnf 250 1065 9-{5} -128 -209 148 0-{2} 2 196 -115 0-{3} -66 -189 -241 0-{7} -84 -132 -93 0-{5} 214 179 66 0-{8} 203 132 -237 0-{2} 164 -13 -172 0-{0} -157 198 160 0-{4} -91 -164 235 0-{0} -70 -116 54 0-{3} -164 171 -189 0-{9} 126 -184 211 0-{1} -19 118 41 0-{9} 32 105 -33 0-{6} -141 -108 50 0-{3} -1 156 -188 0-{4} 138 -181 142 0-{5} -191 -247 -220 0-{3} -101 -207 -88 0-{0} 68 114 -234 0-{3} 134 -57 -131 0-{4} -30 -133 116 0-{5} -24 -173 92 0-{3} 226 -4 -224 0-{8} -190 204 61 0-{3} 148 205 -174 0-{3} 213 -56 53 0-{2} 174 -250 206 0-{4} 32 219 -112 0-{1} 203 -222 202 0-{8} 130 42 226 0-{7} 222 33 58 0-{2} 58 35 34 0-{4} -121 80 245 0-{0} -231 38 -248 0-{7} -205 -179 184 0-{0} -182 -204 -36 0-{3} 23 35 -181 0-{3} 82 -168 -59 0-{8} 103 132 -182 0-{4} -243 -18 -160 0-{0} -180 130 95 0-{9} 111 -140 -107 0-{7} 19 28 -72 0-{8} -222 207 -103 0-{0} 134 -50 -184 0-{8} 185 155 -11 0-{1} -102 230 -18 0-{1} -112 39 242 0-{9} 154 -87 53 0-{5} 173 -123 -159 0-{9} -238 -101 -40 0-{7} -126 -232 -139 0-{1} 107 -51 197 0-{2} -194 -138 -150 0-{5} 106 -66 -11 0-{3} -150 -159 -27 0-{8} -98 -32 138 0-{9} 144 -32 128 0-{4} 153 74 -249 0-{4} -190 -175 -208 0-{3} -127 88 -38 0-{6} -59 125 -225 0-{6} -23 4 181 0-{2} 12 247 -133 0-{1} 151 -238 127 0-{9} 237 -65 -154 0-{6} -218 -26 -55 0-{1} 91 -245 169 0-{8} -81 -156 10 0-{3} 166 -66 -45 0-{9} 109 -162 47 0-{0} -193 153 40 0-{1} 162 -186 -7 0-{1} 93 38 -58 0-{5} -159 -167 -39 0-{4} -187 68 124 0-{6} 247 23 212 0-{8} 49 182 -243 0-{2} 206 -105 -237 0-{3} 236 116 154 0-{5} 236 -6 182 0-{8} -168 236 35 0-{0} -186 70 -236 0-{0} 127 80 103 0-{4} 100 79 -176 0-{1} 117 -88 -1 0-{9} 60 -115 -224 0-{2} -148 181 -65 0-{2} -132 235 19 0-{4} -44 -197 190 0-{4} -214 67 129 0-{9} -203 175 -191 0-{9} -172 166 -115 0-{8} -176 -180 207 0-{1} -56 -208 -1 0-{4} -37 140 -19 0-{6} -242 -55 58 0-{7} -116 -153 241 0-{2} -203 64 -219 0-{1} -214 64 90 0-{7} -166 96 155 0-{8} 68 -2 63 0-{1} -200 49 196 0-{0} -230 -232 -148 0-{8} -81 105 219 0-{2} 187 -236 -123 0-{8} -99 237 136 0-{6} -205 61 -118 0-{2} -235 -230 128 0-{9} 38 -9 -124 0-{9} -34 -116 179 0-{3} -40 -55 -85 0-{2} 244 170 6 0-{4} -7 -54 -236 0-{6} 153 -223 173 0-{8} -219 -13 -217 0-{8} 244 -210 -228 0-{5} 23 -128 -113 0-{4} 35 -245 -235 0-{5} 184 31 143 0-{2} -207 -24 135 0-{3} 97 -165 -14 0-{4} -17 15 26 0-{2} 61 78 -8 0-{3} 215 -30 -166 0-{5} 229 93 -246 0-{1} -167 -113 80 0-{5} 78 205 -87 0-{5} 117 -144 207 0-{5} -10 153 -84 0-{7} -147 238 61 0-{7} -58 -17 -190 0-{3} 209 -25 -81 0-{4} -175 244 -57 0-{1} 185 127 -147 0-{2} 237 199 -144 0-{8} 124 148 -10 0-{7} 190 244 231 0-{1} -185 214 -101 0-{7} -237 31 -94 0-{8} -39 36 -94 0-{5} -175 206 81 0-{8} 141 -209 -109 0-{3} 228 -165 -112 0-{8} -45 142 238 0-{3} -34 -64 -71 0-{1} -60 170 -109 0-{7} 6 245 87 0-{5} 12 -93 -231 0-{8} 80 216 28 0-{5} -103 137 116 0-{3} -77 -73 -30 0-{7} -63 219 -129 0-{4} -215 -94 86 0-{3} 81 46 221 0-{1} 161 -215 -212 0-{3} -137 -215 48 0-{4} -50 211 229 0-{8} 172 74 154 0-{0} -14 -100 166 0-{2} 59 -119 -243 0-{0} 244 -31 -96 0-{2} 51 -247 205 0-{9} -90 97 -139 0-{6} 113 118 -7 0-{3} 57 -161 -84 0-{6} 180 -174 -9 0-{6} -19 16 -202 0-{1} -39 -134 224 0-{2} 84 240 195 0-{7} -55 75 -207 0-{6} 116 54 60 0-{0} 80 98 40 0-{4} -159 109 217 0-{3} -210 -119 82 0-{1} -201 -14 174 0-{6} 43 -19 -100 0-{1} -126 223 26 0-{8} -249 163 -205 0-{9} -58 -4 109 0-{8} -239 109 -82 0-{9} 210 -58 -2 0-{5} 238 -36 117 0-{1} 109 -199 32 0-{3} -54 221 -80 0-{4} 230 99 97 0-{8} 45 221 169 0-{9} 191 17 114 0-{0} -177 -138 -12 0-{3} 35 -5 145 0-{3} -102 -147 103 0-{5} -59 3 84 0-{7} -56 240 -130 0-{8} -233 -223 -47 0-{9} 169 216 -3 0-{4} -68 -182 67 0-{3} 34 -189 27 0-{7} 230 -222 66 0-{1} 19 123 84 0-{7} 64 35 231 0-{5} 236 165 242 0-{4} 77 -119 -61 0-{9} -179 215 198 0-{1} -105 -93 211 0-{4} -204 221 -112 0-{3} -244 23 -125 0-{1} -107 152 78 0-{1} 144 -183 28 0-{3} -179 -32 194 0-{2} 217 174 72 0-{5} -38 101 -132 0-{4} -122 193 108 0-{0} 12 3 -44 0-{6} 140 -23 -2 0-{0} 185 -129 145 0-{5} -116 -245 -102 0-{0} 203 -29 -131 0-{7} -172 239 243 0-{0} -186 -167 109 0-{9} 158 -184 149 0-{5} -53 56 100 0-{6} -92 5 35 0-{2} -212 -236 250 0-{4} -42 137 -193 0-{5} 171 231 127 0-{5} 176 -85 -122 0-{5} 32 81 -178 0-{9} 78 -14 -227 0-{7} 104 -10 -65 0-{5} 239 -81 -118 0-{1} 182 76 -235 0-{5} -226 -132 54 0-{8} 145 25 120 0-{0} 49 205 99 0-{7} 250 240 -89 0-{1} 17 37 -65 0-{9} 226 -66 -47 0-{6} 136 -112 19 0-{6} -94 -32 74 0-{1} 200 144 -65 0-{9} 27 29 207 0-{5} 6 112 53 0-{1} -170 -192 -65 0-{9} -18 206 8 0-{8} -158 245 147 0-{0} 222 34 24 0-{1} 69 182 -121 0-{9} -22 -202 -232 0-{0} -213 -82 173 0-{6} 78 -176 -151 0-{7} 245 215 242 0-{2} -126 -96 243 0-{6} -164 -220 205 0-{1} -60 128 162 0-{0} -237 -126 -20 0-{1} 105 -144 -165 0-{0} -158 76 -38 0-{3} 153 -236 206 0-{3} 187 -191 247 0-{5} -192 159 171 0-{7} 162 -151 -213 0-{8} 19 155 238 0-{4} -43 207 -46 0-{5} 117 250 118 0-{1} 159 40 -199 0-{6} 149 -163 -145 0-{8} 23 7 46 0-{9} 71 106 56 0-{0} -43 220 -118 0-{0} -200 242 6 0-{6} 143 219 -168 0-{7} -179 102 -163 0-{8} -74 183 -82 0-{1} 248 92 -154 0-{2} 81 202 229 0-{1} 92 243 19 0-{0} 165 -210 199 0-{3} -54 -8 244 0-{4} -70 -135 -223 0-{7} -80 -89 -189 0-{0} -7 182 -16 0-{9} 172 53 8 0-{0} 114 -107 197 0-{4} -135 -35 -239 0-{9} -214 -10 137 0-{7} 136 -131 151 0-{5} 15 -37 -89 0-{5} -234 -7 97 0-{1} 118 191 101 0-{2} 215 123 185 0-{2} -230 202 -190 0-{3} 211 -59 210 0-{5} 200 -162 116 0-{1} 158 12 212 0-{2} -56 229 196 0-{9} -50 -52 218 0-{4} 164 -142 -71 0-{3} 233 -140 159 0-{3} 119 93 65 0-{3} 155 -156 -57 0-{1} 117 -197 180 0-{1} -97 -100 -2 0-{3} 165 206 83 0-{6} -127 173 -110 0-{0} 20 158 116 0-{7} -205 -125 -209 0-{7} -244 -57 -246 0-{2} -139 -173 21 0-{9} 89 -150 149 0-{3} -51 60 -224 0-{4} -81 -193 195 0-{2} -208 -209 83 0-{9} -141 70 -223 0-{8} 200 -121 99 0-{6} -207 201 -61 0-{3} 167 157 -71 0-{7} 200 78 182 0-{2} 82 171 -183 0-{3} 4 -33 -85 0-{1} -103 87 186 0-{3} 41 183 169 0-{0} 84 244 -116 0-{3} 128 -108 -67 0-{9} 24 165 181 0-{6} 94 118 -148 0-{3} -41 -71 -98 0-{8} 248 15 -135 0-{3} 10 -157 -17 0-{4} -225 241 93 0-{4} 217 -192 227 0-{9} 28 -11 78 0-{5} -16 218 24 0-{7} 59 -91 -210 0-{8} 4 141 166 0-{3} -204 12 -206 0-{4} 187 153 -186 0-{1} 23 -43 -124 0-{8} 100 2 -46 0-{1} -236 -80 -102 0-{6} 165 129 159 0-{5} -45 245 -187 0-{6} 137 31 -7 0-{0} 214 -178 200 0-{4} 222 107 -74 0-{2} -37 -161 -129 0-{3} -202 -214 99 0-{0} 69 3 78 0-{0} -7 -217 51 0-{4} 215 -99 96 0-{5} 124 41 195 0-{6} -233 -223 206 0-{1} 233 197 87 0-{6} -102 33 70 0-{2} 175 241 162 0-{1} 86 -202 83 0-{8} 137 -214 64 0-{0} -111 -204 197 0-{8} -23 12 -121 0-{2} 101 28 -95 0-{8} -206 57 220 0-{2} -122 -2 -125 0-{6} 75 -241 86 0-{1} -72 185 77 0-{5} -125 210 -143 0-{6} 106 36 54 0-{0} 136 142 -93 0-{8} -142 -180 214 0-{4} 44 -22 -60 0-{0} -235 88 -130 0-{9} -124 -162 245 0-{2} 19 -121 156 0-{2} 84 -23 -191 0-{7} -173 -43 -163 0-{3} 151 148 213 0-{1} -239 147 -180 0-{4} -247 -92 -36 0-{9} 163 37 -188 0-{7} -245 -7 -231 0-{3} -32 -139 41 0-{9} -13 -157 211 0-{6} -107 136 126 0-{0} -58 201 -115 0-{2} -184 -48 -205 0-{7} 57 -237 -80 0-{9} 160 -243 155 0-{9} 154 -42 -179 0-{2} -107 -242 -167 0-{0} 169 170 -19 0-{3} -65 -140 -209 0-{1} 143 146 182 0-{1} 90 -170 158 0-{2} -235 54 83 0-{3} -122 193 239 0-{8} 112 130 -212 0-{8} -9 -167 93 0-{4} -57 54 -28 0-{2} -55 -56 29 0-{9} -206 -79 245 0-{5} -16 -81 -190 0-{5} 174 160 131 0-{4} -125 156 -148 0-{5} -128 174 -25 0-{8} -209 -16 60 0-{3} -13 -225 109 0-{4} 167 -124 168 0-{7} 142 -16 173 0-{3} 8 -45 216 0-{5} 13 160 -41 0-{6} -101 125 -225 0-{3} -218 244 -49 0-{3} 153 -183 204 0-{4} 117 230 167 0-{7} -108 24 -27 0-{7} 149 -198 13 0-{0} 48 124 -84 0-{6} -35 -162 58 0-{2} 110 -103 9 0-{9} -143 -43 169 0-{1} -91 -87 -70 0-{2} 11 -117 244 0-{6} -141 37 -177 0-{1} 238 126 -215 0-{3} 157 103 -27 0-{3} -133 134 -3 0-{1} 112 -107 -113 0-{3} -225 -104 26 0-{1} 109 -220 -174 0-{6} 58 -140 -86 0-{5} 1 97 14 0-{9} 249 161 -217 0-{9} 99 -242 33 0-{3} 172 2 -235 0-{7} -79 -132 107 0-{4} 43 -217 -169 0-{5} -166 218 -128 0-{8} 63 178 135 0-{6} 110 224 30 0-{5} -62 147 -237 0-{4} -241 -103 -169 0-{3} 125 -75 -106 0-{4} 146 20 -112 0-{2} 59 226 -136 0-{5} -194 132 -101 0-{9} 133 -41 -14 0-{1} 190 74 -247 0-{8} 230 221 224 0-{4} -3 -61 -65 0-{1} 93 15 194 0-{5} -155 105 117 0-{0} -146 -127 -35 0-{3} 170 -173 213 0-{8} -13 -234 -117 0-{6} -244 -225 15 0-{9} -41 151 -185 0-{6} -196 -2 114 0-{8} -220 111 -238 0-{2} 234 134 146 0-{3} 100 -29 -4 0-{9} -195 -6 151 0-{1} -116 109 -9 0-{7} 45 -58 -61 0-{4} 195 224 66 0-{3} 119 174 129 0-{2} 122 233 100 0-{0} 30 -227 -120 0-{1} 238 1 16 0-{9} 231 229 -46 0-{7} 188 226 23 0-{7} -181 247 -216 0-{9} 233 84 97 0-{4} 8 41 71 0-{2} 37 52 56 0-{0} -227 58 84 0-{6} 116 48 -95 0-{4} -58 233 36 0-{4} 210 11 -116 0-{8} -107 -103 242 0-{8} 21 -161 169 0-{3} 202 25 82 0-{9} 248 163 65 0-{7} -108 26 -78 0-{6} -162 163 -248 0-{2} -14 -95 92 0-{2} 218 -151 -26 0-{1} -132 -195 44 0-{4} 14 85 -136 0-{7} -236 219 -105 0-{8} 164 136 -25 0-{7} 7 36 124 0-{2} -163 -216 -15 0-{7} -66 176 -76 0-{8} -144 -3 -101 0-{6} -178 -149 -108 0-{6} 175 -161 210 0-{3} -118 106 -11 0-{8} -124 128 98 0-{1} -81 -223 117 0-{9} 154 149 -1 0-{1} -186 26 66 0-{4} -190 192 -114 0-{7} -122 -197 -52 0-{2} -84 -226 105 0-{4} 52 61 225 0-{4} 206 -7 -101 0-{2} -29 93 -116 0-{0} 67 -164 135 0-{8} 1 -217 -5 0-{0} -180 218 222 0-{1} 230 -225 -50 0-{0} 4 -25 45 0-{8} -57 234 -1 0-{5} -221 -103 100 0-{9} 137 234 -109 0-{8} 20 -227 -202 0-{3} -103 -247 198 0-{5} -29 -148 -35 0-{7} -191 102 18 0-{6} -52 -195 18 0-{6} 61 5 -247 0-{7} 165 -207 -217 0-{4} -147 -207 27 0-{5} 100 117 -129 0-{5} -152 -83 132 0-{0} -190 53 -121 0-{2} 156 230 181 0-{5} 2 -239 -65 0-{5} -55 -20 -107 0-{1} -119 -39 -221 0-{7} -116 147 16 0-{3} -211 238 -60 0-{7} 249 -111 141 0-{2} -54 -193 -81 0-{2} 49 -245 -5 0-{8} -233 110 -109 0-{6} -79 -56 180 0-{7} -41 196 150 0-{5} 242 -63 231 0-{8} 39 22 100 0-{1} 5 23 204 0-{2} -55 -100 105 0-{1} -22 -28 247 0-{1} -209 200 67 0-{7} -46 59 62 0-{5} -239 -107 -125 0-{5} 242 25 -246 0-{2} -148 -30 -11 0-{4} -148 160 -169 0-{7} 5 145 249 0-{9} 168 -28 -207 0-{5} -188 212 -201 0-{0} -166 205 -239 0-{3} 145 -246 -100 0-{3} 3 215 -93 0-{5} 101 -198 -160 0-{9} -233 178 -90 0-{0} -143 -26 -102 0-{0} -72 -97 -195 0-{1} -119 -163 -120 0-{2} 93 13 98 0-{2} -131 -53 15 0-{9} -118 129 151 0-{6} 168 81 199 0-{7} -17 121 -21 0-{5} -36 -175 196 0-{4} -221 57 68 0-{6} 111 145 -183 0-{3} 114 -31 24 0-{4} -170 159 -146 0-{7} 123 -80 152 0-{1} -84 -184 -134 0-{0} -206 30 -55 0-{8} 81 -154 198 0-{0} 129 135 248 0-{4} -2 198 122 0-{0} 230 101 -18 0-{4} 25 208 216 0-{1} -247 176 160 0-{2} 34 -159 9 0-{1} -74 184 31 0-{8} 29 -66 -148 0-{9} -233 204 -107 0-{9} 204 -30 -127 0-{8} -237 8 -65 0-{7} 79 112 181 0-{3} 157 -85 83 0-{1} 204 113 -216 0-{7} -11 -15 27 0-{3} 44 114 8 0-{5} 105 188 -158 0-{2} -51 204 -48 0-{7} 145 211 40 0-{4} -107 -31 -114 0-{2} -134 212 -105 0-{1} 188 -174 -151 0-{4} 58 -9 -151 0-{5} 33 -37 -119 0-{4} 172 -3 169 0-{7} -26 -21 48 0-{1} -94 -99 -41 0-{9} 192 1 -7 0-{6} 250 -138 185 0-{9} -6 -131 -83 0-{8} 11 191 -240 0-{2} -175 -163 -249 0-{1} -214 -98 193 0-{9} 120 190 -185 0-{4} -135 -64 -24 0-{8} -187 249 -129 0-{9} 76 -232 112 0-{3} -17 -161 117 0-{8} -6 250 246 0-{5} 85 -188 117 0-{7} -47 91 -103 0-{3} -123 -92 142 0-{1} 3 -183 -249 0-{2} -175 148 -129 0-{3} 223 172 119 0-{9} 194 76 -114 0-{3} 206 123 -222 0-{0} -186 -110 -71 0-{3} -63 152 -110 0-{5} -122 -44 -119 0-{3} -14 76 -224 0-{9} -8 -77 -97 0-{0} -116 110 63 0-{9} 148 106 192 0-{1} 204 -168 -56 0-{9} -221 173 -13 0-{4} 168 57 -211 0-{8} 218 151 245 0-{3} 70 -234 -143 0-{1} 24 194 106 0-{3} 16 -236 -187 0-{4} 162 97 43 0-{7} 8 79 228 0-{9} -39 -179 48 0-{0} -119 213 -231 0-{5} -239 57 -232 0-{0} -161 247 8 0-{4} 30 -127 197 0-{7} 72 168 -233 0-{5} -157 -217 -135 0-{0} 134 180 233 0-{9} 27 -14 -64 0-{9} 153 247 -60 0-{7} -154 -76 -106 0-{4} -59 -100 170 0-{6} 120 -121 -41 0-{6} -169 13 158 0-{9} -166 199 120 0-{4} 164 202 -199 0-{3} -223 148 -242 0-{4} 4 211 100 0-{3} 188 -231 -98 0-{7} 218 129 -93 0-{8} -211 18 -93 0-{2} 51 -10 -78 0-{1} 22 -155 -130 0-{7} 207 -135 -172 0-{7} 199 197 14 0-{9} 182 -245 -135 0-{1} -204 181 -32 0-{2} -18 -237 80 0-{4} -96 69 193 0-{1} -98 245 -91 0-{5} 71 -24 93 0-{9} 48 -131 194 0-{8} 29 144 -12 0-{6} 128 15 -71 0-{8} 125 58 -238 0-{7} -84 111 38 0-{9} 224 168 246 0-{7} -82 -188 -33 0-{0} -67 98 242 0-{8} 34 248 -112 0-{0} 217 95 59 0-{4} 56 245 13 0-{6} 72 129 -245 0-{2} 82 134 -61 0-{4} -128 55 -183 0-{0} -187 42 38 0-{0} 90 -102 54 0-{2} -159 224 229 0-{4} -117 -158 -180 0-{3} 113 108 5 0-{6} 239 34 -122 0-{5} -85 -118 -19 0-{9} -240 129 -145 0-{4} -15 149 129 0-{1} -144 -189 217 0-{3} 228 -223 97 0-{7} 16 -84 -242 0-{0} 206 -212 91 0-{9} -71 -194 21 0-{5} 59 -31 37 0-{6} -89 156 -243 0-{0} 60 21 75 0-{2} 14 12 -8 0-{5} -227 -183 131 0-{4} -95 -190 -49 0-{2} -151 -54 -133 0-{6} -134 49 -157 0-{4} 6 -114 224 0-{0} 201 -195 -17 0-{5} -99 -36 88 0-{7} 123 -67 105 0-{7} 142 -94 49 0-{8} 58 106 234 0-{3} 22 -18 -86 0-{2} 201 -245 71 0-{4} -220 -228 227 0-{8} -117 31 -212 0-{9} -177 -140 -59 0-{2} 229 233 150 0-{3} 47 -36 103 0-{4} -239 102 -241 0-{6} -35 194 208 0-{9} 199 -37 -180 0-{9} 140 -176 -123 0-{6} 148 -36 243 0-{2} 14 141 227 0-{1} -182 -141 248 0-{7} 178 85 144 0-{5} 247 231 15 0-{4} 77 -168 -40 0-{4} -194 -181 -83 0-{6} -225 116 -79 0-{4} -80 182 -50 0-{1} 63 -36 -122 0-{9} 82 231 -59 0-{3} -64 -244 157 0-{9} -86 140 -207 0-{5} -129 -192 -143 0-{9} -69 227 216 0-{6} -83 137 -101 0-{3} 117 -71 145 0-{4} 115 -53 199 0-{5} -32 96 -1 0-{9} 104 93 -142 0-{7} 190 116 83 0-{3} 191 -124 -161 0-{4} 144 11 -181 0-{0} -151 113 243 0-{3} -66 -141 -108 0-{1} -153 -149 7 0-{9} -75 -129 137 0-{1} 113 -107 43 0-{1} -191 99 237 0-{8} 199 67 163 0-{2} -198 -177 -21 0-{8} 217 -236 88 0-{2} -136 -84 158 0-{7} 52 68 -204 0-{7} -61 200 21 0-{4} 95 -204 -221 0-{0} -75 -125 118 0-{3} 213 113 173 0-{8} -226 -92 118 0-{3} -134 -189 67 0-{3} -198 7 -26 0-{4} -49 197 57 0-{1} -5 -72 -146 0-{0} 226 167 -27 0-{5} 211 -229 94 0-{6} -101 -80 -12 0-{6} 58 -47 -80 0-{5} 148 -217 -9 0-{8} 229 -120 -117 0-{3} 161 -174 191 0-{8} 10 -51 -154 0-{6} -155 235 -198 0-{4} -171 247 127 0-{9} -130 19 140 0-{0} -209 -185 -25 0-{2} -223 -199 -27 0-{3} -28 124 187 0-{3} 135 -28 31 0-{2} -31 88 89 0-{6} 22 -43 -47 0-{9} 21 165 -184 0-{5} -250 69 -27 0-{4} 221 -177 162 0-{3} -72 -218 207 0-{4} 23 -159 83 0-{3} -54 225 -190 0-{6} -140 -21 49 0-{4} -50 -177 -18 0-{8} 80 -250 172 0-{2} -77 183 -218 0-{5} 184 55 -146 0-{0} -104 181 -188 0-{2} 243 146 -70 0-{3} -215 -187 -247 0-{3} -196 -50 90 0-{0} -84 143 -146 0-{4} 147 119 -118 0-{0} 227 14 -110 0-{2} 44 238 -153 0-{6} 197 -69 -176 0-{4} 127 65 27 0-{4} 208 190 -162 0-{1} -39 250 -196 0-{5} 114 -89 206 0-{3} 142 75 -148 0-{0} -202 237 -194 0-{7} -21 216 -177 0-{8} 114 -80 -200 0-{4} -27 91 -84 0-{1} -63 249 -36 0-{0} 89 -18 -133 0-{4} -19 -17 -107 0-{8} 145 62 -227 0-{2} -89 -148 -44 0-{7} -133 -192 -149 0-{6} -65 240 -233 0-{4} -88 -40 -245 0-{1} 92 -129 4 0-{9} 22 -62 -21 0-{0} 216 116 -93 0-{0} 79 100 234 0-{2} 39 134 44 0-{1} -226 -170 -157 0-{1} 104 9 -191 0-{8} 26 -39 40 0-{8} 113 232 -174 0-{6} -101 81 -104 0-{7} 173 90 101 0-{0} -208 173 -97 0-{7} -72 209 -111 0-{2} -51 -93 108 0-{2} -248 216 181 0-{0} -65 -170 212 0-{7} -102 -161 146 0-{3} -72 -28 -25 0-{9} -117 -18 229 0-{7} -52 163 -79 0-{8} 94 120 79 0-{2} 105 116 -227 0-{4} 67 186 -211 0-{1} -226 -235 196 0-{8} -67 -11 23 0-{6} -55 -85 -197 0-{9} -200 -245 -76 0-{6} 109 -61 -127 0-{2} -248 127 -229 0-{5} 53 148 -197 0-{9} 151 -98 -24 0-{0} -58 180 -158 0-{0} 74 214 -200 0-{7} -31 241 172 0-{4} 26 219 -56 0-{3} 1 110 -18 0-{2} 156 19 -89 0-{9} 112 87 204 0-{2} -5 151 -59 0-{6} 34 -149 100 0-{4} 83 248 220 0-{6} 31 2 -78 0-{5} 110 -152 -37 0-{7} -132 -217 -57 0-{1} -71 176 79 0-{0} 31 -98 -75 0-{4} -60 229 -171 0-{0} 87 207 112 0-{1} 30 151 -41 0-{2} 17 162 109 0-{6} -172 111 -221 0-{7} 166 170 -147 0-{0} -48 143 -201 0-{6} 233 -46 -122 0-{2} 207 -149 -124 0-{3} -188 -166 -65 0-{3} -76 -77 -96 0-{0} -216 211 45 0-{4} 137 -103 -106 0-{8} 220 -82 -136 0-{3} 47 -84 -44 0-{1} -37 67 -32 0-{1} 33 -5 156 0-{0} -137 58 127 0-{0} 229 -36 -84 0-{5} 243 175 63 0-{5} 242 -73 -121 0-{0} 219 237 164 0-{0} 149 -201 -142 0-{0} 27 172 243 0-{9} -90 29 45 0-{5} 206 57 153 0-{9} -235 -49 -94 0-{8} 233 71 108 0-{9} 82 -122 223 0-{1} -195 -71 37 0-{0} -70 179 -159 0-{6} -79 -240 -38 0-{7} -79 -121 30 0-{3} -238 -78 -246 0-{6} 218 96 48 0-{8} 107 -154 -199 0-{8} 4 -205 194 0-{8} 1 -205 -203 0-{9} -155 129 -26 0-{0} -128 57 22 0-{9} -195 -168 -10 0-{1} 97 -186 -90 0-{8} 122 227 171 0-{6} 22 163 191 0-{7} -223 191 -85 0-{0} 100 -59 -63 0-{3} 245 49 -181 0-{7} -51 210 -135 0-{3} -34 55 54 0-{0} 2 74 -57 0-{5} 233 168 -230 0-{9} -40 22 230 0-{4} 128 -157 27 0-{8} -154 -161 -114 0-{0} -74 -136 38 0-{7} 51 -205 23 0-{8} -212 40 -71 0-{2} 9 -138 -83 0-{6} -95 54 121 0-{3} -174 -85 140 0-{0} 66 16 67 0-{8} -137 -8 105 0-{7} -133 -206 -3 0-{3} 175 86 -206 0-{6} -50 -217 51 0-{0} 51 244 31 0-{0} 184 -218 84 0-{1} -153 58 -237 0-{3} 56 -198 63 0-{9} 228 -42 74 0-{9} 43 -32 245 0-{3} -150 82 -44 0-{5} -14 -22 25 0-{7} 228 -232 -245 0-{5} -147 -221 29 0-{7} -222 41 -40 0-{7} 42 -13 -20 0-{4} 53 9 161 0-{6} 125 236 69 0-{7} -105 -172 32 0-{5} -142 114 -71 0-{2} -120 -122 -197 0-{4} -29 9 -200 0-{7} 26 210 -193 0-{5} -155 183 140 0-{9} 216 -208 -146 0-{0} -220 -8 98 0-{9} 109 175 -63 0-{8} -16 -139 -108 0-{4} 176 137 -119 0-{2} -97 39 142 0-{2} 218 -44 -37 0-{5} -119 -69 -107 0-{7} -79 142 109 0-{3} -123 25 227 0-{2} 177 -187 -89 0-{7} -99 -147 -207 0-{1} -68 81 236 0-{3} 145 90 3 0-{1} 93 -149 -127 0-{0} -120 -67 154 0-{0} 121 234 -229 0-{3} -245 186 21 0-{6} 92 5 -121 0-{9} 197 -100 -46 0-{8} -40 -39 -3 0-{9} 25 -117 -121 0-{2} -194 -189 175 0-{3} 246 10 40 0-{9} 13 50 147 0-{8} -243 163 105 0-{6} 132 -131 -218 0-{5} -241 78 101 0-{1} -200 -38 -29 0-{6} -36 -166 183 0-{8} 248 -216 218 0-{1} -203 92 204 0-{9} -83 -84 -165 0-{4} -202 -197 -244 0-{7} 112 -221 63 0-{9} 100 151 -1 0-{9} 141 -206 -52 0-{5} 181 -208 -229 0-{9} 53 93 173 0-{4} 193 -184 -79 0-{2} 41 -78 -133 0-{2} 1 -35 -90 0-{8} -198 -60 174 0-{1} 152 207 -157 0-{8} 183 -196 -163 0-{8} -244 242 218 0-{8} 11 32 146 0-{7} -66 -32 -84 0-{1} -54 -109 -195 0-{3} 190 -116 144 0-{2} -242 -122 86 0-{3} -71 7 -150 0-{2} 241 -173 -15 0-{7} 62 -217 81 0-{2} 205 -116 130 0-{7} 193 -209 128 0-{8} 146 -240 -132 0-{9} 29 197 161 0-{9} 15 83 -39 0-{8} -109 -44 81 0-{5} 244 85 -7 0-{9} -246 9 165 0-{1} 115 -83 67 0-{1} -98 -141 170 0-{4} -102 94 -52 0-{5} -231 -74 -28 0-{4} 162 191 -149 0-{9} 197 -183 -35 0-{4} 102 -56 50 0-{7} 30 -45 -129 0-{0} 25 -207 -33 0-{1} 192 -106 -169 0-{0} 43 -129 -169 0-{8} 237 244 182 0-{4} -72 -44 -168 0-{5} -158 -150 102 0-{9} 168 -143 151 0-{5} -72 26 212 0-{5} 116 -89 98 0-{9} 171 -197 156 0-{4} 233 -54 -181 0-{5} 129 -161 25 0-{3} 113 69 -33 0-{9} 179 -175 224 0-{3} 138 -143 -46 0-{6} 75 213 -246 0-{1} -137 -175 -150 0-{3} -169 -67 215 0-{1} 86 69 -199 0-{3} -159 233 63 0-{5} -145 101 6 0-{5} 129 -243 -227 0-{7} -175 72 -247 0-{7} 163 -109 207 0-{4} 31 77 33 0-{4} -136 175 160 0-{7} -192 -193 -7 0-{7} 99 145 232 0-{9} -233 198 114 0-{1} 240 -89 -108 0-{2} -81 -67 -63 0-{7} 5 149 69 0-{1} -172 166 -184 0-{2} 158 -244 -166 0-{1} -53 -172 -62 0-{9} 49 25 61 0-{5} 237 19 -166 0-{7} 94 202 -148 0-{9} -246 13 152 0-{3} -135 -86 -5 0-{6} -190 -44 -223 0-{9} -17 -141 6 0-{2} 165 39 237 0-{6} 221 -62 -104 0-{5} -206 107 -223 0-{9} -159 -243 -13 0-{8} 118 -9 57 0
− samples/gcnf/uuf50-01.gcnf
@@ -1,226 +0,0 @@-c This Formular is generated by mcnf-c-c horn? no -c forced? no -c mixed sat? no -c clause length = 3 -c-p gcnf 50 218 10-{1} 18 -8 29 0-{1} -16 3 18 0-{1} -36 -11 -30 0-{1} -50 20 32 0-{1} -6 9 35 0-{1} 42 -38 29 0-{1} 43 -15 10 0-{1} -48 -47 1 0-{1} -45 -16 33 0-{1} 38 42 22 0-{1} -49 41 -34 0-{1} 12 17 35 0-{2} 22 -49 7 0-{2} -10 -11 -39 0-{2} -28 -36 -37 0-{2} -13 -46 -41 0-{2} 21 -4 9 0-{2} 12 48 10 0-{2} 24 23 15 0-{2} -8 -41 -43 0-{2} -44 -2 -35 0-{2} -27 18 31 0-{2} 47 35 6 0-{3} -11 -27 41 0-{3} -33 -47 -45 0-{3} -16 36 -37 0-{3} 27 -46 2 0-{3} 15 -28 10 0-{3} -38 46 -39 0-{3} -33 -4 24 0-{3} -12 -45 50 0-{3} -32 -21 -15 0-{3} 8 42 24 0-{4} 30 -49 4 0-{4} 45 -9 28 0-{4} -33 -47 -1 0-{4} 1 27 -16 0-{4} -11 -17 -35 0-{4} -42 -15 45 0-{4} -19 -27 30 0-{4} 3 28 12 0-{4} 48 -11 -33 0-{4} -6 37 -9 0-{5} -37 13 -7 0-{5} -2 26 16 0-{5} 46 -24 -38 0-{5} -13 -24 -8 0-{5} -36 -42 -21 0-{5} -37 -19 3 0-{5} -31 -50 35 0-{5} -7 -26 29 0-{5} -42 -45 29 0-{5} 33 25 -6 0-{6} -45 -5 7 0-{6} -7 28 -6 0-{6} -48 31 -11 0-{6} 32 16 -37 0-{6} -24 48 1 0-{6} 18 -46 23 0-{6} -30 -50 48 0-{6} -21 39 -2 0-{6} 24 47 42 0-{6} -36 30 4 0-{7} -5 28 -1 0-{7} -47 32 -42 0-{7} 16 37 -22 0-{7} -43 42 -34 0-{7} -40 39 -20 0-{7} -49 29 6 0-{7} -41 -3 39 0-{7} -16 -12 43 0-{7} 24 22 3 0-{7} 47 -45 43 0-{8} 45 -37 46 0-{8} -9 26 5 0-{8} -3 23 -13 0-{8} 5 -34 13 0-{8} 12 39 13 0-{8} 22 50 37 0-{8} 19 9 46 0-{8} -24 8 -27 0-{8} -28 7 21 0-{8} 8 -25 50 0-{9} 20 50 4 0-{9} 27 36 13 0-{9} 26 31 -25 0-{9} 39 -44 -32 0-{9} -20 41 -10 0-{9} 49 -28 35 0-{9} 1 44 34 0-{9} 39 35 -11 0-{9} -50 -42 -7 0-{9} -24 7 47 0-{10} -13 5 -48 0-{10} -9 -20 -23 0-{10} 2 17 -19 0-{10} 11 23 21 0-{10} -45 30 15 0-{10} 11 26 -24 0-{10} 38 33 -13 0-{10} 44 -27 -7 0-{10} 41 49 2 0-{10} -18 12 -37 0-{10} -2 12 -26 0-{10} -19 7 32 0-{10} -22 11 33 0-{10} 8 12 -20 0-{10} 16 40 -48 0-{10} -2 -24 -11 0-{10} 26 -17 37 0-{10} -14 -19 46 0-{10} 5 47 36 0-{10} -29 -9 19 0-{10} 32 4 28 0-{10} -34 20 -46 0-{10} -4 -36 -13 0-{10} -15 -37 45 0-{10} -21 29 23 0-{10} -6 -40 7 0-{10} -42 31 -29 0-{10} -36 24 31 0-{10} -45 -37 -1 0-{10} 3 -6 -29 0-{10} -28 -50 27 0-{10} 44 26 5 0-{10} -17 -48 49 0-{10} 12 -40 -7 0-{10} -12 31 -48 0-{10} 27 32 -42 0-{10} -27 -10 1 0-{10} 6 -49 10 0-{10} -24 8 43 0-{10} 23 31 1 0-{10} 11 -47 38 0-{10} -28 26 -13 0-{10} -40 12 -42 0-{10} -3 39 46 0-{10} 17 41 46 0-{10} 23 21 13 0-{10} -14 -1 -38 0-{10} 20 18 6 0-{10} -50 20 -9 0-{10} 10 -32 -18 0-{10} -21 49 -34 0-{10} 44 23 -35 0-{10} 40 -19 34 0-{10} -1 6 -12 0-{10} 6 -2 -7 0-{10} 32 -20 34 0-{10} -12 43 -29 0-{10} 24 2 -49 0-{10} 10 -4 40 0-{10} 11 5 12 0-{10} -3 47 -31 0-{10} 43 -23 21 0-{10} -41 -36 -50 0-{10} -8 -42 -24 0-{10} 39 45 7 0-{10} 7 37 -45 0-{10} 41 40 8 0-{10} -50 -10 -8 0-{10} -5 -39 -14 0-{10} -22 -24 -43 0-{10} -36 40 35 0-{10} 17 49 41 0-{10} -32 7 24 0-{10} -30 -8 -9 0-{10} -41 -13 -10 0-{10} 31 26 -33 0-{10} 17 -22 -39 0-{10} -21 28 3 0-{10} -14 46 23 0-{10} 29 16 19 0-{10} 42 -32 -44 0-{10} -24 10 23 0-{10} -1 -32 -21 0-{10} -8 -44 -39 0-{10} 39 11 9 0-{10} 19 14 -46 0-{10} 46 44 -42 0-{10} 37 23 -29 0-{10} 32 25 20 0-{10} 14 -43 -12 0-{10} -36 -18 46 0-{10} 14 -26 -10 0-{10} -2 -30 5 0-{10} 6 -18 46 0-{10} -26 2 -44 0-{10} 20 -8 -11 0-{10} -31 3 16 0-{10} -22 -9 39 0-{10} -49 44 -42 0-{10} -45 -44 31 0-{10} -31 50 -11 0-{10} -32 -46 2 0-{10} -6 -7 17 0-{10} 19 -32 48 0-{10} 39 20 -10 0-{10} -22 -37 38 0-{10} -31 9 -48 0-{10} 40 12 7 0-{10} -24 -4 9 0-{10} -22 49 33 0-{10} -12 43 10 0-{10} 25 -30 -10 0-{10} 46 47 31 0-{10} 13 27 -7 0-{10} -45 32 -35 0-{10} -50 34 9 0-{10} 2 34 30 0-{10} 3 16 2 0-{10} -18 45 -12 0-{10} 33 37 10 0-{10} 43 7 -18 0-{10} -22 44 -19 0-{10} -31 -27 -42 0-{10} -3 -40 8 0-{10} -23 -31 38 0
− samples/gcnf/uuf50-01b.gcnf
@@ -1,226 +0,0 @@-c This Formular is generated by mcnf-c-c horn? no -c forced? no -c mixed sat? no -c clause length = 3 -c-p gcnf 50 218 9-{5} 18 -8 29 0-{2} -16 3 18 0-{3} -36 -11 -30 0-{7} -50 20 32 0-{5} -6 9 35 0-{8} 42 -38 29 0-{2} 43 -15 10 0-{0} -48 -47 1 0-{4} -45 -16 33 0-{0} 38 42 22 0-{3} -49 41 -34 0-{9} 12 17 35 0-{1} 22 -49 7 0-{9} -10 -11 -39 0-{6} -28 -36 -37 0-{3} -13 -46 -41 0-{4} 21 -4 9 0-{5} 12 48 10 0-{3} 24 23 15 0-{0} -8 -41 -43 0-{3} -44 -2 -35 0-{4} -27 18 31 0-{5} 47 35 6 0-{3} -11 -27 41 0-{8} -33 -47 -45 0-{3} -16 36 -37 0-{3} 27 -46 2 0-{2} 15 -28 10 0-{4} -38 46 -39 0-{1} -33 -4 24 0-{8} -12 -45 50 0-{7} -32 -21 -15 0-{2} 8 42 24 0-{4} 30 -49 4 0-{0} 45 -9 28 0-{7} -33 -47 -1 0-{0} 1 27 -16 0-{3} -11 -17 -35 0-{3} -42 -15 45 0-{8} -19 -27 30 0-{4} 3 28 12 0-{0} 48 -11 -33 0-{9} -6 37 -9 0-{7} -37 13 -7 0-{8} -2 26 16 0-{0} 46 -24 -38 0-{8} -13 -24 -8 0-{1} -36 -42 -21 0-{1} -37 -19 3 0-{9} -31 -50 35 0-{5} -7 -26 29 0-{9} -42 -45 29 0-{7} 33 25 -6 0-{1} -45 -5 7 0-{2} -7 28 -6 0-{5} -48 31 -11 0-{3} 32 16 -37 0-{8} -24 48 1 0-{9} 18 -46 23 0-{4} -30 -50 48 0-{4} -21 39 -2 0-{3} 24 47 42 0-{6} -36 30 4 0-{6} -5 28 -1 0-{2} -47 32 -42 0-{1} 16 37 -22 0-{9} -43 42 -34 0-{6} -40 39 -20 0-{1} -49 29 6 0-{8} -41 -3 39 0-{3} -16 -12 43 0-{9} 24 22 3 0-{0} 47 -45 43 0-{1} 45 -37 46 0-{1} -9 26 5 0-{5} -3 23 -13 0-{4} 5 -34 13 0-{6} 12 39 13 0-{8} 22 50 37 0-{2} 19 9 46 0-{3} -24 8 -27 0-{5} -28 7 21 0-{8} 8 -25 50 0-{0} 20 50 4 0-{0} 27 36 13 0-{4} 26 31 -25 0-{1} 39 -44 -32 0-{9} -20 41 -10 0-{2} 49 -28 35 0-{2} 1 44 34 0-{4} 39 35 -11 0-{4} -50 -42 -7 0-{9} -24 7 47 0-{9} -13 5 -48 0-{8} -9 -20 -23 0-{1} 2 17 -19 0-{4} 11 23 21 0-{6} -45 30 15 0-{7} 11 26 -24 0-{2} 38 33 -13 0-{1} 44 -27 -7 0-{7} 41 49 2 0-{8} -18 12 -37 0-{1} -2 12 -26 0-{0} -19 7 32 0-{8} -22 11 33 0-{2} 8 12 -20 0-{8} 16 40 -48 0-{6} -2 -24 -11 0-{2} 26 -17 37 0-{9} -14 -19 46 0-{9} 5 47 36 0-{3} -29 -9 19 0-{2} 32 4 28 0-{4} -34 20 -46 0-{6} -4 -36 -13 0-{8} -15 -37 45 0-{8} -21 29 23 0-{5} -6 -40 7 0-{4} -42 31 -29 0-{5} -36 24 31 0-{2} -45 -37 -1 0-{3} 3 -6 -29 0-{4} -28 -50 27 0-{2} 44 26 5 0-{3} -17 -48 49 0-{5} 12 -40 -7 0-{1} -12 31 -48 0-{5} 27 32 -42 0-{5} -27 -10 1 0-{5} 6 -49 10 0-{7} -24 8 43 0-{7} 23 31 1 0-{3} 11 -47 38 0-{4} -28 26 -13 0-{1} -40 12 -42 0-{2} -3 39 46 0-{8} 17 41 46 0-{7} 23 21 13 0-{1} -14 -1 -38 0-{7} 20 18 6 0-{8} -50 20 -9 0-{5} 10 -32 -18 0-{8} -21 49 -34 0-{3} 44 23 -35 0-{8} 40 -19 34 0-{3} -1 6 -12 0-{1} 6 -2 -7 0-{7} 32 -20 34 0-{5} -12 43 -29 0-{8} 24 2 -49 0-{5} 10 -4 40 0-{3} 11 5 12 0-{7} -3 47 -31 0-{4} 43 -23 21 0-{3} -41 -36 -50 0-{1} -8 -42 -24 0-{3} 39 45 7 0-{4} 7 37 -45 0-{8} 41 40 8 0-{0} -50 -10 -8 0-{2} -5 -39 -14 0-{0} -22 -24 -43 0-{2} -36 40 35 0-{9} 17 49 41 0-{6} -32 7 24 0-{3} -30 -8 -9 0-{6} -41 -13 -10 0-{6} 31 26 -33 0-{1} 17 -22 -39 0-{2} -21 28 3 0-{7} -14 46 23 0-{6} 29 16 19 0-{0} 42 -32 -44 0-{4} -24 10 23 0-{3} -1 -32 -21 0-{1} -8 -44 -39 0-{6} 39 11 9 0-{1} 19 14 -46 0-{8} 46 44 -42 0-{9} 37 23 -29 0-{8} 32 25 20 0-{9} 14 -43 -12 0-{5} -36 -18 46 0-{1} 14 -26 -10 0-{3} -2 -30 5 0-{4} 6 -18 46 0-{8} -26 2 -44 0-{9} 20 -8 -11 0-{0} -31 3 16 0-{3} -22 -9 39 0-{3} -49 44 -42 0-{5} -45 -44 31 0-{7} -31 50 -11 0-{8} -32 -46 2 0-{9} -6 -7 17 0-{4} 19 -32 48 0-{3} 39 20 -10 0-{7} -22 -37 38 0-{1} -31 9 -48 0-{7} 40 12 7 0-{5} -24 -4 9 0-{4} -22 49 33 0-{9} -12 43 10 0-{1} 25 -30 -10 0-{4} 46 47 31 0-{3} 13 27 -7 0-{1} -45 32 -35 0-{1} -50 34 9 0-{3} 2 34 30 0-{2} 3 16 2 0-{5} -18 45 -12 0-{4} 33 37 10 0-{0} 43 7 -18 0-{6} -22 44 -19 0-{0} -31 -27 -42 0-{5} -3 -40 8 0-{0} -23 -31 38 0
− samples/gcnf/uuf50-01c.gcnf
@@ -1,226 +0,0 @@-c This Formular is generated by mcnf-c-c horn? no -c forced? no -c mixed sat? no -c clause length = 3 -c-p gcnf 50 218 20-{1} 18 -8 29 0-{12} -16 3 18 0-{13} -36 -11 -30 0-{13} -50 20 32 0-{1} -6 9 35 0-{10} 42 -38 29 0-{7} 43 -15 10 0-{6} -48 -47 1 0-{15} -45 -16 33 0-{6} 38 42 22 0-{9} -49 41 -34 0-{18} 12 17 35 0-{15} 22 -49 7 0-{5} -10 -11 -39 0-{20} -28 -36 -37 0-{0} -13 -46 -41 0-{20} 21 -4 9 0-{12} 12 48 10 0-{8} 24 23 15 0-{18} -8 -41 -43 0-{3} -44 -2 -35 0-{9} -27 18 31 0-{20} 47 35 6 0-{8} -11 -27 41 0-{16} -33 -47 -45 0-{4} -16 36 -37 0-{13} 27 -46 2 0-{4} 15 -28 10 0-{7} -38 46 -39 0-{2} -33 -4 24 0-{16} -12 -45 50 0-{14} -32 -21 -15 0-{7} 8 42 24 0-{17} 30 -49 4 0-{5} 45 -9 28 0-{6} -33 -47 -1 0-{14} 1 27 -16 0-{13} -11 -17 -35 0-{3} -42 -15 45 0-{6} -19 -27 30 0-{11} 3 28 12 0-{13} 48 -11 -33 0-{15} -6 37 -9 0-{8} -37 13 -7 0-{17} -2 26 16 0-{5} 46 -24 -38 0-{8} -13 -24 -8 0-{8} -36 -42 -21 0-{11} -37 -19 3 0-{5} -31 -50 35 0-{13} -7 -26 29 0-{15} -42 -45 29 0-{20} 33 25 -6 0-{6} -45 -5 7 0-{3} -7 28 -6 0-{8} -48 31 -11 0-{6} 32 16 -37 0-{4} -24 48 1 0-{9} 18 -46 23 0-{0} -30 -50 48 0-{3} -21 39 -2 0-{9} 24 47 42 0-{15} -36 30 4 0-{20} -5 28 -1 0-{20} -47 32 -42 0-{4} 16 37 -22 0-{5} -43 42 -34 0-{20} -40 39 -20 0-{14} -49 29 6 0-{16} -41 -3 39 0-{12} -16 -12 43 0-{13} 24 22 3 0-{12} 47 -45 43 0-{10} 45 -37 46 0-{5} -9 26 5 0-{0} -3 23 -13 0-{10} 5 -34 13 0-{4} 12 39 13 0-{9} 22 50 37 0-{0} 19 9 46 0-{17} -24 8 -27 0-{4} -28 7 21 0-{18} 8 -25 50 0-{17} 20 50 4 0-{5} 27 36 13 0-{10} 26 31 -25 0-{2} 39 -44 -32 0-{15} -20 41 -10 0-{13} 49 -28 35 0-{18} 1 44 34 0-{0} 39 35 -11 0-{4} -50 -42 -7 0-{16} -24 7 47 0-{18} -13 5 -48 0-{2} -9 -20 -23 0-{9} 2 17 -19 0-{14} 11 23 21 0-{17} -45 30 15 0-{20} 11 26 -24 0-{3} 38 33 -13 0-{5} 44 -27 -7 0-{20} 41 49 2 0-{15} -18 12 -37 0-{15} -2 12 -26 0-{14} -19 7 32 0-{12} -22 11 33 0-{19} 8 12 -20 0-{0} 16 40 -48 0-{6} -2 -24 -11 0-{6} 26 -17 37 0-{12} -14 -19 46 0-{2} 5 47 36 0-{8} -29 -9 19 0-{4} 32 4 28 0-{11} -34 20 -46 0-{4} -4 -36 -13 0-{19} -15 -37 45 0-{6} -21 29 23 0-{15} -6 -40 7 0-{1} -42 31 -29 0-{14} -36 24 31 0-{9} -45 -37 -1 0-{8} 3 -6 -29 0-{0} -28 -50 27 0-{4} 44 26 5 0-{9} -17 -48 49 0-{12} 12 -40 -7 0-{11} -12 31 -48 0-{3} 27 32 -42 0-{20} -27 -10 1 0-{17} 6 -49 10 0-{14} -24 8 43 0-{10} 23 31 1 0-{12} 11 -47 38 0-{20} -28 26 -13 0-{11} -40 12 -42 0-{3} -3 39 46 0-{17} 17 41 46 0-{10} 23 21 13 0-{17} -14 -1 -38 0-{16} 20 18 6 0-{6} -50 20 -9 0-{17} 10 -32 -18 0-{7} -21 49 -34 0-{17} 44 23 -35 0-{0} 40 -19 34 0-{11} -1 6 -12 0-{17} 6 -2 -7 0-{5} 32 -20 34 0-{9} -12 43 -29 0-{10} 24 2 -49 0-{18} 10 -4 40 0-{9} 11 5 12 0-{10} -3 47 -31 0-{2} 43 -23 21 0-{19} -41 -36 -50 0-{1} -8 -42 -24 0-{9} 39 45 7 0-{17} 7 37 -45 0-{20} 41 40 8 0-{18} -50 -10 -8 0-{2} -5 -39 -14 0-{17} -22 -24 -43 0-{17} -36 40 35 0-{4} 17 49 41 0-{5} -32 7 24 0-{15} -30 -8 -9 0-{0} -41 -13 -10 0-{17} 31 26 -33 0-{0} 17 -22 -39 0-{12} -21 28 3 0-{20} -14 46 23 0-{18} 29 16 19 0-{17} 42 -32 -44 0-{14} -24 10 23 0-{15} -1 -32 -21 0-{2} -8 -44 -39 0-{7} 39 11 9 0-{19} 19 14 -46 0-{9} 46 44 -42 0-{9} 37 23 -29 0-{11} 32 25 20 0-{7} 14 -43 -12 0-{0} -36 -18 46 0-{4} 14 -26 -10 0-{13} -2 -30 5 0-{17} 6 -18 46 0-{2} -26 2 -44 0-{6} 20 -8 -11 0-{8} -31 3 16 0-{19} -22 -9 39 0-{3} -49 44 -42 0-{2} -45 -44 31 0-{6} -31 50 -11 0-{11} -32 -46 2 0-{8} -6 -7 17 0-{6} 19 -32 48 0-{8} 39 20 -10 0-{11} -22 -37 38 0-{3} -31 9 -48 0-{1} 40 12 7 0-{15} -24 -4 9 0-{1} -22 49 33 0-{12} -12 43 10 0-{12} 25 -30 -10 0-{2} 46 47 31 0-{0} 13 27 -7 0-{19} -45 32 -35 0-{20} -50 34 9 0-{0} 2 34 30 0-{19} 3 16 2 0-{16} -18 45 -12 0-{16} 33 37 10 0-{13} 43 7 -18 0-{2} -22 44 -19 0-{19} -31 -27 -42 0-{18} -3 -40 8 0-{11} -23 -31 38 0
+ samples/maxsat/MML10.wcnf view
@@ -0,0 +1,8 @@+c from http://sat.inesc-id.pt/~ruben/talks/sat10-talk.pdf+p wcnf 3 6 15+15 1 2 -3 0+15 -2 3 0+15 -1 3 0+5 -3 0+3 1 2 0+2 1 3 0
+ samples/maxsat/file_rwpms_wcnf_L2_V150_C1000_H150_0.wcnf view
@@ -0,0 +1,1003 @@+c Weighted CNF+c from Selman's wff generator+p wcnf 150 1000 5278+5278 123 -121 0+5278 66 -130 0+5278 94 88 0+5278 -150 94 0+5278 77 138 0+5278 -32 -77 0+5278 29 -135 0+5278 -149 -3 0+5278 31 51 0+5278 -81 8 0+5278 78 115 0+5278 -61 -57 0+5278 44 113 0+5278 39 103 0+5278 88 -71 0+5278 74 -126 0+5278 -27 -91 0+5278 -99 68 0+5278 33 -142 0+5278 -48 -145 0+5278 107 -83 0+5278 35 -56 0+5278 126 98 0+5278 74 -114 0+5278 55 118 0+5278 35 31 0+5278 23 75 0+5278 69 89 0+5278 21 27 0+5278 83 84 0+5278 -31 -85 0+5278 48 -111 0+5278 -78 -110 0+5278 140 132 0+5278 -56 -39 0+5278 -128 -93 0+5278 120 20 0+5278 -103 -80 0+5278 -15 68 0+5278 28 -141 0+5278 101 -117 0+5278 -98 96 0+5278 -134 -35 0+5278 -128 -126 0+5278 -146 -13 0+5278 -93 -110 0+5278 27 19 0+5278 10 -31 0+5278 148 -76 0+5278 -21 3 0+5278 -37 75 0+5278 -50 75 0+5278 -88 110 0+5278 -70 -74 0+5278 -92 -4 0+5278 34 8 0+5278 -83 -110 0+5278 -113 -74 0+5278 148 75 0+5278 -150 -124 0+5278 -84 85 0+5278 -9 -102 0+5278 105 -97 0+5278 105 110 0+5278 -70 145 0+5278 69 100 0+5278 -24 43 0+5278 -16 -57 0+5278 -141 -75 0+5278 -26 -49 0+5278 -146 -149 0+5278 -109 138 0+5278 133 129 0+5278 -78 -90 0+5278 -133 -81 0+5278 -137 -82 0+5278 -7 48 0+5278 97 -76 0+5278 74 131 0+5278 118 -29 0+5278 7 -119 0+5278 59 119 0+5278 50 9 0+5278 91 -136 0+5278 -33 -141 0+5278 66 -141 0+5278 121 -112 0+5278 141 -81 0+5278 -49 -41 0+5278 -9 117 0+5278 -125 37 0+5278 22 109 0+5278 100 139 0+5278 129 -104 0+5278 66 26 0+5278 106 77 0+5278 -117 -134 0+5278 100 110 0+5278 -147 129 0+5278 87 149 0+5278 138 -106 0+5278 60 -55 0+5278 81 104 0+5278 31 -83 0+5278 -67 3 0+5278 -113 -7 0+5278 -135 79 0+5278 -77 49 0+5278 5 8 0+5278 63 -97 0+5278 50 -69 0+5278 -2 69 0+5278 -71 51 0+5278 -58 25 0+5278 -103 119 0+5278 -18 70 0+5278 -77 -125 0+5278 -71 -124 0+5278 43 9 0+5278 -78 -129 0+5278 29 -46 0+5278 -70 24 0+5278 143 91 0+5278 10 -146 0+5278 120 118 0+5278 92 -56 0+5278 65 -62 0+5278 -41 139 0+5278 34 -22 0+5278 -46 133 0+5278 74 -27 0+5278 22 -81 0+5278 48 -95 0+5278 -150 43 0+5278 105 -150 0+5278 138 46 0+5278 -68 -69 0+5278 51 -99 0+5278 125 -51 0+5278 -131 77 0+5278 21 19 0+5278 -62 140 0+5278 -140 10 0+5278 -73 -149 0+5278 123 68 0+5278 69 -17 0+5278 -74 -43 0+5278 30 128 0+5278 -145 -41 0+5278 -125 -126 0+6 136 102 0+8 100 105 0+2 -22 -91 0+3 107 39 0+8 82 -9 0+1 136 -51 0+2 -92 120 0+8 96 -90 0+10 -41 -32 0+4 136 37 0+4 -128 -56 0+10 -95 7 0+4 -15 -145 0+7 -46 -147 0+2 117 96 0+2 -35 -85 0+5 116 -130 0+4 -17 -129 0+4 -35 -56 0+10 62 -44 0+10 -39 -142 0+5 139 -56 0+8 1 125 0+10 -59 8 0+4 -138 27 0+8 -5 84 0+1 139 78 0+8 -121 23 0+10 -14 52 0+4 -107 -15 0+5 -140 123 0+6 130 -104 0+1 -130 -48 0+6 131 -119 0+9 46 41 0+8 63 -146 0+7 -47 121 0+10 -135 -35 0+6 7 -105 0+7 -58 94 0+3 141 -74 0+9 -42 -45 0+6 -85 -111 0+6 107 131 0+6 101 -2 0+7 37 118 0+8 72 -81 0+1 24 132 0+1 -55 -39 0+1 83 77 0+10 38 -138 0+1 -118 89 0+5 91 -3 0+7 120 62 0+10 143 48 0+9 30 -37 0+4 75 17 0+1 94 -64 0+7 -52 40 0+3 -129 122 0+4 125 -91 0+2 -3 -65 0+9 113 -6 0+4 -42 -43 0+7 -59 106 0+7 -20 149 0+2 -38 108 0+4 -79 29 0+6 -119 -130 0+7 -45 132 0+10 -138 127 0+8 -19 -75 0+6 -31 119 0+5 -118 62 0+4 20 -63 0+1 91 105 0+2 85 -148 0+2 -130 -145 0+1 -121 -135 0+2 59 -142 0+2 -111 -146 0+1 -58 -112 0+3 25 -103 0+7 58 -26 0+7 -24 54 0+2 -48 106 0+6 91 -117 0+1 -108 74 0+2 -70 -79 0+3 41 78 0+4 31 -79 0+6 -104 -54 0+4 -108 50 0+2 6 -101 0+9 -67 30 0+1 -104 34 0+8 -112 88 0+1 15 53 0+4 -131 -97 0+3 150 -62 0+7 -112 -43 0+4 144 135 0+1 -15 -8 0+3 -41 27 0+9 114 -139 0+4 41 71 0+4 -17 5 0+10 -67 17 0+5 -59 86 0+4 -70 -58 0+2 65 -46 0+7 -73 41 0+4 30 112 0+4 -33 38 0+4 42 -45 0+1 -61 -39 0+6 125 131 0+10 -38 -133 0+1 29 -30 0+7 -70 -16 0+2 127 2 0+4 39 -109 0+3 3 124 0+5 12 -25 0+5 5 54 0+1 -37 8 0+5 37 -52 0+3 67 2 0+1 3 74 0+9 -32 111 0+5 -84 -10 0+8 -34 131 0+2 -34 111 0+5 -119 74 0+10 -125 150 0+1 -2 17 0+9 90 -136 0+3 96 17 0+10 -26 103 0+4 -83 -56 0+7 16 -26 0+2 -99 20 0+10 -20 101 0+1 117 47 0+6 33 -70 0+4 86 -32 0+2 134 132 0+1 37 115 0+4 141 -69 0+2 88 -26 0+8 -126 -124 0+5 -20 2 0+6 72 25 0+10 -57 38 0+10 -20 138 0+1 -103 -139 0+1 57 -145 0+5 -20 -41 0+3 -15 80 0+1 -82 85 0+3 110 117 0+8 4 129 0+9 -116 13 0+5 1 37 0+2 32 41 0+9 81 -5 0+5 -84 133 0+1 67 66 0+2 33 28 0+5 6 -98 0+4 110 -138 0+8 25 48 0+6 -88 70 0+4 -74 3 0+9 136 94 0+2 -10 40 0+8 -67 120 0+1 67 137 0+2 -125 -81 0+1 129 5 0+3 -75 -13 0+9 16 49 0+6 142 28 0+8 67 -132 0+9 101 120 0+5 106 -98 0+9 -29 31 0+9 35 -135 0+9 -147 7 0+2 56 112 0+10 140 65 0+2 46 -91 0+9 60 94 0+8 -42 59 0+7 -90 -24 0+1 -8 149 0+6 6 40 0+1 -2 -28 0+2 93 -6 0+7 -96 85 0+6 29 150 0+5 -59 -115 0+5 -139 -66 0+2 65 55 0+8 -95 -17 0+4 -44 -87 0+3 -92 132 0+6 67 -110 0+4 110 62 0+5 26 5 0+6 70 -139 0+6 44 -12 0+3 -28 33 0+1 120 20 0+4 -2 32 0+2 142 -140 0+6 -52 -28 0+3 -32 -137 0+10 -126 103 0+5 114 -139 0+4 22 -92 0+9 112 -121 0+6 3 -150 0+3 -140 45 0+7 -73 -66 0+2 52 60 0+3 12 -142 0+3 -131 55 0+3 -146 -30 0+4 1 44 0+10 -43 102 0+9 147 92 0+9 7 41 0+5 -100 -80 0+10 -72 133 0+7 38 54 0+8 -84 -44 0+3 -87 -61 0+2 12 83 0+2 -25 85 0+7 -126 -101 0+8 30 -27 0+8 10 125 0+10 -29 -54 0+9 98 70 0+1 131 -133 0+1 66 -26 0+4 -111 -77 0+3 28 62 0+10 88 -50 0+8 -24 10 0+7 64 73 0+9 143 -61 0+4 -43 -60 0+9 86 115 0+5 -42 19 0+5 -81 146 0+1 -46 134 0+7 -144 109 0+8 32 136 0+5 -46 -114 0+7 24 -112 0+6 76 -94 0+3 113 139 0+1 134 13 0+5 -146 -26 0+10 134 70 0+8 55 -114 0+7 77 -36 0+1 148 86 0+10 29 -64 0+4 53 78 0+8 90 -94 0+7 120 -14 0+3 -83 -119 0+7 -83 8 0+8 -43 128 0+3 -64 -17 0+10 -81 -4 0+10 82 117 0+3 -61 85 0+8 -99 29 0+7 148 -100 0+1 108 -89 0+1 -47 41 0+5 -4 91 0+6 -24 -128 0+5 148 -109 0+6 64 -79 0+3 -61 62 0+3 -81 20 0+10 -109 118 0+9 9 121 0+8 62 -64 0+3 41 107 0+9 -66 -124 0+3 53 -1 0+3 -62 -12 0+7 32 -92 0+10 -60 3 0+3 -123 63 0+6 -127 98 0+3 55 -43 0+1 -16 26 0+3 27 -20 0+5 -32 6 0+7 98 110 0+10 112 -46 0+7 -109 -4 0+7 -102 87 0+10 -129 -8 0+9 33 74 0+4 -94 -95 0+6 101 77 0+10 37 -89 0+4 -135 -129 0+10 132 -52 0+5 -138 -130 0+9 -137 64 0+5 -138 -26 0+7 120 75 0+1 -1 93 0+5 31 22 0+5 -150 -118 0+8 19 137 0+8 -117 -3 0+4 -67 86 0+1 -111 -51 0+10 126 -39 0+10 132 118 0+10 139 -49 0+3 -17 137 0+6 124 -34 0+2 37 -16 0+4 101 17 0+8 -68 141 0+6 30 142 0+1 110 -32 0+7 -81 -51 0+2 -37 55 0+7 -89 -24 0+7 -39 -143 0+1 10 -86 0+1 -77 -43 0+2 -35 -137 0+10 -19 -140 0+4 41 -27 0+2 -82 27 0+5 -50 -37 0+3 -30 75 0+7 -11 -129 0+2 21 83 0+4 70 -10 0+1 150 139 0+6 -15 -83 0+2 -109 53 0+9 -90 -112 0+10 37 24 0+2 -2 122 0+9 -55 -27 0+9 36 124 0+1 113 -99 0+2 32 -42 0+5 -94 39 0+2 1 95 0+5 -119 -9 0+2 -130 68 0+7 94 -69 0+5 43 70 0+9 -19 90 0+9 131 55 0+2 -94 -39 0+5 -134 -110 0+10 118 -64 0+2 -131 65 0+7 134 140 0+10 60 -68 0+6 -8 -14 0+8 69 18 0+5 -56 20 0+8 -130 -85 0+5 148 -62 0+6 127 -28 0+1 -17 -106 0+5 24 18 0+2 32 -131 0+2 -148 81 0+4 -101 -65 0+1 149 -82 0+4 -144 -73 0+3 -100 -28 0+9 133 66 0+4 84 -46 0+4 26 56 0+4 -137 -25 0+5 90 -19 0+8 -100 -45 0+5 117 60 0+2 87 143 0+3 59 -75 0+4 -120 -112 0+1 17 21 0+4 -46 -96 0+8 115 107 0+1 1 -8 0+5 68 70 0+5 62 -67 0+1 -142 -149 0+1 -110 -68 0+3 -89 -126 0+5 -72 69 0+8 -25 42 0+7 -50 -107 0+10 -26 -28 0+9 95 -44 0+2 43 18 0+1 -86 4 0+1 130 108 0+5 -26 128 0+1 -19 38 0+4 144 70 0+7 -97 6 0+10 -50 -11 0+8 -29 -24 0+10 -28 72 0+3 29 147 0+3 -124 -146 0+8 33 31 0+8 100 95 0+5 -100 -149 0+10 -10 64 0+1 88 -34 0+5 -105 -140 0+3 136 -30 0+8 -25 143 0+6 -23 -11 0+8 105 127 0+3 126 -106 0+6 20 -143 0+8 26 -24 0+5 -14 -42 0+10 -72 -2 0+6 145 58 0+1 -68 87 0+10 -63 8 0+4 114 -129 0+2 -122 -46 0+10 -70 -12 0+5 -54 -92 0+7 94 -39 0+10 -96 74 0+9 10 94 0+4 -102 112 0+10 90 134 0+6 30 -139 0+4 150 37 0+2 129 115 0+8 3 -98 0+1 -21 115 0+9 -58 146 0+2 107 63 0+1 -47 -124 0+9 112 -17 0+7 53 59 0+3 -24 42 0+7 -139 113 0+3 77 -84 0+1 -80 141 0+10 -53 -69 0+8 42 41 0+8 -57 -52 0+4 -110 -130 0+8 22 94 0+4 56 -132 0+5 -66 -58 0+7 49 -111 0+8 29 114 0+7 5 75 0+6 127 -39 0+2 19 11 0+3 104 78 0+6 -59 -69 0+1 -127 109 0+7 -69 -1 0+5 115 -26 0+6 101 -92 0+10 131 -51 0+7 62 81 0+4 9 87 0+1 5 -16 0+6 124 12 0+6 -12 -131 0+1 -6 -8 0+5 99 -126 0+2 -26 -44 0+4 -125 -115 0+1 52 126 0+5 142 -92 0+5 104 -43 0+1 -24 147 0+2 -4 -36 0+2 11 17 0+4 -61 109 0+10 74 -75 0+5 51 69 0+9 11 -70 0+7 -113 -14 0+3 10 20 0+5 -56 150 0+3 -16 -146 0+4 -104 76 0+8 1 129 0+8 -48 34 0+4 103 100 0+4 113 -99 0+3 -119 66 0+10 -66 -99 0+4 95 43 0+9 -118 -75 0+3 -77 -20 0+4 113 52 0+5 72 128 0+8 -28 -148 0+5 133 -13 0+9 102 -90 0+10 -97 73 0+9 147 81 0+9 100 4 0+4 -55 -95 0+3 -72 -2 0+9 149 -137 0+6 149 -52 0+4 -141 -87 0+3 10 56 0+6 -136 -11 0+9 -15 112 0+1 57 -124 0+2 -126 -44 0+1 -31 121 0+6 -22 17 0+4 -103 -74 0+5 -130 -100 0+3 110 -48 0+2 10 50 0+9 24 -91 0+6 -135 121 0+4 92 -77 0+8 -93 24 0+9 98 -74 0+3 24 -127 0+1 -24 94 0+3 -143 2 0+7 92 -142 0+9 -112 136 0+7 63 135 0+5 9 -141 0+9 65 -60 0+5 36 77 0+4 -20 29 0+3 30 -40 0+8 31 -42 0+3 28 -138 0+9 -122 -62 0+2 -53 -147 0+6 56 -120 0+4 47 128 0+10 -6 92 0+7 132 105 0+6 147 54 0+1 -42 51 0+2 -113 60 0+10 -56 -81 0+6 50 -39 0+4 16 53 0+1 145 -89 0+5 -44 64 0+10 118 144 0+5 45 29 0+3 88 -16 0+9 -96 -5 0+7 -44 9 0+3 -61 104 0+1 42 -137 0+4 -51 21 0+2 14 41 0+8 69 49 0+9 -65 87 0+1 92 -106 0+3 114 98 0+3 -51 -123 0+3 110 112 0+10 132 -4 0+6 44 -54 0+2 -103 118 0+1 54 -118 0+1 -73 33 0+5 130 23 0+1 -145 -140 0+8 -101 -150 0+1 -3 141 0+2 45 -129 0+9 97 126 0+10 -94 41 0+8 73 125 0+3 -147 -112 0+1 -101 54 0+2 -54 60 0+2 -51 -59 0+5 -38 -110 0+4 -86 106 0+10 146 130 0+2 -105 -97 0+7 -58 52 0+1 105 40 0+5 100 -43 0+8 -102 -16 0+9 -126 37 0+4 -143 -109 0+8 89 135 0+2 -81 -25 0+6 -76 88 0+1 128 -57 0+2 -100 103 0+1 119 -21 0+2 58 15 0+2 124 95 0+2 -79 93 0+7 -118 100 0+3 37 145 0+9 -52 113 0+7 65 17 0+5 -38 -94 0+7 -109 -133 0+7 -77 32 0+3 125 -98 0+9 -48 -13 0+7 -7 58 0+4 20 -39 0+1 -55 -112 0+2 55 95 0+8 -77 31 0+1 63 88 0+3 -36 -24 0+4 36 112 0+1 -20 116 0+7 -4 10 0+2 122 91 0+10 35 -37 0+10 -68 -135 0+10 73 -122 0+1 146 145 0+6 107 -59 0+10 24 25 0+2 -35 139 0+6 79 -87 0+1 124 72 0+4 56 -37 0+7 -9 38 0+8 32 -128 0+7 -36 108 0+5 -132 129 0+5 117 24 0+1 110 -54 0+2 -126 81 0+2 117 -144 0+3 -31 96 0+1 73 -12 0+8 120 -14 0+7 -143 -104 0+1 127 -138 0+9 41 11 0+4 92 143 0+1 137 56 0+2 -2 11 0+7 23 -130 0+2 -144 -49 0+8 -2 -59 0+8 47 -98 0+1 -109 85 0+8 -77 150 0+7 -56 140 0+2 -1 10 0+3 140 -12 0+7 -60 107 0+3 16 64 0+9 -12 -105 0+8 39 -102 0+7 101 127 0+6 117 -108 0+5 -118 -43 0+3 -54 -4 0+1 111 -58 0+10 122 -64 0+4 -19 36 0+2 138 -122 0+1 -99 51 0+6 9 -8 0+2 -50 -22 0+9 26 -21 0+3 -79 91 0+3 5 149 0+8 -35 135 0+6 -107 103 0+4 -4 55 0+9 -62 -2 0+3 23 69 0+5 90 132 0+7 73 -145 0+1 -143 101 0+6 85 30 0+4 -133 -9 0+8 -63 -65 0+7 -66 -135 0+7 -53 -1 0+4 133 19 0+9 -13 78 0+6 29 -82 0+2 111 -82 0+5 -91 100 0+1 -14 -75 0+6 59 -64 0+7 -64 3 0+1 -22 114 0+6 42 82 0+10 13 -72 0+3 4 -37 0+6 -136 -144 0+6 -69 -76 0+5 -139 97 0+4 -100 -44 0+8 7 49 0+7 -131 -44 0+1 -115 -2 0+4 38 33 0+10 27 -10 0+10 85 102 0+6 -49 -12 0+5 -55 73 0+6 -121 -124 0+6 -17 -79 0+10 -81 -61 0+10 -93 -11 0+4 20 -14 0+6 116 137 0+6 149 3 0+7 -76 133 0+5 -106 -76 0+1 -5 -91 0+8 1 -54 0+9 65 -44 0+2 57 128 0+4 114 -67 0+6 69 -50 0+2 33 -130 0+9 -55 36 0+6 -127 -66 0+4 120 46 0+5 -89 -135 0+2 112 -7 0+8 73 -55 0+8 -105 -53 0+10 -32 -24 0+5 -60 86 0+9 2 -138 0+3 34 -86 0+4 -70 122 0+8 -129 135 0+9 39 -144 0+8 -46 -27 0+3 51 -106 0+5 -42 9 0+8 147 10 0+2 96 18 0+8 140 -117 0+3 101 -2 0+8 -145 62 0+5 -88 -114 0+7 -70 -131 0+9 139 -94 0+3 104 17 0+6 34 14 0+10 -131 -109 0+6 111 -11 0+1 -72 55 0+1 -19 -113 0+5 93 -95 0+7 39 -52 0+5 68 -79 0+9 -93 105 0+8 63 117 0+3 -127 75 0+7 129 -124 0+8 -87 55 0+7 -150 133 0+5 34 -25 0+1 104 72 0+1 -26 -30 0+3 -146 -123 0+9 48 90 0+9 64 -79 0+5 133 -108 0+4 91 -139 0+6 -14 -51 0+7 123 -130 0+1 -9 132 0+8 -104 47 0+4 137 148 0+6 76 51 0+5 9 -79 0+2 68 -62 0+8 113 -148 0+10 -127 -61 0+2 -42 -18 0+4 -65 116 0+1 -113 24 0+3 -75 -2 0+8 81 -138 0+7 -50 104 0+7 -101 -127 0+7 38 -29 0+5 -47 -53 0+9 18 -72 0+3 96 113 0+2 -115 116 0+5 104 135 0+8 88 121 0+2 -98 -112 0+6 140 30 0+10 -83 -141 0+1 -62 9 0+4 122 -100 0+5 -65 132 0+4 116 22 0+9 -143 -36 0+1 -147 -59 0+5 89 142 0+7 -132 19 0+4 27 -51 0+10 -150 80 0+1 -61 64 0+6 -86 -105 0+7 141 -22 0+10 -81 96 0+8 87 146 0+10 -15 10 0+10 61 13 0+10 -92 124 0+8 37 -59 0+7 14 108 0+6 -130 70 0
− samples/wbo/example-lin.wbo
@@ -1,6 +0,0 @@-* #variable= 5 #constraint= 4 #soft= 4 mincost= 2 maxcost= 5 sumcost= 14-soft: 15 ;-[2] 1 x1 +4 x2 -2 x5 >= 2;-[3] -1 x1 +4 x2 -2 x5 >= +3;-[4] 12345678901234567890 x4 +4 x3 >= 10;-[5] 2 x2 +3 x4 +2 x1 +3 x5 = 5;
+ src/Algebra/Lattice/Boolean.hs view
@@ -0,0 +1,66 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algebra.Lattice.Boolean+-- Copyright : (c) Masahiro Sakai 2012-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Type classes for lattices and boolean algebras.+-- +-----------------------------------------------------------------------------+module Algebra.Lattice.Boolean+ (+ -- * Boolean algebra+ Complement (..)+ , Boolean (..)+ , true+ , false+ , (.&&.)+ , (.||.)+ , andB+ , orB+ ) where++import Algebra.Lattice++infixr 3 .&&.+infixr 2 .||.+infix 1 .=>., .<=>.++-- | types that can be negated.+class Complement a where+ notB :: a -> a++-- | types that can be combined with boolean operations.+class (BoundedLattice a, Complement a) => Boolean a where+ (.=>.), (.<=>.) :: a -> a -> a+ x .=>. y = notB x .||. y+ x .<=>. y = (x .=>. y) .&&. (y .=>. x)++-- | alias of 'top'+true :: Boolean a => a+true = top++-- | alias of 'bottom'+false :: Boolean a => a+false = bottom++-- | alias of 'meet'+(.&&.) :: Boolean a => a -> a -> a+(.&&.) = meet++-- | alias of 'join'+(.||.) :: Boolean a => a -> a -> a+(.||.) = join++-- | alias of 'meets'+andB :: Boolean a => [a] -> a+andB = meets++-- | alias of 'joins'+orB :: Boolean a => [a] -> a+orB = joins
src/Algorithm/BoundsInference.hs view
@@ -21,13 +21,13 @@ import Control.Monad import qualified Data.IntMap as IM import qualified Data.IntSet as IS+import Data.VectorSpace -import Data.Expr import Data.ArithRel-import Data.Linear import Data.Interval import Data.LA (BoundsEnv) import qualified Data.LA as LA+import Data.Var import Util (isInteger) type C r = (RelOp, LA.Expr r)@@ -44,11 +44,11 @@ cs :: VarMap [C r] cs = IM.fromListWith (++) $ do Rel lhs op rhs <- constraints- let m = LA.coeffMap (lhs .-. rhs)+ 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)+ rhs' = (-1/c) *^ LA.fromCoeffMap (IM.delete v m) return (v, [(op', rhs')]) loop :: Int -> LA.BoundsEnv r -> LA.BoundsEnv r@@ -70,16 +70,40 @@ f b cs i = foldr intersection i $ do (op, rhs) <- cs let i' = LA.computeInterval b rhs- lb = lowerBound i'- ub = upperBound i'+ lb = lowerBound' i'+ ub = upperBound' i' case op of Eql -> return i'- Le -> return $ interval Nothing ub- Ge -> return $ interval lb Nothing- Lt -> return $ interval Nothing (strict ub)- Gt -> return $ interval (strict lb) Nothing+ 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 -> EndPoint r-strict Nothing = Nothing-strict (Just (_,val)) = Just (False,val)+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
src/Algorithm/CAD.hs view
@@ -63,7 +63,7 @@ import Data.ArithRel import qualified Data.AlgebraicNumber as AReal-import Data.Formula (DNF (..))+import Data.DNF import Data.Polynomial import Debug.Trace@@ -409,9 +409,10 @@ solve :: forall v. (Ord v, Show v, RenderVar v)- => [(Rel (Polynomial Rational v))]+ => Set.Set v+ -> [(Rel (Polynomial Rational v))] -> Maybe (Model v)-solve cs0 = solve' (map f cs0)+solve vs cs0 = solve' vs (map f cs0) where f (Rel lhs op rhs) = (lhs - rhs, g op) g Le = [Zero, Neg]@@ -423,12 +424,11 @@ solve' :: forall v. (Ord v, Show v, RenderVar v)- => [(Polynomial Rational v, [Sign])]+ => Set.Set v+ -> [(Polynomial Rational v, [Sign])] -> Maybe (Model v)-solve' cs0 = go vs0 cs0+solve' vs0 cs0 = go (Set.toList vs0) cs0 where- vs0 = Set.toList $ Set.unions [variables p | (p,_) <- cs0]- go :: [v] -> [(Polynomial Rational v, [Sign])] -> Maybe (Model v) go [] cs = if and [signOfConst v `elem` ss | (p,ss) <- cs, let v = eval (\_ -> undefined) p]@@ -504,14 +504,15 @@ [(conf, _)] = runM $ buildSignConf ps test1b :: Bool-test1b = isJust $ solve cs+test1b = isJust $ solve vs cs where x = var ()+ vs = Set.singleton () cs = [x + 1 .>. 0, -2*x + 3 .>. 0, x .>. 0] test1c :: Bool test1c = isJust $ do- m <- solve' cs+ m <- solve' (Set.singleton ()) cs guard $ and $ do (p, ss) <- cs let val = eval (m Map.!) (mapCoeff fromRational p)@@ -529,9 +530,10 @@ [(conf, _)] = runM $ buildSignConf ps test2b :: Bool-test2b = isNothing $ solve cs+test2b = isNothing $ solve vs cs where x = var ()+ vs = Set.singleton () cs = [x^(2::Int) .<. 0] test = and [test1b, test1c, test2b]@@ -564,11 +566,12 @@ p :: Polynomial Rational Int p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1 -test_solve = solve [p .<. 0]+test_solve = solve vs [p .<. 0] where a = var 0 b = var 1 c = var 2+ vs = Set.fromList [0,1,2] p :: Polynomial Rational Int p = a^(2::Int) + b^(2::Int) + c^(2::Int) - 1
src/Algorithm/ContiTraverso.hs view
@@ -35,22 +35,22 @@ import Data.List import Data.Monoid import Data.Ratio+import Data.VectorSpace import Data.ArithRel-import Data.Linear import qualified Data.LA as LA-import Data.Expr (Var, VarSet, Variables (..), Model) import Data.OptDir import Data.Polynomial import Data.Polynomial.GBase+import Data.Var import qualified Algorithm.LPUtil as LPUtil -solve :: MonomialOrder Var -> OptDir -> LA.Expr Rational -> [LA.Atom Rational] -> Maybe (Model Integer)-solve cmp dir obj cs = do- m <- solve' cmp obj3 cs3+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 lnegate obj, cs)+ ((obj2,cs2), mt) = LPUtil.toStandardForm (if dir == OptMin then obj else negateV obj, cs) obj3 = LA.mapCoeff g obj2 where g = round . (c*)@@ -61,8 +61,8 @@ g = round . (c*) c = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms lhs] -solve' :: MonomialOrder Var -> LA.Expr Integer -> [(LA.Expr Integer, Integer)] -> Maybe (Model Integer)-solve' cmp obj cs+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'@@ -72,9 +72,6 @@ where vs :: [Var] vs = IS.toList vs'-- vs' :: VarSet- vs' = vars $ obj : [lhs | (lhs,_) <- cs] v2 :: Var v2 = if IS.null vs' then 0 else IS.findMax vs' + 1
src/Algorithm/Cooper.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Algorithm.Cooper@@ -29,416 +28,23 @@ ExprZ , Lit (..) , QFFormula (..)+ , fromLAAtom , (.|.)- , Model -- * Projection , project , projectCases- , projectCases' , projectCasesN -- * Quantifier elimination , eliminateQuantifiers -- * Constraint solving- , solveFormula+ , solve , solveQFFormula- , solveConj+ , solveFormula , 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.Ratio--import Data.ArithRel-import Data.Expr-import Data.Formula-import Data.Linear-import qualified Data.LA as LA-import qualified Algorithm.FourierMotzkin as FM---- ------------------------------------------------------------------------------- | Linear arithmetic expression over integers.-type ExprZ = LA.Expr Integer--atomZ :: RelOp -> Expr Rational -> Expr Rational -> Maybe QFFormula-atomZ op a b = do- (e1,c1) <- FM.termR a- (e2,c2) <- FM.termR b- let a' = c2 .*. e1- b' = c1 .*. e2- case op of- Le -> return $ Lit $ a' `leZ` b'- Lt -> return $ Lit $ a' `ltZ` b'- Ge -> return $ Lit $ a' `geZ` b'- Gt -> return $ Lit $ a' `gtZ` b'- Eql -> return $ eqZ a' b'- NEq -> liftM notB (atomZ Eql a b)--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 Lattice QFFormula where- top = T'- bottom = F'- meet = And'- join = Or'--instance Boolean QFFormula--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) (e .-. LA.constant 1) .+. LA.constant 1- where- d = if null cs then 1 else abs $ foldl1' gcd cs- cs = [c | (c,x) <- LA.terms e, 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---- -----------------------------------------------------------------------------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-project x formula = simplify $ orB [phi | (phi,_) <- projectCases' x formula, phi /= F']--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') -> [lnegate 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)---- ------------------------------------------------------------------------------- | eliminate quantifiers and returns equivalent quantifier-free formula.-eliminateQuantifiers :: Formula (Atom Rational) -> Maybe QFFormula-eliminateQuantifiers = f- where- f T = return T'- f F = return F'- f (Atom (Rel e1 op e2)) = atomZ op e1 e2- f (And a b) = liftM2 (.&&.) (f a) (f b)- f (Or a b) = liftM2 (.||.) (f a) (f b)- f (Not a) = f (pushNot a)- f (Imply a b) = f $ Or (Not a) b- f (Equiv a b) = f $ And (Imply a b) (Imply b a)- f (Forall x body) = liftM notB $ f $ Exists x $ Not body- f (Exists x body) = liftM (project x) (f body)---- -----------------------------------------------------------------------------solveFormula :: Formula (Atom Rational) -> SatResult Integer-solveFormula formula =- case eliminateQuantifiers formula of- Nothing -> Unknown- Just formula' ->- case solveQFFormula formula' of- Nothing -> Unsat- Just m -> Sat m--solveQFFormula :: QFFormula -> Maybe (Model Integer)-solveQFFormula formula = listToMaybe $ do- (formula2, mt) <- projectCasesN (vars formula) formula- case formula2 of- T' -> return $ mt IM.empty- _ -> mzero---- | solve a (open) quantifier-free formula-solveConj :: [LA.Atom Rational] -> Maybe (Model Integer)-solveConj cs = solveQFFormula formula- where- formula = andB [rel op (f (lhs .-. rhs)) (LA.constant 0) | Rel lhs op rhs <- cs]- f e = LA.mapCoeff (round . (s*)) e- where- s = fromInteger $ foldl' lcm 1 [denominator c | (c,_) <- LA.terms e]---- | solve a (open) quantifier-free formula-solveQFLA :: [LA.Atom Rational] -> VarSet -> Maybe (Model Rational)-solveQFLA cs ivs = listToMaybe $ do- (cs2, mt) <- FM.projectN rvs cs- m <- maybeToList $ solveConj cs2- return $ mt $ IM.map fromInteger m- where- rvs = vars cs `IS.difference` ivs---- -----------------------------------------------------------------------------testHagiya :: QFFormula-testHagiya = 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<x ∧ 3|x-⇔-(2y-z > 0 ∧ 3|z+1) ∨ (2y-z > -2 ∧ 3|z+2) ∨ (2y-z > -3 ∧ 3|z+3)--}--test3 :: QFFormula-test3 = 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<y ∧ y < x+2 ∧ 2|y-⇔-(2x < 2 ∧ 0 < x) ∨ (0 < 2x+2 ∧ x < 0)--}---- ---------------------------------------------------------------------------+import Algorithm.Cooper.Core+import Algorithm.Cooper.FOL
+ src/Algorithm/Cooper/Core.hs view
@@ -0,0 +1,449 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algorithm.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:+-- +-- * <http://hagi.is.s.u-tokyo.ac.jp/pub/staff/hagiya/kougiroku/ronri/5.txt>+-- +-- * <http://www.cs.cmu.edu/~emc/spring06/home1_files/Presburger%20Arithmetic.ppt>+-- +-- See also:+--+-- * <http://hackage.haskell.org/package/presburger>+--+-----------------------------------------------------------------------------+module Algorithm.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 Algebra.Lattice+import Algebra.Lattice.Boolean++import Data.ArithRel+import qualified Data.LA as LA+import Data.Var+import qualified Algorithm.FourierMotzkin as FM+import qualified Algorithm.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 JoinSemiLattice QFFormula where+ join = Or'++instance MeetSemiLattice QFFormula where+ meet = And'++instance Lattice QFFormula++instance BoundedJoinSemiLattice QFFormula where+ bottom = F'++instance BoundedMeetSemiLattice QFFormula where+ top = T'++instance BoundedLattice QFFormula++instance Boolean QFFormula++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<x ∧ 3|x+⇔+(2y-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<y ∧ y < x+2 ∧ 2|y+⇔+(2x < 2 ∧ 0 < x) ∨ (0 < 2x+2 ∧ x < 0)+-}++-- ---------------------------------------------------------------------------
+ src/Algorithm/Cooper/FOL.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algorithm.Cooper.FOL+-- Copyright : (c) Masahiro Sakai 2011-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+-- +-----------------------------------------------------------------------------+module Algorithm.Cooper.FOL+ ( eliminateQuantifiers+ , solveFormula+ ) where++import Control.Monad++import Algebra.Lattice.Boolean++import Data.ArithRel+import qualified Data.FOL.Arith as FOL+import qualified Data.LA.FOL as LAFOL+import Data.Var++import Algorithm.Cooper.Core++-- | eliminate quantifiers and returns equivalent quantifier-free formula.+eliminateQuantifiers :: FOL.Formula (FOL.Atom Rational) -> 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
src/Algorithm/FourierMotzkin.hs view
@@ -1,14 +1,13 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} ----------------------------------------------------------------------------- -- | -- Module : Algorithm.FourierMotzkin--- Copyright : (c) Masahiro Sakai 2011+-- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (MultiParamTypeClasses, FunctionalDependencies)+-- Portability : portable -- -- Naïve implementation of Fourier-Motzkin Variable Elimination -- @@ -22,263 +21,9 @@ , project , projectN , eliminateQuantifiers+ , solveFormula , solve- , solveConj-- -- Functions for internal use in OmegaTest- , termR- , Rat- , constraintsToDNF ) 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.ArithRel-import Data.Expr-import Data.Formula-import Data.Linear-import qualified Data.LA as LA-import qualified Data.Interval as Interval---- -----------------------------------------------------------------------------type ExprZ = LA.Expr Integer---- | (t,c) represents t/c, and c must be >0.-type Rat = (ExprZ, Integer)--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 (lnegate t)- notB (Nonneg t) = Pos (lnegate t)---- 制約集合の単純化--- 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]---- -----------------------------------------------------------------------------atomR :: RelOp -> Expr Rational -> Expr Rational -> Maybe (DNF Lit)-atomR op a b = do- a' <- termR a- b' <- termR b- return $ atomR' op a' b'--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]]--termR :: Expr Rational -> Maybe Rat-termR (Const c) = return (LA.constant (numerator c), denominator c)-termR (Var v) = return (LA.var v, 1)-termR (a :+: b) = do- (t1,c1) <- termR a- (t2,c2) <- termR b- return (c2 .*. t1 .+. c1 .*. t2, c1*c2)-termR (a :*: b) = do- (t1,c1) <- termR a- (t2,c2) <- termR b- msum [ do{ c <- LA.asConst t1; return (c .*. t2, c1*c2) }- , do{ c <- LA.asConst t2; return (c .*. t1, c1*c2) }- ]-termR (a :/: b) = do- (t1,c1) <- termR a- (t2,c2) <- termR b- c3 <- LA.asConst t2- guard $ c3 /= 0- return (c2 .*. t1, c1*c3)--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--normalizeExprR :: ExprZ -> ExprZ-normalizeExprR e = LA.mapCoeff (`div` d) e- where d = abs $ gcd' $ map fst $ LA.terms e--litToLAAtom :: Lit -> LA.Atom Rational-litToLAAtom (Nonneg e) = LA.mapCoeff fromInteger e .>=. LA.constant 0-litToLAAtom (Pos e) = LA.mapCoeff fromInteger e .>. LA.constant 0---- -----------------------------------------------------------------------------{--(ls1,ls2,us1,us2) represents-{ x | ∀(M,c)∈ls1. M/c≤x, ∀(M,c)∈ls2. M/c<x, ∀(M,c)∈us1. x≤M/c, ∀(M,c)∈us2. x<M/c }--}-type BoundsR = ([Rat], [Rat], [Rat], [Rat])--project :: Var -> [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)]-project v xs = do- ys <- unDNF $ constraintsToDNF xs- (zs, mt) <- project' v ys- return (map litToLAAtom zs, mt)--project' :: Var -> [Lit] -> [([Lit], Model Rational -> Model Rational)]-project' v xs = do- case collectBounds v xs of- (bnd, rest) -> do- cond <- unDNF $ boundConditions bnd- let mt m =- case Interval.pickup (evalBounds m bnd) of- Nothing -> error "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) <- projectN' vs ys- return (map litToLAAtom zs, mt)--projectN' :: VarSet -> [Lit] -> [([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, (lnegate t', c) : ls2, us1, us2), xs) -- 0 < cx + M ⇔ -M/c < x- else (((lnegate 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--boundConditions :: BoundsR -> DNF Lit-boundConditions (ls1, ls2, us1, us2) = DNF $ maybeToList $ 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 ]--eliminateQuantifiers :: Formula (Atom Rational) -> Maybe (DNF Lit)-eliminateQuantifiers = f- where- f T = return true- f F = return false- f (Atom (Rel a op b)) = atomR op a b- f (And a b) = liftM2 (.&&.) (f a) (f b)- f (Or a b) = liftM2 (.||.) (f a) (f b)- f (Not a) = f (pushNot a)- f (Imply a b) = f (Or (Not a) b)- f (Equiv a b) = f (And (Imply a b) (Imply b a))- f (Forall v a) = do- dnf <- f (Exists v (pushNot a))- return (notB dnf)- f (Exists v a) = do- dnf <- f a- return $ orB [DNF $ map fst $ project' v xs | xs <- unDNF dnf]--solve :: Formula (Atom Rational) -> SatResult Rational-solve formula =- case eliminateQuantifiers formula of- Nothing -> Unknown- Just dnf ->- case msum [solve' vs xs | xs <- unDNF dnf] of- Nothing -> Unsat- Just m -> Sat m- where- vs = IS.toList (vars formula)--solveConj :: [LA.Atom Rational] -> Maybe (Model Rational)-solveConj cs = msum [solve' vs cs2 | cs2 <- unDNF (constraintsToDNF cs)]- where- vs = IS.toList (vars cs)--solve' :: [Var] -> [Lit] -> Maybe (Model Rational)-solve' vs xs = listToMaybe $ do- (ys,mt) <- projectN' (IS.fromList vs) =<< maybeToList (simplify xs)- guard $ Just [] == simplify ys- return $ mt IM.empty--evalBounds :: Model Rational -> BoundsR -> Interval.Interval Rational-evalBounds model (ls1,ls2,us1,us2) =- foldl' Interval.intersection Interval.univ $ - [ Interval.interval (Just (True, evalRat model x)) Nothing | x <- ls1 ] ++- [ Interval.interval (Just (False, evalRat model x)) Nothing | x <- ls2 ] ++- [ Interval.interval Nothing (Just (True, evalRat model x)) | x <- us1 ] ++- [ Interval.interval Nothing (Just (False, evalRat model x)) | x <- us2 ]---- -----------------------------------------------------------------------------constraintsToDNF :: [LA.Atom Rational] -> DNF Lit-constraintsToDNF = andB . map constraintToDNF--constraintToDNF :: LA.Atom Rational -> DNF Lit-constraintToDNF (Rel lhs op rhs) = DNF $- case op of- Eql -> [[Nonneg lhs', Nonneg (lnegate lhs')]]- NEq -> [[Pos lhs'], [Pos (lnegate lhs')]]- Ge -> [[Nonneg lhs']]- Le -> [[Nonneg (lnegate lhs')]]- Gt -> [[Pos lhs']]- Lt -> [[Pos (lnegate lhs')]]- where- lhs' = normalize (lhs .-. rhs)-- normalize :: LA.Expr Rational -> ExprZ- normalize e = LA.mapCoeff (round . (*c)) e- where- c = fromIntegral $ foldl' lcm 1 ds- ds = [denominator d | (d,_) <- LA.terms e]---- -----------------------------------------------------------------------------gcd' :: [Integer] -> Integer-gcd' [] = 1-gcd' xs = foldl1' gcd xs---- ---------------------------------------------------------------------------+import Algorithm.FourierMotzkin.Core+import Algorithm.FourierMotzkin.FOL
+ src/Algorithm/FourierMotzkin/Core.hs view
@@ -0,0 +1,229 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Algorithm.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:+--+-- * <http://users.cecs.anu.edu.au/~michaeln/pubs/arithmetic-dps.pdf>+--+-----------------------------------------------------------------------------+module Algorithm.FourierMotzkin.Core+ ( ExprZ+ , Rat+ , toRat+ , fromRat++ , Lit (..)+ , fromLAAtom+ , toLAAtom++ , 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 Algebra.Lattice.Boolean++import Data.ArithRel+import Data.DNF+import qualified Data.LA as LA+import qualified Data.Interval as Interval+import Data.Interval (Interval, EndPoint (..), (<=..<), (<..<=), (<..<))+import 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)++-- 制約集合の単純化+-- 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]]++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++-- ---------------------------------------------------------------------------++{-+(ls1,ls2,us1,us2) represents+{ x | ∀(M,c)∈ls1. M/c≤x, ∀(M,c)∈ls2. M/c<x, ∀(M,c)∈us1. x≤M/c, ∀(M,c)∈us2. x<M/c }+-}+type BoundsR = ([Rat], [Rat], [Rat], [Rat])++project :: Var -> [LA.Atom Rational] -> [([LA.Atom Rational], Model Rational -> Model Rational)]+project v xs = do+ ys <- unDNF $ constraintsToDNF xs+ (zs, mt) <- project' v ys+ return (map toLAAtom zs, mt)++project' :: Var -> [Lit] -> [([Lit], Model Rational -> Model Rational)]+project' v xs = do+ case collectBounds v xs of+ (bnd, rest) -> do+ cond <- unDNF $ boundConditions bnd+ let mt m =+ case Interval.pickup (evalBounds m bnd) of+ Nothing -> error "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) <- projectN' vs ys+ return (map toLAAtom zs, mt)++projectN' :: VarSet -> [Lit] -> [([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++boundConditions :: BoundsR -> DNF Lit+boundConditions (ls1, ls2, us1, us2) = DNF $ maybeToList $ 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 = listToMaybe $ do+ (ys,mt) <- projectN' vs =<< maybeToList (simplify cs)+ guard $ Just [] == simplify ys+ return $ mt IM.empty++evalBounds :: Model Rational -> BoundsR -> Interval Rational+evalBounds model (ls1,ls2,us1,us2) =+ foldl' Interval.intersection Interval.whole $ + [ 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++-- ---------------------------------------------------------------------------
+ src/Algorithm/FourierMotzkin/FOL.hs view
@@ -0,0 +1,59 @@+{-# OPTIONS_GHC -Wall #-}+module Algorithm.FourierMotzkin.FOL+ ( solveFormula+ , eliminateQuantifiers+ , eliminateQuantifiers'+ )+ where++import Control.Monad+import qualified Data.IntSet as IS++import Algebra.Lattice.Boolean++import Data.ArithRel+import Data.DNF+import qualified Data.FOL.Arith as FOL+import qualified Data.LA.FOL as LAFOL+import Data.Var++import Algorithm.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 $ map fst $ project' v xs | xs <- unDNF dnf]++-- ---------------------------------------------------------------------------
src/Algorithm/LPSolver.hs view
@@ -25,12 +25,12 @@ import qualified Data.IntMap as IM import qualified Data.IntSet as IS import Data.OptDir+import Data.VectorSpace -import Data.Expr import Data.ArithRel-import Data.Linear import qualified Data.LA as LA import qualified Data.Interval as Interval+import Data.Var import qualified Algorithm.Simplex as Simplex import qualified Algorithm.BoundsInference as BI @@ -101,7 +101,7 @@ Ge -> do v1 <- gensym -- surplus variable v2 <- gensym -- artificial variable- putTableau $ Simplex.setRow v2 tbl (LA.coeffMap (e .-. LA.var v1), b)+ putTableau $ Simplex.setRow v2 tbl (LA.coeffMap (e ^-^ LA.var v1), b) addArtificialVariable v2 Eql -> do v <- gensym -- artificial variable@@ -118,14 +118,14 @@ addConstraint2 c = do Rel lhs rop rhs <- expandDefs' c let- (b', e) = LA.extract LA.unitVar (lhs .-. rhs)+ (b', e) = LA.extract LA.unitVar (lhs ^-^ rhs) b = - b' case rop of Le -> f e b- Ge -> f (lnegate e) (negate b)+ Ge -> f (negateV e) (negate b) Eql -> do f e b- f (lnegate e) (negate b)+ f (negateV e) (negate b) _ -> error $ "addConstraint does not support " ++ show rop where -- -x≤b で -b≤0 なら追加しない。ad hoc なので一般化したい。@@ -158,7 +158,7 @@ forM_ (IS.toList fvs) $ \v -> do v1 <- gensym v2 <- gensym- define v (LA.var v1 .-. LA.var v2)+ define v (LA.var v1 ^-^ LA.var v2) mapM_ addConstraint cs' getModel :: Fractional r => VarSet -> LP r (Model r)@@ -200,10 +200,10 @@ normalizeConstraint :: forall r. Real r => LA.Atom r -> (LA.Expr r, RelOp, r) normalizeConstraint (Rel a op b)- | rhs < 0 = (lnegate lhs, flipOp op, negate rhs)+ | rhs < 0 = (negateV lhs, flipOp op, negate rhs) | otherwise = (lhs, op, rhs) where- (c, lhs) = LA.extract LA.unitVar (a .-. b)+ (c, lhs) = LA.extract LA.unitVar (a ^-^ b) rhs = - c collectNonnegVars :: forall r. (RealFrac r) => [LA.Atom r] -> VarSet -> (VarSet, [LA.Atom r])@@ -212,11 +212,11 @@ vs = vars cs bounds = BI.inferBounds initialBounds cs ivs 1000 where- initialBounds = IM.fromList [(v, Interval.univ) | v <- IS.toList vs]+ 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- Just (_, lb) | 0 <= lb -> True+ Interval.Finite lb | 0 <= lb -> True _ -> False isTriviallyTrue :: LA.Atom r -> Bool@@ -224,26 +224,30 @@ case op of Le -> case ub of- Nothing -> False- Just (_, val) -> val <= 0+ Interval.PosInf -> False+ Interval.Finite val -> val <= 0+ Interval.NegInf -> True -- should not happen Ge -> case lb of- Nothing -> False- Just (_, val) -> val >= 0+ Interval.NegInf -> False+ Interval.Finite val -> val >= 0+ Interval.PosInf -> True -- should not happen Lt -> case ub of- Nothing -> False- Just (incl, val) -> val < 0 || (not incl && val <= 0)+ Interval.PosInf -> False+ Interval.Finite val -> val < 0 || (not inUB && val <= 0)+ Interval.NegInf -> True -- should not happen Gt -> case lb of- Nothing -> False- Just (incl, val) -> val > 0 || (not incl && val >= 0)- Eql -> isTriviallyTrue (c .<=. lzero) && isTriviallyTrue (c .>=. lzero)- NEq -> isTriviallyTrue (c .<. lzero) || isTriviallyTrue (c .>. lzero)+ 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+ c = a ^-^ b i = LA.computeInterval bounds c- lb = Interval.lowerBound i- ub = Interval.upperBound i+ (lb, inLB) = Interval.lowerBound' i+ (ub, inUB) = Interval.upperBound' i -- ---------------------------------------------------------------------------
src/Algorithm/LPSolverHL.hs view
@@ -15,8 +15,7 @@ ----------------------------------------------------------------------------- module Algorithm.LPSolverHL- ( module Data.Expr- , module Data.Formula+ ( OptResult (..) , minimize , maximize , optimize@@ -24,55 +23,44 @@ ) where import Control.Monad.State-import Data.Maybe (fromMaybe)-import Data.Ratio import qualified Data.IntMap as IM import qualified Data.IntSet as IS import Data.OptDir+import Data.VectorSpace -import Data.Expr import Data.ArithRel-import Data.Formula (Atom) import qualified Data.LA as LA+import Data.Var import qualified Algorithm.Simplex as Simplex import Algorithm.LPSolver -- --------------------------------------------------------------------------- -maximize :: (RealFrac r) => Expr r -> [Atom r] -> OptResult r+-- | 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) => Expr r -> [Atom r] -> OptResult r+minimize :: (RealFrac r) => LA.Expr r -> [LA.Atom r] -> OptResult r minimize = optimize OptMin -optimize :: (RealFrac r) => OptDir -> Expr r -> [Atom r] -> OptResult r-optimize optdir obj2 cs2 = fromMaybe OptUnknown $ do- obj <- LA.compileExpr obj2 - cs <- mapM LA.compileAtom cs2- return (optimize' optdir obj cs)--solve :: (RealFrac r) => [Atom r] -> SatResult r-solve cs2 = fromMaybe Unknown $ do- cs <- mapM LA.compileAtom cs2- return (solve' cs)---- -----------------------------------------------------------------------------solve' :: (RealFrac r) => [LA.Atom r] -> SatResult r-solve' cs =+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 Unsat+ then return Nothing else do m <- getModel vs- return (Sat m)+ return (Just m) where vs = vars cs -optimize' :: (RealFrac r) => OptDir -> LA.Expr r -> [LA.Atom r] -> OptResult r-optimize' optdir obj 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 <- phaseI@@ -92,19 +80,19 @@ -- --------------------------------------------------------------------------- -- Test cases -example_3_2 :: (Expr Rational, [Atom Rational])+example_3_2 :: (LA.Expr Rational, [LA.Atom Rational]) example_3_2 = (obj, cond) where- x1 = var 1- x2 = var 2- x3 = var 3- obj = 3*x1 + 2*x2 + 3*x3- cond = [ 2*x1 + x2 + x3 .<=. 2- , x1 + 2*x2 + 3*x3 .<=. 5- , 2*x1 + 2*x2 + x3 .<=. 6- , x1 .>=. 0- , x2 .>=. 0- , x3 .>=. 0+ 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@@ -112,22 +100,22 @@ uncurry maximize example_3_2 == Optimum (27/5) (IM.fromList [(1,1/5),(2,0),(3,8/5)]) -example_3_5 :: (Expr Rational, [Atom Rational])+example_3_5 :: (LA.Expr Rational, [LA.Atom Rational]) example_3_5 = (obj, cond) where- x1 = var 1- x2 = var 2- x3 = var 3- x4 = var 4- x5 = var 5- obj = -2*x1 + 4*x2 + 7*x3 + x4 + 5*x5- cond = [ -x1 + x2 + 2*x3 + x4 + 2*x5 .==. 7- , -x1 + 2*x2 + 3*x3 + x4 + x5 .==. 6- , -x1 + x2 + x3 + 2*x4 + x5 .==. 4- , x2 .>=. 0- , x3 .>=. 0- , x4 .>=. 0- , x5 .>=. 0+ 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@@ -135,16 +123,16 @@ uncurry minimize example_3_5 == Optimum 19 (IM.fromList [(1,-1),(2,0),(3,1),(4,0),(5,2)]) -example_4_1 :: (Expr Rational, [Atom Rational])+example_4_1 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_1 = (obj, cond) where- x1 = var 1- x2 = var 2- obj = 2*x1 + x2- cond = [ -x1 + x2 .>=. 2- , x1 + x2 .<=. 1- , x1 .>=. 0- , x2 .>=. 0+ 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@@ -152,16 +140,16 @@ uncurry maximize example_4_1 == OptUnsat -example_4_2 :: (Expr Rational, [Atom Rational])+example_4_2 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_2 = (obj, cond) where- x1 = var 1- x2 = var 2- obj = 2*x1 + x2- cond = [ - x1 - x2 .<=. 10- , 2*x1 - x2 .<=. 40- , x1 .>=. 0- , x2 .>=. 0+ 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@@ -169,16 +157,16 @@ uncurry maximize example_4_2 == Unbounded -example_4_3 :: (Expr Rational, [Atom Rational])+example_4_3 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_3 = (obj, cond) where- x1 = var 1- x2 = var 2- obj = 6*x1 - 2*x2- cond = [ 2*x1 - x2 .<=. 2- , x1 .<=. 4- , x1 .>=. 0- , x2 .>=. 0+ 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@@ -186,17 +174,17 @@ uncurry maximize example_4_3 == Optimum 12 (IM.fromList [(1,4),(2,6)]) -example_4_5 :: (Expr Rational, [Atom Rational])+example_4_5 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_5 = (obj, cond) where- x1 = var 1- x2 = var 2- obj = 2*x1 + x2- cond = [ 4*x1 + 3*x2 .<=. 12- , 4*x1 + x2 .<=. 8- , 4*x1 - x2 .<=. 8- , x1 .>=. 0- , x2 .>=. 0+ 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@@ -204,22 +192,22 @@ uncurry maximize example_4_5 == Optimum 5 (IM.fromList [(1,3/2),(2,2)]) -example_4_6 :: (Expr Rational, [Atom Rational])+example_4_6 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_6 = (obj, cond) where- x1 = var 1- x2 = var 2- x3 = var 3- x4 = var 4- obj = 20*x1 + (1/2)*x2 - 6*x3 + (3/4)*x4- cond = [ x1 .<=. 2- , 8*x1 - x2 + 9*x3 + (1/4)*x4 .<=. 16- , 12*x1 - (1/2)*x2 + 3*x3 + (1/2)*x4 .<=. 24- , x2 .<=. 1- , x1 .>=. 0- , x2 .>=. 0- , x3 .>=. 0- , x4 .>=. 0+ 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@@ -227,22 +215,22 @@ uncurry maximize example_4_6 == Optimum (165/4) (IM.fromList [(1,2),(2,1),(3,0),(4,1)]) -example_4_7 :: (Expr Rational, [Atom Rational])+example_4_7 :: (LA.Expr Rational, [LA.Atom Rational]) example_4_7 = (obj, cond) where- x1 = var 1- x2 = var 2- x3 = var 3- x4 = var 4- obj = x1 + 1.5*x2 + 5*x3 + 2*x4- cond = [ 3*x1 + 2*x2 + x3 + 4*x4 .<=. 6- , 2*x1 + x2 + 5*x3 + x4 .<=. 4- , 2*x1 + 6*x2 - 4*x3 + 8*x4 .==. 0- , x1 + 3*x2 - 2*x3 + 4*x4 .==. 0- , x1 .>=. 0- , x2 .>=. 0- , x3 .>=. 0- , x4 .>=. 0+ 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@@ -251,21 +239,21 @@ Optimum (48/11) (IM.fromList [(1,0),(2,0),(3,81),(4,41)]) -- 退化して巡回の起こるKuhnの7変数3制約の例-kuhn_7_3 :: (Expr Rational, [Atom Rational])+kuhn_7_3 :: (LA.Expr Rational, [LA.Atom Rational]) kuhn_7_3 = (obj, cond) where- [x1,x2,x3,x4,x5,x6,x7] = map var [1..7]- obj = -2*x4-3*x5+x6+12*x7- cond = [ x1 - 2*x4 - 9*x5 + x6 + 9*x7 .==. 0- , x2 + (1/3)*x4 + x5 - (1/3)*x6 - 2*x7 .==. 0- , x3 + 2*x4 + 3*x5 - x6 - 12*x7 .==. 2- , x1 .>=. 0- , x2 .>=. 0- , x3 .>=. 0- , x4 .>=. 0- , x5 .>=. 0- , x6 .>=. 0- , x7 .>=. 0+ [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
src/Algorithm/LPUtil.hs view
@@ -9,12 +9,12 @@ import qualified Data.IntMap as IM import qualified Data.IntSet as IS import Data.Maybe+import Data.VectorSpace -import Data.Expr (Var, VarSet, VarMap, Variables (..), Model (..)) import Data.ArithRel-import Data.Linear import qualified Data.LA as LA import qualified Data.Interval as Interval+import Data.Var import qualified Algorithm.BoundsInference as BI toStandardForm@@ -43,7 +43,7 @@ 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.univ) | v <- IS.toList vs]+ initialBounds = IM.fromList [(v, Interval.whole) | v <- IS.toList vs] bounds = BI.inferBounds initialBounds cs IS.empty 10 gensym :: M Var@@ -55,35 +55,35 @@ m = flip evalState v1 $ do s <- liftM IM.unions $ forM (IM.toList bounds) $ \(v,i) -> do case Interval.lowerBound i of- Nothing -> do+ Interval.NegInf -> do v1 <- gensym v2 <- gensym- return $ IM.singleton v (LA.var v1 .-. LA.var v2)- Just (_,lb)+ 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)+ 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+ 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 (lnegate e, flipOp 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)]+ 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)]+ return [(lhs2 ^-^ LA.var v, rhs2)] _ -> error $ "LPUtil.toStandardForm: " ++ show op2 ++ " is not supported" assert (and [isNothing $ LA.lookupCoeff LA.unitVar c | (c,_) <- cs2]) $ return ()
src/Algorithm/MIPSolver2.hs view
@@ -67,6 +67,7 @@ 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@@ -76,7 +77,6 @@ import Data.ArithRel ((.<=.), (.>=.)) import qualified Algorithm.Simplex2 as Simplex2 import Algorithm.Simplex2 (OptResult (..), Var, Model)-import Data.Linear import Util (isInteger, fracPart) data Solver@@ -459,16 +459,16 @@ 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)+ 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 $ c *^ (LA.constant uj ^-^ LA.var xj) - return $ lsum xs1 .+. lsum xs2 .>=. LA.constant 1+ return $ sumV xs1 ^+^ sumV xs2 .>=. LA.constant 1 -- TODO: Simplex2をδに対応させたら、xi, xj がδを含まない有理数であるという条件も必要 canDeriveGomoryCut :: Simplex2.Solver -> Var -> IO Bool
src/Algorithm/MIPSolverHL.hs view
@@ -26,13 +26,11 @@ ----------------------------------------------------------------------------- module Algorithm.MIPSolverHL- ( module Data.Expr- , module Data.Formula- , module Data.OptDir+ ( module Data.OptDir+ , OptResult (..) , minimize , maximize , optimize--- , solve ) where import Control.Exception@@ -42,43 +40,21 @@ import Data.List (maximumBy) import qualified Data.IntMap as IM import qualified Data.IntSet as IS-import Data.Ratio import Data.OptDir+import Data.VectorSpace -import Data.Expr import Data.ArithRel-import Data.Formula (Atom)-import Data.Linear+import Data.Var import qualified Data.LA as LA import qualified Algorithm.Simplex as Simplex import qualified Algorithm.LPSolver as LPSolver import Algorithm.LPSolver+import Algorithm.LPSolverHL (OptResult (..)) import qualified Algorithm.OmegaTest as OmegaTest import Util (isInteger, fracPart) -- --------------------------------------------------------------------------- -maximize :: RealFrac r => Expr r -> [Atom r] -> VarSet -> OptResult r-maximize = optimize OptMax--minimize :: RealFrac r => Expr r -> [Atom r] -> VarSet -> OptResult r-minimize = optimize OptMin--optimize :: RealFrac r => OptDir -> Expr r -> [Atom r] -> VarSet -> OptResult r-optimize optdir obj2 cs2 ivs = fromMaybe OptUnknown $ do- obj <- LA.compileExpr obj2 - cs <- mapM LA.compileAtom cs2- return (optimize' optdir obj cs ivs)--{--solve :: RealFrac r => [Atom r] -> VarSet -> SatResult r-solve cs2 ivs = fromMaybe Unknown $ do- cs <- mapM compileAtom cs2- return (solve' cs ivs)--}---- ---------------------------------------------------------------------------- data Node r = Node { ndSolver :: LPSolver.Solver r@@ -94,8 +70,14 @@ data Err = ErrUnbounded | ErrUnsat deriving (Ord, Eq, Show, Enum, Bounded) -optimize' :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r-optimize' optdir obj cs ivs = +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@@ -112,7 +94,7 @@ original problem is unbounded or unsatisfiable when LP relaxation is unbounded. -}- case OmegaTest.solveQFLA (map conv cs) ivs of+ case OmegaTest.solveQFLA OmegaTest.defaultOptions (vars cs `IS.union` ivs) (map conv cs) ivs of Nothing -> OptUnsat Just _ -> Unbounded Right (node0, ivs2) -> @@ -133,7 +115,7 @@ ivs2 <- liftM IS.unions $ forM (IS.toList fvs) $ \v -> do v1 <- gensym v2 <- gensym- define v (LA.var v1 .-. LA.var v2)+ 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@@ -244,11 +226,11 @@ x2 = LA.var 2 x3 = LA.var 3 x4 = LA.var 4- obj = x1 .+. 2 .*. x2 .+. 3 .*. x3 .+. x4+ 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+ [ (-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@@ -263,7 +245,7 @@ where (optdir, obj, cs, ivs) = example1 result, expected :: OptResult Rational- result = optimize' optdir obj cs ivs+ result = optimize optdir obj cs ivs expected = Optimum (245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) test1' :: Bool@@ -273,7 +255,7 @@ f OptMin = OptMax f OptMax = OptMin result, expected :: OptResult Rational- result = optimize' (f optdir) (lnegate obj) cs ivs+ 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@@ -282,11 +264,11 @@ where optdir = OptMin [x1,x2,x3] = map LA.var [1..3]- obj = (-1) .*. x1 .-. 3 .*. x2 .-. 5 .*. x3+ 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+ [ 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@@ -297,7 +279,7 @@ test2 = result == expected where result, expected :: OptResult Rational- result = optimize' optdir obj cs ivs+ result = optimize optdir obj cs ivs expected = Optimum (-37/2) (IM.fromList [(1,0),(2,2),(3,5/2)]) (optdir, obj, cs, ivs) = example2
src/Algorithm/OmegaTest.hs view
@@ -1,5 +1,4 @@ {-# OPTIONS_GHC -Wall #-}-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} ----------------------------------------------------------------------------- -- | -- Module : Algorithm.OmegaTest@@ -8,7 +7,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (MultiParamTypeClasses, FunctionalDependencies)+-- Portability : portable -- -- (incomplete) implementation of Omega Test --@@ -29,6 +28,10 @@ ( Model , solve , solveQFLA+ , Options (..)+ , defaultOptions+ , checkRealNoCheck+ , checkRealByFM ) where import Control.Monad@@ -38,17 +41,41 @@ import Data.Ratio import qualified Data.IntMap as IM import qualified Data.IntSet as IS+import Data.VectorSpace -import Data.Expr-import Data.Formula-import Data.Linear+import Algebra.Lattice.Boolean++import Data.ArithRel+import Data.DNF import qualified Data.LA as LA+import Data.Var import Util (combineMaybe) import qualified Algorithm.FourierMotzkin as FM-import Algorithm.FourierMotzkin (Lit (..), Rat)+import Algorithm.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 -- 制約集合の単純化@@ -72,20 +99,20 @@ -- Note that constants may be floored by division leZ e1 e2 = Nonneg (LA.mapCoeff (`div` d) e) where- e = e2 .-. e1+ e = e2 ^-^ e1 d = abs $ gcd' [c | (c,v) <- LA.terms e, v /= LA.unitVar]-ltZ e1 e2 = (e1 .+. LA.constant 1) `leZ` e2+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 (lnegate e)]]+ then DNF [[Nonneg e, Nonneg (negateV e)]] else false where e = LA.mapCoeff (`div` d) e3- e3 = e1 .-. e2+ e3 = e1 ^-^ e2 d = abs $ gcd' [c | (c,v) <- LA.terms e3, v /= LA.unitVar] -- ---------------------------------------------------------------------------@@ -100,24 +127,25 @@ collectBoundsZ v = foldr phi (([],[]),[]) where phi :: Lit -> (BoundsZ,[Lit]) -> (BoundsZ,[Lit])- phi (Pos t) x = phi (Nonneg (t .-. LA.constant 1)) x+ 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 -> (((lnegate t', c) : ls, us), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x+ 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' :: [Var] -> [Lit] -> Maybe (Model Integer)-solve' vs2 xs = simplify xs >>= go vs2+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@@ -126,7 +154,7 @@ (v,vs',bnd@(ls,us),rest) = chooseVariable vs ys case1 = do- let zs = [ LA.constant ((a-1)*(b-1)) `leZ` (a .*. d .-. b .*. c)+ 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@@ -134,7 +162,7 @@ Just val -> return $ IM.insert v val model case2 = msum- [ do eq <- isZero $ a' .*. LA.var v .-. (c' .+. LA.constant k)+ [ 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@@ -162,16 +190,16 @@ then case LA.extract xk e of (_, e') ->- let xk_def = signum ak .*. lnegate 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 .+.+ 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 .+. + 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@@ -218,11 +246,10 @@ -- --------------------------------------------------------------------------- -solve :: [LA.Atom Rational] -> Maybe (Model Integer)-solve cs = msum [solve' (IS.toList vs) lits | lits <- unDNF dnf]+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)- vs = vars cs f (Rel lhs op rhs) = case op of Lt -> DNF [[a `ltZ` b]]@@ -234,20 +261,20 @@ where (e1,c1) = g lhs (e2,c2) = g rhs- a = c2 .*. e1- b = c1 .*. e2+ 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 :: [LA.Atom Rational] -> VarSet -> Maybe (Model Rational)-solveQFLA cs ivs = listToMaybe $ do+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 cs2+ m <- maybeToList $ solve opt ivs cs2 return $ mt $ IM.map fromInteger m where- rvs = vars cs `IS.difference` ivs+ rvs = vs `IS.difference` ivs -- ---------------------------------------------------------------------------
+ src/Algorithm/OmegaTest/Misc.hs view
@@ -0,0 +1,41 @@+{-# OPTIONS_GHC -Wall #-}+module Algorithm.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 Data.LA as LA+import qualified Data.Polynomial as P+import Data.Var+import qualified Algorithm.CAD as CAD+import qualified Algorithm.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 = P.fromTerms [(c, g x) | (c,x) <- LA.terms t]++ g :: Int -> P.MonicMonomial Int+ g x+ | x == LA.unitVar = P.mmOne+ | otherwise = P.mmVar x++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
src/Algorithm/Simplex.hs view
@@ -41,11 +41,11 @@ import qualified Data.IntMap as IM import qualified Data.IntSet as IS import Data.OptDir+import Data.VectorSpace import Control.Exception -import Data.Expr-import Data.Linear import qualified Data.LA as LA+import Data.Var -- --------------------------------------------------------------------------- @@ -113,7 +113,7 @@ where row = case LA.extract LA.unitVar e of- (c, e') -> (LA.coeffMap (lnegate e'), c)+ (c, e') -> (LA.coeffMap (negateV e'), c) copyObjRow :: (Num r, Eq r) => Tableau r -> Tableau r -> Tableau r copyObjRow from to =@@ -225,7 +225,7 @@ | otherwise = (True, copyObjRow tbl $ removeArtificialVariables avs $ tbl1') where optdir = OptMax- tbl1 = setObjFun tbl $ lnegate $ lsum [LA.var v | v <- IS.toList avs]+ tbl1 = setObjFun tbl $ negateV $ sumV [LA.var v | v <- IS.toList avs] tbl1' = go tbl1 go tbl2 | currentObjValue tbl2 == 0 = tbl2
src/Algorithm/Simplex2.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DoAndIfThenElse, TypeSynonymInstances, FlexibleContexts, FlexibleInstances #-}+{-# LANGUAGE DoAndIfThenElse, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Algorithm.Simplex2@@ -7,7 +7,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (DoAndIfThenElse, TypeSynonymInstances, FlexibleContexts, FlexibleInstances)+-- Portability : non-portable (DoAndIfThenElse, TypeFamilies) -- -- Naïve implementation of Simplex method -- @@ -103,12 +103,12 @@ import Text.Printf import Data.Time import Data.OptDir+import Data.VectorSpace import System.CPUTime import qualified Data.LA as LA import Data.LA (Atom (..)) import Data.ArithRel-import Data.Linear import Data.Delta import Util (showRational) @@ -143,10 +143,10 @@ newSolver :: SolverValue v => IO (GenericSolver v) newSolver = do- t <- newIORef (IM.singleton objVar lzero)+ t <- newIORef (IM.singleton objVar zeroV) l <- newIORef IM.empty u <- newIORef IM.empty- m <- newIORef (IM.singleton objVar lzero)+ m <- newIORef (IM.singleton objVar zeroV) v <- newIORef 0 ok <- newIORef True dir <- newIORef OptMin@@ -197,7 +197,7 @@ , svPivotStrategy = pivot } -class (Linear Rational v, Ord v) => SolverValue v where+class (VectorSpace v, Scalar v ~ Rational, Ord v) => SolverValue v where toValue :: Rational -> v showValue :: Bool -> v -> String model :: GenericSolver v -> IO Model@@ -250,7 +250,7 @@ newVar solver = do v <- readIORef (svVCnt solver) writeIORef (svVCnt solver) $! v+1- modifyIORef (svModel solver) (IM.insert v lzero)+ modifyIORef (svModel solver) (IM.insert v zeroV) return v assertAtom :: Solver -> LA.Atom Rational -> IO ()@@ -271,8 +271,8 @@ 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)+ 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')@@ -281,7 +281,7 @@ 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+ case LA.extract LA.unitVar (lhs ^-^ rhs) of (n,e) -> (e, -n) case LA.terms lhs' of [(1,v)] -> return (v, op, rhs')@@ -289,7 +289,7 @@ _ -> do defs <- readIORef (svDefDB solver) let (c,lhs'') = scale lhs' -- lhs' = lhs'' / c = rhs'- rhs'' = c .*. rhs'+ rhs'' = c *^ rhs' op'' = if c < 0 then flipOp op else op case Map.lookup lhs'' defs of Just v -> do@@ -301,7 +301,7 @@ return (v,op'',rhs'') where scale :: LA.Expr Rational -> (Rational, LA.Expr Rational)- scale e = (c, c .*. e)+ scale e = (c, c *^ e) where c = c1 * c2 c1 = fromIntegral $ foldl' lcm 1 [denominator c | (c, _) <- LA.terms e]@@ -454,8 +454,8 @@ 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)+ then return (xi, fromJust li ^-^ vi)+ else return (xi, vi ^-^ fromJust ui) return $ Just $ fst $ maximumBy (comparing snd) xs2 {--------------------------------------------------------------------@@ -572,9 +572,9 @@ v1 <- getValue solver xi li <- getLB solver xi ui <- getUB solver xi- return [ assert (theta >= lzero) ((xi,v2), theta)+ return [ assert (theta >= zeroV) ((xi,v2), theta) | Just v2 <- [ui | aij > 0] ++ [li | aij < 0]- , let theta = (v2 .-. v1) ./. aij ]+ , let theta = (v2 ^-^ v1) ^/ aij ] -- β(xj) := β(xj) + θ なので θ を大きく case ubs of@@ -595,9 +595,9 @@ v1 <- getValue solver xi li <- getLB solver xi ui <- getUB solver xi- return [ assert (theta <= lzero) ((xi,v2), theta)+ return [ assert (theta <= zeroV) ((xi,v2), theta) | Just v2 <- [li | aij > 0] ++ [ui | aij < 0]- , let theta = (v2 .-. v1) ./. aij ]+ , let theta = (v2 ^-^ v1) ^/ aij ] -- β(xj) := β(xj) + θ なので θ を小さく case lbs of@@ -653,12 +653,12 @@ return $ case dir of OptMin -> def- OptMax -> lnegate def+ OptMax -> negateV def -- normalize to the cases of lower bound violation let xi_def = if isLBViolated then row- else lnegate row+ else negateV row ws <- do -- select non-basic variable xj such that -- (aij > 0 and β(xj) < uj) or (aij < 0 and β(xj) > lj)@@ -714,12 +714,12 @@ -- dump solver v0 <- getValue solver xj- let diff = v .-. v0+ let diff = v ^-^ v0 aj <- getCol solver xj modifyIORef (svModel solver) $ \m ->- let m2 = IM.map (\aij -> aij .*. diff) aj- in IM.insert xj v $ IM.unionWith (.+.) m2 m+ let m2 = IM.map (\aij -> aij *^ diff) aj+ in IM.insert xj v $ IM.unionWith (^+^) m2 m -- log solver $ printf "after update x%d (%s)" xj (show v) -- dump solver@@ -746,11 +746,11 @@ aj <- getCol solver xj let aij = aj IM.! xi- let theta = (v .-. (m IM.! xi)) ./. aij+ let theta = (v ^-^ (m IM.! xi)) ^/ aij let m' = IM.fromList $- [(xi, v), (xj, (m IM.! xj) .+. theta)] ++- [(xk, (m IM.! xk) .+. (akj .*. theta)) | (xk, akj) <- IM.toList aj, xk /= xi]+ [(xi, v), (xj, (m IM.! xj) ^+^ theta)] +++ [(xk, (m IM.! xk) ^+^ (akj *^ theta)) | (xk, akj) <- IM.toList aj, xk /= xi] writeIORef (svModel solver) (IM.union m' m) -- note that 'IM.union' is left biased. pivot solver xi xj
− src/Converter/CNF2LP.hs
@@ -1,77 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module : Converter.CNF2LP--- Copyright : (c) Masahiro Sakai 2011-2012--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : experimental--- Portability : portable----------------------------------------------------------------------------------module Converter.CNF2LP- ( ObjType (..)- , convert - ) where--import Data.Array.IArray-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.OptDir-import qualified Text.LPFile as LPFile-import qualified Language.CNF.Parse.ParseDIMACS as DIMACS-import qualified SAT.Types as SAT-import Converter.ObjType--convert :: ObjType -> DIMACS.CNF -> (LPFile.LP, Map.Map LPFile.Var Rational -> SAT.Model)-convert objType cnf = (lp, mtrans)- where- lp = LPFile.LP- { LPFile.variables = Set.fromList vs- , LPFile.dir = dir- , LPFile.objectiveFunction = (Nothing, obj)- , LPFile.constraints = cs- , LPFile.varInfo = Map.fromList- [ ( v- , LPFile.VarInfo- { LPFile.varName = v- , LPFile.varType = LPFile.IntegerVariable- , LPFile.varBounds = (LPFile.Finite 0, LPFile.Finite 1)- }- )- | v <- vs- ]- , LPFile.sos = []- }- mtrans m =- array (1, DIMACS.numVars cnf)- [ (i, val)- | i <- [1 .. DIMACS.numVars cnf]- , let val =- case m Map.! ("x" ++ show i) of- 0 -> False- 1 -> True- v0 -> error (show v0 ++ " is neither 0 nor 1")- ]- - dir = if objType == ObjMaxZero then OptMin else OptMax- obj = if objType == ObjNone then [LPFile.Term 0 (take 1 vs)] else [LPFile.Term 1 [v] | v <- vs]- vs = if DIMACS.numVars cnf == 0- then ["x0"]- else ["x" ++ show i | i <- [1 .. DIMACS.numVars cnf]]- cs = do- cl <- DIMACS.clauses cnf - let (lhs,n) = foldr f ([], 0) (elems cl)- return $ LPFile.Constraint- { LPFile.constrType = LPFile.NormalConstraint- , LPFile.constrLabel = Nothing- , LPFile.constrIndicator = Nothing- , LPFile.constrBody = (lhs, LPFile.Ge, fromIntegral $ 1 - n)- }- f :: Int -> (LPFile.Expr,Integer) -> (LPFile.Expr,Integer)- f lit (es,n) =- if lit > 0- then (LPFile.Term 1 [v] : es, n)- else (LPFile.Term (-1) [v] : es, n+1)- where v = "x" ++ show (abs lit)
src/Converter/MaxSAT2LP.hs view
@@ -14,75 +14,12 @@ ( convert ) where -import Data.Array.IArray-import qualified Data.Set as Set import qualified Data.Map as Map import qualified Text.LPFile as LPFile import qualified Text.MaxSAT as MaxSAT import SAT.Types--convert :: MaxSAT.WCNF -> (LPFile.LP, Map.Map LPFile.Var Rational -> Model)-convert- MaxSAT.WCNF- { MaxSAT.numVars = nvar- , MaxSAT.topCost = top- , MaxSAT.clauses = ls- } = (lp, mtrans)- where- lp = LPFile.LP- { LPFile.variables = Set.fromList vs- , LPFile.dir = LPFile.OptMin- , LPFile.objectiveFunction = (Nothing, obj)- , LPFile.constraints = cs- , LPFile.varInfo = Map.fromList- [ ( v- , LPFile.VarInfo- { LPFile.varName = v- , LPFile.varType = LPFile.IntegerVariable- , LPFile.varBounds = (LPFile.Finite 0, LPFile.Finite 1)- }- )- | v <- vs- ]- , LPFile.sos = []- }- mtrans m =- array (1, nvar)- [ (i, val)- | i <- [1 .. nvar]- , let val =- case m Map.! ("x" ++ show i) of- 0 -> False- 1 -> True- v0 -> error (show v0 ++ " is neither 0 nor 1")- ]-- obj = [ LPFile.Term (fromIntegral w) [v] | (v,(w,_)) <- zs, w < top ]- vs = [ "x" ++ show n | n <- [(1::Int)..nvar]] ++ - [ z | (z,(w,_)) <- zs, w /= top ]- cs = [h (z,(w,xs)) | (z,(w,xs)) <- zs]- where- h (z,(w,xs)) = LPFile.Constraint- { LPFile.constrType = LPFile.NormalConstraint- , LPFile.constrLabel = Nothing- , LPFile.constrIndicator = Nothing- , LPFile.constrBody = - case f xs of- (s,n)- | w>=top -> (g s, LPFile.Ge, fromIntegral (1 - n)) -- hard constraint- | otherwise -> (LPFile.Term 1 [z] : g s, LPFile.Ge, fromIntegral (1 - n)) -- soft constraint- }-- zs = zip (map (\x -> "z" ++ show x) [(1::Int)..]) ls-- f :: [Lit] -> (Map.Map Var Int, Int)- f = foldr phi (Map.empty,0)- where - phi lit (s,m)- | lit >= 0 = (Map.insertWith (+) (abs lit) 1 s, m)- | otherwise = (Map.insertWith (+) (abs lit) (-1) s, m+1)+import qualified Converter.MaxSAT2WBO as MaxSAT2WBO+import qualified Converter.PB2LP as PB2LP - g :: Map.Map Var Int -> [LPFile.Term]- g m = do- (v,c) <- Map.toList m- return (LPFile.Term (fromIntegral c) ["x" ++ show v])+convert :: Bool -> MaxSAT.WCNF -> (LPFile.LP, Map.Map LPFile.Var Rational -> Model)+convert useIndicator wcnf = PB2LP.convertWBO useIndicator (MaxSAT2WBO.convert wcnf)
+ src/Converter/MaxSAT2NLPB.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.MaxSAT2NLPB+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.MaxSAT2NLPB+ ( convert+ ) where++import qualified Text.PBFile as PBFile+import qualified Text.MaxSAT as MaxSAT++convert :: MaxSAT.WCNF -> PBFile.Formula+convert+ MaxSAT.WCNF+ { MaxSAT.topCost = top+ , MaxSAT.clauses = cs+ } = (Just obj, cs2)+ where+ obj = [(w, [-l | l <- ls]) | (w,ls) <- cs, w /= top]+ cs2 = [([(1,[l]) | l <- ls], PBFile.Ge, 1) | (w,ls) <- cs, w == top]
+ src/Converter/MaxSAT2WBO.hs view
@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.MaxSAT2WBO+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.MaxSAT2WBO+ ( convert+ ) where++import qualified Text.PBFile as PBFile+import qualified Text.MaxSAT as MaxSAT++convert :: MaxSAT.WCNF -> PBFile.SoftFormula+convert+ MaxSAT.WCNF+ { MaxSAT.topCost = top+ , MaxSAT.clauses = cs+ } = (Nothing, map f cs)+ where+ f (w,ls)+ | w>=top = (Nothing, p) -- hard constraint+ | otherwise = (Just w, p) -- soft constraint+ where+ p = ([(1,[l]) | l <- ls], PBFile.Ge, 1)+
src/Converter/PB2LP.hs view
@@ -11,8 +11,7 @@ -- ----------------------------------------------------------------------------- module Converter.PB2LP- ( ObjType (..)- , convert+ ( convert , convertWBO ) where @@ -25,10 +24,9 @@ import qualified Text.PBFile as PBFile import qualified Text.LPFile as LPFile import qualified SAT.Types as SAT-import Converter.ObjType -convert :: ObjType -> PBFile.Formula -> (LPFile.LP, Map.Map LPFile.Var Rational -> SAT.Model)-convert objType formula@(obj, cs) = (lp, mtrans (PBFile.pbNumVars formula))+convert :: PBFile.Formula -> (LPFile.LP, Map.Map LPFile.Var Rational -> SAT.Model)+convert formula@(obj, cs) = (lp, mtrans (PBFile.pbNumVars formula)) where lp = LPFile.LP { LPFile.variables = vs2@@ -54,11 +52,8 @@ (dir,obj2) = case obj of Just obj' -> (LPFile.OptMin, convExpr obj')- Nothing ->- case objType of- ObjNone -> (LPFile.OptMin, [LPFile.Term 0 (take 1 (Set.toList vs2 ++ ["x0"]))])- ObjMaxOne -> (LPFile.OptMax, [LPFile.Term 1 [v] | v <- Set.toList vs2])- ObjMaxZero -> (LPFile.OptMin, [LPFile.Term 1 [v] | v <- Set.toList vs2])+ Nothing -> (LPFile.OptMin, convExpr [])+ cs2 = do (lhs,op,rhs) <- cs let op2 = case op of@@ -75,7 +70,8 @@ } convExpr :: PBFile.Sum -> LPFile.Expr-convExpr = concatMap g2+convExpr [] = [LPFile.Term 0 ["x1"]]+convExpr s = concatMap g2 s where g2 :: PBFile.WeightedTerm -> LPFile.Expr g2 (w, tm) = foldl' prodE [LPFile.Term (fromIntegral w) []] (map g3 tm)
+ src/Converter/PB2LSP.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.PB2LSP+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.PB2LSP+ ( convert+ ) where++import Data.List+import qualified Text.PBFile as PBFile++convert :: PBFile.Formula -> ShowS+convert formula@(obj, cs) =+ showString "function model() {\n" .+ decls .+ constrs .+ obj2 .+ showString "}\n"+ where+ nv = PBFile.pbNumVars formula++ decls = showString $+ " for [i in 1.." ++ show nv ++ "] x[i] <- bool();\n"++ constrs = foldr (.) id+ [ showString " constraint " .+ showString (showSum lhs) .+ showString op2 .+ shows rhs .+ showString ";\n"+ | (lhs, op, rhs) <- cs+ , let op2 = case op of+ PBFile.Ge -> " >= "+ PBFile.Eq -> " == "+ ]++ sum' :: [String] -> String+ sum' xs = "sum(" ++ intercalate ", " xs ++ ")"++ showSum = sum' . map showTerm++ showTerm (n,ls) = intercalate "*" $ [show n | n /= 1] ++ [showLit l | l<-ls]++ showLit l =+ if l < 0+ then "!x[" ++ show (abs l) ++ "]"+ else "x[" ++ show l ++ "]"++ obj2 =+ case obj of+ Just obj' -> showString " minimize " . showString (showSum obj') . showString ";\n"+ Nothing -> id
+ src/Converter/PB2SMP.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.PB2SMP+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.PB2SMP+ ( convert+ ) where++import Data.List+import qualified Text.PBFile as PBFile++convert :: Bool -> PBFile.Formula -> ShowS+convert isUnix formula@(obj, cs) =+ header .+ decls .+ showString "\n" .+ obj2 .+ showString "\n" .+ constrs .+ showString "\n" .+ actions .+ footer+ where+ nv = PBFile.pbNumVars formula++ header =+ if isUnix+ then showString "#include \"simple.h\"\nvoid ufun()\n{\n\n"+ else id+ + footer =+ if isUnix+ then showString "\n}\n"+ else id++ actions =+ showString "solve();\n" .+ showString "x[i].val.print();\n" .+ showString "cost.val.print();\n"++ decls = showString $+ "Element i(set=\"1 .. " ++ show nv ++ "\");\n" +++ "IntegerVariable x(type=binary, index=i);\n"++ constrs = foldr (.) id+ [ showString (showSum lhs) .+ showString op2 .+ shows rhs .+ showString ";\n"+ | (lhs, op, rhs) <- cs+ , let op2 = case op of+ PBFile.Ge -> " >= "+ PBFile.Eq -> " == "+ ]++ showSum :: PBFile.Sum -> String+ showSum [] = "0"+ showSum xs = intercalate " + " $ map showTerm xs++ showTerm (n,ls) = intercalate "*" $ showCoeff n ++ [showLit l | l<-ls]++ showCoeff n+ | n == 1 = []+ | n < 0 = ["(" ++ show n ++ ")"]+ | otherwise = [show n]++ showLit l =+ if l < 0+ then "(1-x[" ++ show (abs l) ++ "])"+ else "x[" ++ show l ++ "]"++ obj2 =+ case obj of+ Just obj' ->+ showString "Objective cost(type=minimize);\n" .+ showString "cost = " . showString (showSum obj') . showString ";\n"+ Nothing -> id
+ src/Converter/PB2WBO.hs view
@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.PB2WBO+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- References:+--+-- * Improving Unsatisfiability-based Algorithms for Boolean Optimization+-- <http://sat.inesc-id.pt/~ruben/talks/sat10-talk.pdf>+--+-----------------------------------------------------------------------------+module Converter.PB2WBO (convert) where++import qualified Text.PBFile as PBFile++convert :: PBFile.Formula -> PBFile.SoftFormula+convert (obj, cs) = (Nothing, cs1 ++ cs2)+ where+ cs1 = [(Nothing, c) | c <- cs]+ cs2 = case obj of+ Nothing -> []+ Just e ->+ [ if w >= 0+ then (Just w, ([(-1,ls)], PBFile.Ge, 0))+ else (Just (abs w), ([(1,ls)], PBFile.Ge, 1))+ | (w,ls) <- e+ ]
+ src/Converter/PBSetObj.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.PBSetObj+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.PBSetObj+ ( ObjType (..)+ , setObj+ ) where++import qualified Text.PBFile as PBFile+import Converter.ObjType++setObj :: ObjType -> PBFile.Formula -> PBFile.Formula+setObj objType formula@(_, cs) = (Just obj2, cs)+ where+ obj2 = genObj objType formula++genObj :: ObjType -> PBFile.Formula -> PBFile.Sum+genObj objType formula =+ case objType of+ ObjNone -> []+ ObjMaxOne -> [(1,[-v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize false literals+ ObjMaxZero -> [(1,[ v]) | v <- [1 .. PBFile.pbNumVars formula]] -- minimize true literals
+ src/Converter/SAT2LP.hs view
@@ -0,0 +1,25 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.SAT2LP+-- Copyright : (c) Masahiro Sakai 2011-2012+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.SAT2LP+ ( convert+ ) where++import qualified Data.Map as Map+import qualified Text.LPFile as LPFile+import qualified Language.CNF.Parse.ParseDIMACS as DIMACS+import qualified SAT.Types as SAT+import qualified Converter.PB2LP as PB2LP+import qualified Converter.SAT2PB as SAT2PB++convert :: DIMACS.CNF -> (LPFile.LP, Map.Map LPFile.Var Rational -> SAT.Model)+convert cnf = PB2LP.convert (SAT2PB.convert cnf)
+ src/Converter/SAT2PB.hs view
@@ -0,0 +1,24 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.SAT2PB+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.SAT2PB+ ( convert+ ) where++import Data.Array.IArray+import qualified Text.PBFile as PBFile+import qualified Language.CNF.Parse.ParseDIMACS as DIMACS++convert :: DIMACS.CNF -> PBFile.Formula+convert cnf = (Nothing, map f (DIMACS.clauses cnf))+ where+ f clause = ([(1,[l]) | l <- elems clause], PBFile.Ge, 1)
+ src/Converter/WBO2PB.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : Converter.WBO2PB+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : experimental+-- Portability : portable+--+-----------------------------------------------------------------------------+module Converter.WBO2PB (convert) where++import Data.Array.IArray+import qualified SAT.Types as SAT+import qualified Text.PBFile as PBFile++convert :: PBFile.SoftFormula -> (PBFile.Formula, SAT.Model -> SAT.Model)+convert wbo@(top, cs) = ((Just obj, topConstr ++ concatMap f cm), mtrans)+ where+ nv = PBFile.wboNumVars wbo++ cm = zip [nv+1..] cs+ obj = [(w, [i]) | (i, (Just w,_)) <- cm]++ f :: (PBFile.Var, PBFile.SoftConstraint) -> [PBFile.Constraint]+ f (_, (Nothing, c)) = return c+ f (i, (Just _, c)) = relax i c++ relax :: PBFile.Var -> PBFile.Constraint -> [PBFile.Constraint]+ relax i (lhs, PBFile.Ge, rhs) = [((d, [i]) : lhs, PBFile.Ge, rhs)]+ where+ d = rhs - SAT.pbLowerBound [(c,1) | (c,_) <- lhs]+ relax i (lhs, PBFile.Eq, rhs) =+ relax i (lhs, PBFile.Ge, rhs) +++ relax i ([(-c,ls) | (c,ls) <- lhs], PBFile.Ge, - rhs)++ topConstr :: [PBFile.Constraint]+ topConstr = + case top of+ Nothing -> []+ Just t -> [([(-c,ls) | (c,ls) <- obj], PBFile.Ge, - (t - 1))]++ mtrans :: SAT.Model -> SAT.Model+ mtrans m = + array (1, nv) [(x, m ! x) | x <- [1..nv]]
src/Data/AlgebraicNumber.hs view
@@ -47,7 +47,7 @@ import qualified Data.Polynomial as P import qualified Data.Polynomial.Sturm as Sturm import qualified Data.Polynomial.FactorZ as FactorZ-import Data.Interval (Interval, (<!), (>!))+import Data.Interval (Interval, EndPoint (..), (<=..<), (<..<=), (<..<), (<!), (>!)) import qualified Data.Interval as Interval import Data.AlgebraicNumber.Root @@ -114,8 +114,8 @@ | otherwise = assert (Sturm.numRoots p ineg == 1) LT where c@(RealRoot p i3) = a - b- ipos = Interval.intersection i3 (Interval.interval (Just (False,0)) Nothing)- ineg = Interval.intersection i3 (Interval.interval Nothing (Just (False,0)))+ ipos = Interval.intersection i3 (Finite 0 <..< PosInf)+ ineg = Interval.intersection i3 (NegInf <..< Finite 0) instance Num AReal where RealRoot p1 i1 + RealRoot p2 i2 = realRoot p3 i3@@ -128,9 +128,9 @@ [] -> error "AReal.+: should not happen" [i5] -> i5 is5 ->- go (Sturm.narrow p1 i1 (Interval.size i1 / 2))- (Sturm.narrow p2 i2 (Interval.size i2 / 2))- [Sturm.narrow p3 i5 (Interval.size i5 / 2) | i5 <- is5]+ go (Sturm.narrow p1 i1 (Interval.width i1 / 2))+ (Sturm.narrow p2 i2 (Interval.width i2 / 2))+ [Sturm.narrow p3 i5 (Interval.width i5 / 2) | i5 <- is5] where i4 = i1 + i2 @@ -144,9 +144,9 @@ [] -> error "AReal.*: should not happen" [i5] -> i5 is5 ->- go (Sturm.narrow p1 i1 (Interval.size i1 / 2))- (Sturm.narrow p2 i2 (Interval.size i2 / 2))- [Sturm.narrow p3 i5 (Interval.size i5 / 2) | i5 <- is5]+ go (Sturm.narrow p1 i1 (Interval.width i1 / 2))+ (Sturm.narrow p2 i2 (Interval.width i2 / 2))+ [Sturm.narrow p3 i5 (Interval.width i5 / 2) | i5 <- is5] where i4 = i1 * i2 @@ -229,32 +229,32 @@ -- | Same as 'ceiling'. ceiling' :: Integral b => AReal -> b ceiling' (RealRoot p i) =- if Sturm.numRoots' chain (Interval.intersection i2 i3) > 1+ if Sturm.numRoots' chain (Interval.intersection i2 i3) >= 1 then fromInteger ceiling_lb else fromInteger ceiling_ub where chain = Sturm.sturmChain p i2 = Sturm.narrow' chain i (1/2)- Just (inLB, lb) = Interval.lowerBound i2- Just (inUB, ub) = Interval.upperBound i2+ (Finite lb, inLB) = Interval.lowerBound' i2+ (Finite ub, inUB) = Interval.upperBound' i2 ceiling_lb = ceiling lb ceiling_ub = ceiling ub- i3 = Interval.interval Nothing (Just (True, fromInteger ceiling_lb))+ i3 = NegInf <..<= Finite (fromInteger ceiling_lb) -- | Same as 'floor'. floor' :: Integral b => AReal -> b floor' (RealRoot p i) =- if Sturm.numRoots' chain (Interval.intersection i2 i3) > 1+ if Sturm.numRoots' chain (Interval.intersection i2 i3) >= 1 then fromInteger floor_ub else fromInteger floor_lb where chain = Sturm.sturmChain p i2 = Sturm.narrow' chain i (1/2)- Just (inLB, lb) = Interval.lowerBound i2- Just (inUB, ub) = Interval.upperBound i2+ (Finite lb, inLB) = Interval.lowerBound' i2+ (Finite ub, inUB) = Interval.upperBound' i2 floor_lb = floor lb floor_ub = floor ub- i3 = Interval.interval (Just (True, fromInteger floor_ub)) Nothing+ i3 = Finite (fromInteger floor_ub) <=..< PosInf {-------------------------------------------------------------------- Properties
src/Data/ArithRel.hs view
@@ -29,9 +29,9 @@ , (.<.), (.<=.), (.>=.), (.>.), (.==.), (./=.) ) where +import Algebra.Lattice.Boolean (Complement (..)) import qualified Data.IntSet as IS-import Data.Expr (Variables (..))-import Data.Lattice (Complement (..))+import Data.Var infix 4 .<., .<=., .>=., .>., .==., ./=. @@ -126,5 +126,8 @@ instance Variables e => Variables (Rel e) where vars (Rel a _ b) = vars a `IS.union` vars b++instance Functor Rel where+ fmap f (Rel a op b) = Rel (f a) op (f b) -- ---------------------------------------------------------------------------
+ src/Data/DNF.hs view
@@ -0,0 +1,46 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.DNF+-- Copyright : (c) Masahiro Sakai 2011-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Disjunctive Normal Form+-- +-----------------------------------------------------------------------------+module Data.DNF+ ( DNF (..)+ ) where++import Algebra.Lattice+import Algebra.Lattice.Boolean++-- | Disjunctive normal form+newtype DNF lit+ = DNF+ { unDNF :: [[lit]] -- ^ list of conjunction of literals+ } deriving (Show)++instance Complement lit => Complement (DNF lit) where+ notB (DNF xs) = DNF . sequence . map (map notB) $ xs++instance JoinSemiLattice (DNF lit) where+ DNF xs `join` DNF ys = DNF (xs++ys)++instance MeetSemiLattice (DNF lit) where+ DNF xs `meet` DNF ys = DNF [x++y | x<-xs, y<-ys]++instance Lattice (DNF lit)++instance BoundedJoinSemiLattice (DNF lit) where+ bottom = DNF []++instance BoundedMeetSemiLattice (DNF lit) where+ top = DNF [[]]++instance BoundedLattice (DNF lit)++instance Complement lit => Boolean (DNF lit)
src/Data/Delta.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Delta--- Copyright : (c) Masahiro Sakai 2011+-- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (FlexibleInstances, MultiParamTypeClasses)+-- Portability : non-portable (TypeFamilies) -- -- Augmenting number types with infinitesimal parameter δ. --@@ -41,7 +41,7 @@ , isInteger' ) where -import Data.Linear+import Data.VectorSpace import Util (isInteger) -- | @Delta r k@ represents r + kδ for symbolic infinitesimal parameter δ.@@ -63,12 +63,14 @@ deltaPart :: Delta r -> r deltaPart (Delta _ k) = k -instance Num r => Module r (Delta r) where- Delta r1 k1 .+. Delta r2 k2 = Delta (r1+r2) (k1+k2)- c .*. Delta r k = Delta (c*r) (c*k)- lzero = Delta 0 0+instance Num r => AdditiveGroup (Delta r) where+ Delta r1 k1 ^+^ Delta r2 k2 = Delta (r1+r2) (k1+k2)+ zeroV = Delta 0 0+ negateV (Delta r k) = Delta (- r) (- k) -instance Fractional r => Linear r (Delta r)+instance Num r => VectorSpace (Delta r) where+ type Scalar (Delta r) = r+ c *^ Delta r k = Delta (c*r) (c*k) -- | 'Delta' version of 'floor'. -- @'floor'' x@ returns the greatest integer not greater than @x@
− src/Data/Expr.hs
@@ -1,118 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Data.Expr--- Copyright : (c) Masahiro Sakai 2011--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : portable------ Arithmetic expressions (not limited to linear ones).--- -------------------------------------------------------------------------------module Data.Expr- ( Var- , VarSet- , VarMap- , Variables (..)- , Model- , Expr (..)- , var- , eval-- -- FIXME: どこか違うモジュールへ?- , SatResult (..)- , OptResult (..)- ) where--import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import Data.Ratio---- ------------------------------------------------------------------------------- | Variables are represented as non-negative integers-type Var = Int---- | Set of variables-type VarSet = IS.IntSet---- | Map from variables-type VarMap = IM.IntMap---- | collecting free variables-class Variables a where- vars :: a -> VarSet--instance Variables a => Variables [a] where- vars = IS.unions . map vars---- | A @Model@ is a map from variables to values.-type Model r = VarMap r---- ------------------------------------------------------------------------------- | Arithmetic expressions-data Expr r- = Const r- | Var Var- | Expr r :+: Expr r- | Expr r :*: Expr r- | Expr r :/: Expr r- deriving (Eq, Ord, Show)--instance Num r => Num (Expr r) where- a + b = a :+: b- a * b = a :*: b- a - b = a + negate b- negate a = Const (-1) :*: a- abs a = a- signum _ = 1- fromInteger = Const . fromInteger--instance Fractional r => Fractional (Expr r) where- a / b = a :/: b- fromRational x = fromInteger (numerator x) / fromInteger (denominator x)--instance Functor Expr where- fmap f = g- where- g (Const c) = Const (f c)- g (Var v) = Var v- g (a :+: b) = g a :+: g b- g (a :*: b) = g a :*: g b- g (a :/: b) = g a :/: g b--instance Variables (Expr r) where- vars (Const _) = IS.empty- vars (Var v) = IS.singleton v- vars (a :+: b) = vars a `IS.union` vars b- vars (a :*: b) = vars a `IS.union` vars b- vars (a :/: b) = vars a `IS.union` vars b---- | single variable expression-var :: Var -> Expr r-var = Var---- | evaluate an 'Expr' with respect to a 'Model'-eval :: Fractional r => Model r -> Expr r -> r-eval m = f- where- f (Const x) = x- f (Var v) = m IM.! v- f (a :+: b) = f a + f b- f (a :*: b) = f a * f b- f (a :/: b) = f a / f b---- ------------------------------------------------------------------------------- | results of satisfiability checking-data SatResult r = Unknown | Unsat | Sat (Model r)- deriving (Show, Eq, Ord)---- | results of optimization-data OptResult r = OptUnknown | OptUnsat | Unbounded | Optimum r (Model r)- deriving (Show, Eq, Ord)---- ---------------------------------------------------------------------------
+ src/Data/FOL/Arith.hs view
@@ -0,0 +1,112 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.FOL.Arith+-- Copyright : (c) Masahiro Sakai 2011-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Arithmetic language (not limited to linear ones).+-- +-----------------------------------------------------------------------------+module Data.FOL.Arith+ (+ -- * Arithmetic expressions+ Expr (..)+ , var+ , evalExpr++ -- * Atomic formula+ , module Data.ArithRel+ , Atom (..)+ , evalAtom++ -- * Arithmetic formula+ , module Data.FOL.Formula ++ -- * Misc+ , SatResult (..)+ ) where++import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Ratio++import Data.ArithRel+import Data.FOL.Formula+import Data.Var++-- ---------------------------------------------------------------------------++-- | Arithmetic expressions+data Expr r+ = Const r+ | Var Var+ | Expr r :+: Expr r+ | Expr r :*: Expr r+ | Expr r :/: Expr r+ deriving (Eq, Ord, Show)++instance Num r => Num (Expr r) where+ a + b = a :+: b+ a * b = a :*: b+ a - b = a + negate b+ negate a = Const (-1) :*: a+ abs a = a+ signum _ = 1+ fromInteger = Const . fromInteger++instance Fractional r => Fractional (Expr r) where+ a / b = a :/: b+ fromRational x = fromInteger (numerator x) / fromInteger (denominator x)++instance Functor Expr where+ fmap f = g+ where+ g (Const c) = Const (f c)+ g (Var v) = Var v+ g (a :+: b) = g a :+: g b+ g (a :*: b) = g a :*: g b+ g (a :/: b) = g a :/: g b++instance Variables (Expr r) where+ vars (Const _) = IS.empty+ vars (Var v) = IS.singleton v+ vars (a :+: b) = vars a `IS.union` vars b+ vars (a :*: b) = vars a `IS.union` vars b+ vars (a :/: b) = vars a `IS.union` vars b++-- | single variable expression+var :: Var -> Expr r+var = Var++-- | evaluate an 'Expr' with respect to a 'Model'+evalExpr :: Fractional r => Model r -> Expr r -> r+evalExpr m = f+ where+ f (Const x) = x+ f (Var v) = m IM.! v+ f (a :+: b) = f a + f b+ f (a :*: b) = f a * f b+ f (a :/: b) = f a / f b++-- ---------------------------------------------------------------------------++-- | Atomic formula+type Atom c = Rel (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)++instance IsRel (Expr c) (Formula (Atom c)) where+ rel op a b = Atom $ rel op a b++-- ---------------------------------------------------------------------------++-- | results of satisfiability checking+data SatResult r = Unknown | Unsat | Sat (Model r)+ deriving (Show, Eq, Ord)++-- ---------------------------------------------------------------------------
+ src/Data/FOL/Formula.hs view
@@ -0,0 +1,92 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.FOL.Formula+-- Copyright : (c) Masahiro Sakai 2011-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+--+-- Formula of first order logic.+-- +-----------------------------------------------------------------------------+module Data.FOL.Formula+ (+ -- * Overloaded operations for formula.+ module Algebra.Lattice.Boolean++ -- * Concrete formula+ , Formula (..)+ , pushNot+ ) where++import Algebra.Lattice+import Algebra.Lattice.Boolean++import qualified Data.IntSet as IS+import Data.Var++-- ---------------------------------------------------------------------------++-- | formulas of first order logic+data Formula a+ = T+ | F+ | Atom a+ | And (Formula a) (Formula a)+ | Or (Formula a) (Formula a)+ | Not (Formula a)+ | Imply (Formula a) (Formula a)+ | Equiv (Formula a) (Formula a)+ | Forall Var (Formula a)+ | Exists Var (Formula a)+ deriving (Show, Eq, Ord)++instance Variables a => Variables (Formula a) where+ vars T = IS.empty+ vars F = IS.empty+ vars (Atom a) = vars a+ vars (And a b) = vars a `IS.union` vars b+ vars (Or a b) = vars a `IS.union` vars b+ vars (Not a) = vars a+ vars (Imply a b) = vars a `IS.union` vars b+ vars (Equiv a b) = vars a `IS.union` vars b+ vars (Forall v a) = IS.delete v (vars a)+ vars (Exists v a) = IS.delete v (vars a)++instance Complement (Formula a) where+ notB = Not++instance JoinSemiLattice (Formula c) where+ join = Or++instance MeetSemiLattice (Formula c) where+ meet = And++instance Lattice (Formula c)++instance BoundedJoinSemiLattice (Formula c) where+ bottom = F++instance BoundedMeetSemiLattice (Formula c) where+ top = T++instance BoundedLattice (Formula c)++instance Boolean (Formula c) where+ (.=>.) = Imply+ (.<=>.) = Equiv++-- | convert a formula into negation normal form+pushNot :: Complement a => Formula a -> Formula a+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 (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 (Forall v a) = Exists v (pushNot a)+pushNot (Exists v a) = Forall v (pushNot a)
− src/Data/Formula.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--------------------------------------------------------------------------------- |--- Module : Data.Formula--- Copyright : (c) Masahiro Sakai 2011--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances)------ Formula of first order logic.--- -------------------------------------------------------------------------------module Data.Formula- (- -- * Overloaded operations for formula.- module Data.Lattice-- -- * Relational operators- , module Data.ArithRel-- -- * Concrete formula- , Atom (..)- , Formula (..)- , pushNot- , DNF (..)- ) where--import qualified Data.IntSet as IS-import Data.Expr-import Data.Lattice-import Data.ArithRel---- ------------------------------------------------------------------------------- | Atomic formula-type Atom c = Rel (Expr c)---- ------------------------------------------------------------------------------- | formulas of first order logic-data Formula a- = T- | F- | Atom a- | And (Formula a) (Formula a)- | Or (Formula a) (Formula a)- | Not (Formula a)- | Imply (Formula a) (Formula a)- | Equiv (Formula a) (Formula a)- | Forall Var (Formula a)- | Exists Var (Formula a)- deriving (Show, Eq, Ord)--instance Variables a => Variables (Formula a) where- vars T = IS.empty- vars F = IS.empty- vars (Atom a) = vars a- vars (And a b) = vars a `IS.union` vars b- vars (Or a b) = vars a `IS.union` vars b- vars (Not a) = vars a- vars (Imply a b) = vars a `IS.union` vars b- vars (Equiv a b) = vars a `IS.union` vars b- vars (Forall v a) = IS.delete v (vars a)- vars (Exists v a) = IS.delete v (vars a)--instance Complement (Formula a) where- notB = Not--instance Lattice (Formula c) where- top = T- bottom = F- meet = And- join = Or--instance Boolean (Formula c) where- (.=>.) = Imply- (.<=>.) = Equiv--instance IsRel (Expr c) (Formula (Atom c)) where- rel op a b = Atom $ rel op a b---- | convert a formula into negation normal form-pushNot :: Complement a => Formula a -> Formula a-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 (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 (Forall v a) = Exists v (pushNot a)-pushNot (Exists v a) = Forall v (pushNot a)---- | Disjunctive normal form-newtype DNF lit- = DNF- { unDNF :: [[lit]] -- ^ list of conjunction of literals- } deriving (Show)--instance Complement lit => Complement (DNF lit) where- notB (DNF xs) = DNF . sequence . map (map notB) $ xs--instance Complement lit => Lattice (DNF lit) where- top = DNF [[]]- bottom = DNF []- DNF xs `meet` DNF ys = DNF [x++y | x<-xs, y<-ys]- DNF xs `join` DNF ys = DNF (xs++ys)--instance Complement lit => Boolean (DNF lit)
− src/Data/Interval.hs
@@ -1,481 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable #-}--------------------------------------------------------------------------------- |--- Module : Data.Interval--- Copyright : (c) Masahiro Sakai 2011--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : non-portable (ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, DeriveDataTypeable)------ Interval datatype.--- -------------------------------------------------------------------------------module Data.Interval- (- -- * Interval type- Interval- , EndPoint-- -- * Construction- , interval- , closedInterval- , openInterval- , univ- , empty- , singleton-- -- * Query- , null- , member- , notMember- , isSubsetOf- , isProperSubsetOf- , lowerBound- , upperBound- , size-- -- * Comparison- , (<!), (<=!), (==!), (>=!), (>!)- , (<?), (<=?), (==?), (>=?), (>?)-- -- * Combine- , intersection- , join-- -- * Operations- , pickup- , tightenToInteger- ) where--import Control.Monad hiding (join)-import Data.List hiding (null)-import Data.Maybe-import Data.Monoid-import Data.Linear-import Data.Lattice-import Data.Typeable-import Util (combineMaybe, isInteger)-import Prelude hiding (null)---- | Interval-data Interval r- = Empty- | Interval (EndPoint r) (EndPoint r)- deriving (Eq, Typeable) ---- | Lower bound of the interval-lowerBound :: Num r => Interval r -> EndPoint r-lowerBound Empty = Just (False,0)-lowerBound (Interval lb _) = lb---- | Upper bound of the interval-upperBound :: Num r => Interval r -> EndPoint r-upperBound Empty = Just (False,0)-upperBound (Interval _ ub) = ub---- | Endpoint--- --- > (isInclusive, value)-type EndPoint r = Maybe (Bool, r)--instance (Ord r, Num r) => Lattice (Interval r) where- top = univ- bottom = empty- join = join'- meet = intersection--instance (Num r, Show r) => Show (Interval r) where- showsPrec p x = showParen (p > appPrec) $- showString "interval " .- showsPrec appPrec1 (lowerBound x) .- showChar ' ' . - showsPrec appPrec1 (upperBound x)---- | smart constructor for 'Interval'-interval- :: (Ord r, Num r)- => EndPoint r -- ^ lower bound- -> EndPoint r -- ^ upper bound- -> Interval r-interval lb@(Just (in1,x1)) ub@(Just (in2,x2)) =- case x1 `compare` x2 of- GT -> empty- LT -> Interval lb ub- EQ -> if in1 && in2 then Interval lb ub else empty-interval lb ub = Interval lb ub---- | closed set [@l, @u]-closedInterval- :: (Ord r, Num r)- => r -- ^ lower bound @l@- -> r -- ^ upper bound @u@- -> Interval r-closedInterval lb ub = interval (Just (True, lb)) (Just (True, ub))---- | open set (@l, @u)-openInterval- :: (Ord r, Num r)- => r -- ^ lower bound @l@- -> r -- ^ upper bound @u@- -> Interval r-openInterval lb ub = interval (Just (False, lb)) (Just (False, ub))---- | universal set (-∞, ∞)-univ :: (Num r, Ord r) => Interval r-univ = interval Nothing Nothing---- | empty (contradicting) interval-empty :: Num r => Interval r-empty = Empty---- | singleton set \[x,x\]-singleton :: (Num r, Ord r) => r -> Interval r-singleton x = interval (Just (True, x)) (Just (True, x))---- | intersection (greatest lower bounds) of two intervals-intersection :: forall r. (Ord r, Num r) => Interval r -> Interval r -> Interval r-intersection (Interval l1 u1) (Interval l2 u2) = interval (maxLB l1 l2) (minUB u1 u2)- where- maxLB :: EndPoint r -> EndPoint r -> EndPoint r- maxLB = combineMaybe $ \(in1,x1) (in2,x2) ->- ( case x1 `compare` x2 of- EQ -> in1 && in2- LT -> in2- GT -> in1- , max x1 x2- )- minUB :: EndPoint r -> EndPoint r -> EndPoint r- minUB = combineMaybe $ \(in1,x1) (in2,x2) ->- ( case x1 `compare` x2 of- EQ -> in1 && in2- LT -> in1- GT -> in2- , min x1 x2- )-intersection _ _ = empty---- | join (least upperbound) of two intervals.-join' :: forall r. (Ord r, Num r) => Interval r -> Interval r -> Interval r-join' Empty x2 = x2-join' x1 Empty = x1-join' (Interval l1 u1) (Interval l2 u2) = interval (minLB l1 l2) (maxUB u1 u2)- where- maxUB :: EndPoint r -> EndPoint r -> EndPoint r- maxUB u1 u2 = do- (in1,x1) <- u1- (in2,x2) <- u2- return $- ( case x1 `compare` x2 of- EQ -> in1 || in2- LT -> in2- GT -> in1- , max x1 x2- )- minLB :: EndPoint r -> EndPoint r -> EndPoint r- minLB l1 l2 = do- (in1,x1) <- l1- (in2,x2) <- l2- return $- ( case x1 `compare` x2 of- EQ -> in1 || in2- LT -> in1- GT -> in2- , min x1 x2- )---- | Is the interval empty?-null :: Ord r => Interval r -> Bool-null Empty = True-null _ = False---- | Is the element in the interval?-member :: Ord r => r -> Interval r -> Bool-member _ Empty = False-member x (Interval lb ub) = testLB x lb && testUB x ub- where- testLB x Nothing = True- testLB x (Just (in1,x1)) = if in1 then x1 <= x else x1 < x- testUB x Nothing = True- testUB x (Just (in2,x2)) = if in2 then x <= x2 else x < x2---- | Is the element not in the interval?-notMember :: Ord r => r -> Interval r -> Bool-notMember a i = not $ member a i---- | Is this a subset?--- @(i1 `isSubsetOf` i2)@ tells whether @i1@ is a subset of @i2@.-isSubsetOf :: Ord r => Interval r -> Interval r -> Bool-isSubsetOf Empty _ = True-isSubsetOf _ Empty = False-isSubsetOf (Interval lb1 ub1) (Interval lb2 ub2) = testLB lb1 lb2 && testUB ub1 ub2- where- testLB _ Nothing = True- testLB (Just (in1,x1)) (Just (in2,x2)) =- case x1 `compare` x2 of- GT -> True- LT -> False- EQ -> not in1 || in2 -- in1 => in2- testLB Nothing _ = False-- testUB _ Nothing = True- testUB (Just (in1,x1)) (Just (in2,x2)) =- case x1 `compare` x2 of- LT -> True- GT -> False- EQ -> not in1 || in2 -- in1 => in2- testUB Nothing _ = False---- | Is this a proper subset? (ie. a subset but not equal).-isProperSubsetOf :: Ord r => Interval r -> Interval r -> Bool-isProperSubsetOf i1 i2 = i1 /= i2 && i1 `isSubsetOf` i2---- | Size of a interval. Size of an unbounded interval is @undefined@.-size :: (Num r, Ord r) => Interval r -> r-size Empty = 0-size (Interval (Just (_,l)) (Just (_,u))) = u - l-size _ = error "Data.Interval.size: unbounded interval"---- | pick up an element from the interval if the interval is not empty.-pickup :: (Real r, Fractional r) => Interval r -> Maybe r-pickup Empty = Nothing-pickup (Interval Nothing Nothing) = Just 0-pickup (Interval (Just (in1,x1)) Nothing) = Just $ if in1 then x1 else x1+1-pickup (Interval Nothing (Just (in2,x2))) = Just $ if in2 then x2 else x2-1-pickup (Interval (Just (in1,x1)) (Just (in2,x2))) =- case x1 `compare` x2 of- GT -> Nothing- LT -> Just $ (x1+x2) / 2- EQ -> if in1 && in2 then Just x1 else Nothing---- | tightening intervals by ceiling lower bounds and flooring upper bounds.-tightenToInteger :: forall r. (RealFrac r) => Interval r -> Interval r-tightenToInteger Empty = Empty-tightenToInteger (Interval lb ub) = interval (fmap tightenLB lb) (fmap tightenUB ub)- where- tightenLB (incl,lb) =- ( True- , if isInteger lb && not incl- then lb + 1- else fromIntegral (ceiling lb :: Integer)- )- tightenUB (incl,ub) =- ( True- , if isInteger ub && not incl- then ub - 1- else fromIntegral (floor ub :: Integer)- )---- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@-(<!) :: Real r => Interval r -> Interval r -> Bool-a <! b- | null a = True- | null b = True- | otherwise =- case upperBound a of- Nothing -> False- Just (in1,ub1) ->- case lowerBound b of- Nothing -> False- Just (in2,lb2) ->- ub1 < lb2 || (ub1==lb2 && not (in1 && in2))---- | For all @x@ in @X@, @y@ in @Y@. @x '<=' y@-(<=!) :: Real r => Interval r -> Interval r -> Bool-a <=! b- | null a = True- | null b = True- | otherwise =- case upperBound a of- Nothing -> False- Just (in1,ub1) ->- case lowerBound b of- Nothing -> False- Just (in2,lb2) ->- ub1 <= lb2---- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@-(==!) :: Real r => Interval r -> Interval r -> Bool-a ==! b = a <=! b && a >=! b---- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@-(>=!) :: Real r => Interval r -> Interval r -> Bool-(>=!) = flip (<=!)---- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@-(>!) :: Real r => Interval r -> Interval r -> Bool-(>!) = flip (<!)---- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?-(<?) :: Real r => Interval r -> Interval r -> Bool-a <? b- | null a = False- | null b = False- | otherwise =- case lowerBound a of- Nothing -> True- Just (in1,lb) ->- case upperBound b of- Nothing -> True- Just (in2,ub) -> lb < ub---- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?-(<=?) :: Real r => Interval r -> Interval r -> Bool-a <=? b- | null a = False- | null b = False- | otherwise =- case lowerBound a of- Nothing -> True- Just (in1,lb) ->- case upperBound b of- Nothing -> True- Just (in2,ub) ->- lb < ub || (lb==ub && in1 && in2)---- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?-(==?) :: Real r => Interval r -> Interval r -> Bool-a ==? b = not $ null $ intersection a b---- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?-(>=?) :: Real r => Interval r -> Interval r -> Bool-(>=?) = flip (<=?)---- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?-(>?) :: Real r => Interval r -> Interval r -> Bool-(>?) = flip (<?)---- | Interval airthmetics.--- Note that this instance does not satisfy algebraic laws of linear spaces.-instance Real r => Module r (Interval r) where- lzero = singleton 0-- Interval lb1 ub1 .+. Interval lb2 ub2 = interval (f lb1 lb2) (f ub1 ub2)- where- f = liftM2 $ \(in1,x1) (in2,x2) -> (in1 && in2, x1 + x2)- _ .+. _ = Empty-- _ .*. Empty = Empty- c .*. Interval lb ub =- case compare c 0 of- EQ -> singleton 0- LT -> interval (f ub) (f lb)- GT -> interval (f lb) (f ub)- where- f Nothing = Nothing- f (Just (incl,val)) = Just (incl, c * val)--instance (Real r, Fractional r) => Linear r (Interval r)--appPrec, appPrec1 :: Int-appPrec = 10-appPrec1 = appPrec + 1---instance forall r. (Real r, Fractional r) => Num (Interval r) where- a + b = a .+. b- a - b = a .-. b- negate a = (-1) .*. a- fromInteger i = singleton (fromInteger i)-- abs x = ((x `intersection` nonneg) `join` (negate x `intersection` nonneg))- where- nonneg = interval (Just (True,0)) Nothing-- signum x = zero `join` pos `join` neg- where- zero = if member 0 x then singleton 0 else empty- pos = if null $ intersection (interval (Just (False,0)) Nothing) x- then empty- else singleton 1- neg = if null $ intersection (interval Nothing (Just (False,0))) x- then empty- else singleton (-1)-- Interval lb1 ub1 * Interval lb2 ub2 = interval lb3 ub3- where- xs = [ mulInf' x1 x2- | x1 <- [lbToInf lb1, ubToInf ub1]- , x2 <- [lbToInf lb2, ubToInf ub2]- ]- ub3 = infToUB $ maximumBy cmpUB xs- lb3 = infToLB $ minimumBy cmpLB xs- _ * _ = Empty--instance forall r. (Real r, Fractional r) => Fractional (Interval r) where- fromRational r = singleton (fromRational r)- recip Empty = Empty- recip i | 0 `member` i = univ -- should be error?- recip (Interval lb ub) = interval lb3 ub3- where- ub3 = infToUB $ maximumBy cmpUB xs- lb3 = infToLB $ minimumBy cmpLB xs- xs = [recipLB (lbToInf lb), recipUB (ubToInf ub)]--data Inf r = NegInf | Finite !r | PosInf- deriving (Ord, Eq)--cmpUB, cmpLB :: Real r => (Bool, Inf r) -> (Bool, Inf r) -> Ordering-cmpUB (in1,x1) (in2,x2) = compare x1 x2 `mappend` compare in1 in2-cmpLB (in1,x1) (in2,x2) = compare x1 x2 `mappend` flip compare in1 in2--negateInf :: Num r => Inf r -> Inf r-negateInf NegInf = PosInf-negateInf PosInf = NegInf-negateInf (Finite x) = Finite (negate x)--mulInf' :: (Num r, Ord r) => (Bool, Inf r) -> (Bool, Inf r) -> (Bool, Inf r)-mulInf' (True, Finite 0) _ = (True, Finite 0)-mulInf' _ (True, Finite 0) = (True, Finite 0)-mulInf' (in1,x1) (in2,x2) = (in1 && in2, mulInf x1 x2)--mulInf :: (Num r, Ord r) => Inf r -> Inf r -> Inf r-mulInf (Finite x1) (Finite x2) = Finite (x1 * x2)-mulInf inf (Finite x2) =- case compare x2 0 of- EQ -> Finite 0- GT -> inf- LT -> negateInf inf-mulInf (Finite x1) inf =- case compare x1 0 of- EQ -> Finite 0- GT -> inf- LT -> negateInf inf-mulInf PosInf PosInf = PosInf-mulInf PosInf NegInf = NegInf-mulInf NegInf PosInf = NegInf-mulInf NegInf NegInf = PosInf--recipLB :: (Fractional r, Ord r) => (Bool, Inf r) -> (Bool, Inf r)-recipLB (_, Finite 0) = (False, PosInf)-recipLB (in1, x1) = (in1, recipInf x1)--recipUB :: (Fractional r, Ord r) => (Bool, Inf r) -> (Bool, Inf r)-recipUB (_, Finite 0) = (False, NegInf)-recipUB (in1, x1) = (in1, recipInf x1)--recipInf :: (Fractional r, Ord r) => Inf r -> Inf r-recipInf PosInf = Finite 0-recipInf NegInf = Finite 0-recipInf (Finite x) = Finite (1/x)--lbToInf :: Num r => EndPoint r -> (Bool, Inf r)-lbToInf Nothing = (False, NegInf)-lbToInf (Just (in1,x1)) = (in1, Finite x1)--ubToInf :: Num r => EndPoint r -> (Bool, Inf r)-ubToInf Nothing = (False, PosInf)-ubToInf (Just (in1,x1)) = (in1, Finite x1)--infToLB :: Num r => (Bool, Inf r) -> EndPoint r-infToLB (in1, Finite x) = Just (in1, x)-infToLB (False, NegInf) = Nothing-infToLB (_, PosInf) = error "infToLB: should not happen"-infToLB (True, NegInf) = error "infToLB: should not happen"--infToUB :: Num r => (Bool, Inf r) -> EndPoint r-infToUB (in1, Finite x) = Just (in1, x)-infToUB (False, PosInf) = Nothing-infToUB (_, NegInf) = error "infToUB: should not happen"-infToUB (True, PosInf) = error "infToUB: should not happen"
src/Data/LA.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Data.LA@@ -7,16 +7,15 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances)+-- Portability : non-portable (TypeFamilies) -- -- Some definition for Theory of Linear Arithmetics. -- ----------------------------------------------------------------------------- module Data.LA- ( module Data.Linear-+ ( -- * Expression of linear arithmetics- , Expr+ Expr -- ** Conversion , var@@ -53,8 +52,6 @@ -- * misc , BoundsEnv , computeInterval- , compileExpr- , compileAtom ) where import Control.Monad@@ -63,12 +60,10 @@ import Data.Maybe import qualified Data.IntMap as IM import qualified Data.IntSet as IS-import qualified Data.Expr as Expr-import Data.Expr (Var, VarMap, VarSet, Variables, Model) import qualified Data.ArithRel as ArithRel-import qualified Data.Formula as Formula-import Data.Linear import Data.Interval+import Data.Var+import Data.VectorSpace ----------------------------------------------------------------------------- @@ -145,16 +140,18 @@ g v c = if c' == 0 then Nothing else Just c' where c' = f c v -instance (Num r, Eq r) => Module r (Expr r) where- Expr t .+. e2 | IM.null t = e2- e1 .+. Expr t | IM.null t = e1- e1 .+. e2 = normalizeExpr $ plus e1 e2- 1 .*. e = e- 0 .*. e = lzero- c .*. e = mapCoeff (c*) e- lzero = Expr $ IM.empty+instance (Num r, Eq r) => AdditiveGroup (Expr r) where+ Expr t ^+^ e2 | IM.null t = e2+ e1 ^+^ Expr t | IM.null t = e1+ e1 ^+^ e2 = normalizeExpr $ plus e1 e2+ zeroV = Expr $ IM.empty+ negateV = ((-1) *^) -instance (Fractional r, Eq r) => Linear r (Expr r)+instance (Num r, Eq r) => VectorSpace (Expr r) where+ type Scalar (Expr r) = r+ 1 *^ e = e+ 0 *^ e = zeroV+ c *^ e = mapCoeff (c*) e plus :: Num r => Expr r -> Expr r -> Expr r plus (Expr t1) (Expr t2) = Expr $ IM.unionWith (+) t1 t2@@ -165,21 +162,21 @@ where m' = IM.insert unitVar 1 m -- | evaluate the expression under the model.-evalLinear :: Linear r a => Model a -> a -> Expr r -> a-evalLinear m u (Expr t) = lsum [c .*. (m' IM.! v) | (v,c) <- IM.toList t]+evalLinear :: VectorSpace a => Model a -> a -> Expr (Scalar a) -> a+evalLinear m u (Expr t) = sumV [c *^ (m' IM.! v) | (v,c) <- IM.toList t] where m' = IM.insert unitVar u m -lift1 :: Linear r x => x -> (Var -> x) -> Expr r -> x-lift1 unit f (Expr t) = lsum [c .*. (g v) | (v,c) <- IM.toList t]+lift1 :: VectorSpace x => x -> (Var -> x) -> Expr (Scalar x) -> x+lift1 unit f (Expr t) = sumV [c *^ (g v) | (v,c) <- IM.toList t] where g v | v==unitVar = unit | otherwise = f v applySubst :: (Num r, Eq r) => VarMap (Expr r) -> Expr r -> Expr r-applySubst s (Expr m) = lsum (map f (IM.toList m))+applySubst s (Expr m) = sumV (map f (IM.toList m)) where- f (v,c) = c .*. (+ f (v,c) = c *^ ( case IM.lookup v s of Just tm -> tm Nothing -> var v)@@ -189,7 +186,7 @@ applySubst1 x e e1 = case extractMaybe x e1 of Nothing -> e1- Just (c,e2) -> c .*. e .+. e2+ Just (c,e2) -> c *^ e ^+^ e2 -- | lookup a coefficient of the variable. -- @@@ -206,7 +203,7 @@ lookupCoeff :: Num r => Var -> Expr r -> Maybe r lookupCoeff v (Expr m) = IM.lookup v m --- | @extract v e@ returns @(c, e')@ such that @e == c .*. v .+. e'@+-- | @extract v e@ returns @(c, e')@ such that @e == c *^ v ^+^ e'@ extract :: Num r => Var -> Expr r -> (r, Expr r) extract v (Expr m) = (IM.findWithDefault 0 v m, Expr (IM.delete v m)) {-@@ -217,7 +214,7 @@ (Just c, m2) -> (c, Expr m2) -} --- | @extractMaybe v e@ returns @Just (c, e')@ such that @e == c .*. v .+. e'@+-- | @extractMaybe v e@ returns @Just (c, e')@ such that @e == c *^ v ^+^ e'@ -- if @e@ contains v, and returns @Nothing@ otherwise. extractMaybe :: Num r => Var -> Expr r -> Maybe (r, Expr r) extractMaybe v (Expr m) =@@ -265,40 +262,17 @@ -- is equivalent to @a@. solveFor :: (Real r, Fractional r) => Atom r -> Var -> Maybe (ArithRel.RelOp, Expr r) solveFor (ArithRel.Rel lhs op rhs) v = do- (c,e) <- extractMaybe v (lhs .-. rhs)+ (c,e) <- extractMaybe v (lhs ^-^ rhs) return ( if c < 0 then ArithRel.flipOp op else op- , (1/c) .*. lnegate e+ , (1/c) *^ negateV e ) ----------------------------------------------------------------------------- -type BoundsEnv r = Expr.VarMap (Interval r)+type BoundsEnv r = VarMap (Interval r) -- | compute bounds for a @Expr@ with respect to @BoundsEnv@. computeInterval :: (Real r, Fractional r) => BoundsEnv r -> Expr r -> Interval r-computeInterval b = lift1 (singleton 1) (b IM.!)---------------------------------------------------------------------------------compileExpr :: (Real r, Fractional r) => Expr.Expr r -> Maybe (Expr r)-compileExpr (Expr.Const c) = return (constant c)-compileExpr (Expr.Var c) = return (var c)-compileExpr (a Expr.:+: b) = liftM2 (.+.) (compileExpr a) (compileExpr b)-compileExpr (a Expr.:*: b) = do- x <- compileExpr a- y <- compileExpr b- msum [ do{ c <- asConst x; return (c .*. y) }- , do{ c <- asConst y; return (c .*. x) }- ]-compileExpr (a Expr.:/: b) = do- x <- compileExpr a- c <- asConst =<< compileExpr b- return $ (1/c) .*. x--compileAtom :: (Real r, Fractional r) => Formula.Atom r -> Maybe (Atom r)-compileAtom (ArithRel.Rel a op b) = do- a' <- compileExpr a- b' <- compileExpr b- return $ ArithRel.rel op a' b'+computeInterval b = evalExpr b . mapCoeff singleton -----------------------------------------------------------------------------
+ src/Data/LA/FOL.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -Wall #-}+module Data.LA.FOL+ ( fromFOLAtom+ , toFOLFormula+ , fromFOLExpr+ , toFOLExpr+ ) where++import Control.Monad++import Data.ArithRel+import Data.FOL.Arith+import Data.VectorSpace++import qualified Data.LA as LA++-- ---------------------------------------------------------------------------++fromFOLAtom :: (Real r, Fractional r) => Atom r -> Maybe (LA.Atom r)+fromFOLAtom (Rel a op b) = do+ a' <- fromFOLExpr a+ b' <- fromFOLExpr b+ return $ rel op a' b'++toFOLFormula :: (Real r, Fractional r) => LA.Atom r -> Formula (Atom r)+toFOLFormula r = Atom $ fmap toFOLExpr r++fromFOLExpr :: (Real r, Fractional r) => Expr r -> Maybe (LA.Expr r)+fromFOLExpr (Const c) = return (LA.constant c)+fromFOLExpr (Var v) = return (LA.var v)+fromFOLExpr (a :+: b) = liftM2 (^+^) (fromFOLExpr a) (fromFOLExpr b)+fromFOLExpr (a :*: b) = do+ a' <- fromFOLExpr a+ b' <- fromFOLExpr b+ msum [ do{ c <- LA.asConst a'; return (c *^ b') }+ , do{ c <- LA.asConst b'; return (c *^ a') }+ ]+fromFOLExpr (a :/: b) = do+ a' <- fromFOLExpr a+ b' <- fromFOLExpr b+ c <- LA.asConst b'+ guard $ c /= 0+ return (a' ^/ c)++toFOLExpr :: (Real r, Fractional r) => LA.Expr r -> Expr r+toFOLExpr e =+ case map f (LA.terms e) of+ [] -> Const 0+ [t] -> t+ ts -> foldr1 (*) ts+ where+ f (c,x)+ | x == LA.unitVar = Const c+ | otherwise = Const c * Var x++-- ---------------------------------------------------------------------------
− src/Data/Lattice.hs
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module : Data.Lattice--- Copyright : (c) Masahiro Sakai 2012--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : portable------ Type classes for lattices and boolean algebras.--- -------------------------------------------------------------------------------module Data.Lattice- (- -- * Lattice- Lattice (..)- - -- * Boolean algebra- , Complement (..)- , Boolean (..)- , true- , false- , (.&&.)- , (.||.)- , andB- , orB- ) where--infixr 3 .&&.-infixr 2 .||.-infix 1 .=>., .<=>.---- | Type class for lattice.-class Lattice a where- -- | top element- top :: a-- -- | bottom element- bottom :: a-- -- | join- join :: a -> a -> a-- -- | meet- meet :: a -> a -> a-- -- | n-ary join- joinL :: [a] -> a-- -- | n-ary meet- meetL :: [a] -> a-- joinL = foldr join bottom- meetL = foldr meet top---- | types that can be negated.-class Complement a where- notB :: a -> a---- | types that can be combined with boolean operations.-class (Lattice a, Complement a) => Boolean a where- (.=>.), (.<=>.) :: a -> a -> a- x .=>. y = notB x .||. y- x .<=>. y = (x .=>. y) .&&. (y .=>. x)---- | alias of 'top'-true :: Boolean a => a-true = top---- | alias of 'bottom'-false :: Boolean a => a-false = bottom---- | alias of 'meet'-(.&&.) :: Boolean a => a -> a -> a-(.&&.) = meet---- | alias of 'join'-(.||.) :: Boolean a => a -> a -> a-(.||.) = join---- | alias of 'meetL'-andB :: Boolean a => [a] -> a-andB = meetL---- | alias of 'joinL'-orB :: Boolean a => [a] -> a-orB = joinL
− src/Data/Linear.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}-{-# OPTIONS_GHC -Wall #-}--------------------------------------------------------------------------------- |--- Module : Data.Linear--- Copyright : (c) Masahiro Sakai 2011--- License : BSD-style--- --- Maintainer : masahiro.sakai@gmail.com--- Stability : provisional--- Portability : non-portable (MultiParamTypeClasses, FunctionalDependencies)------ Type class of linear spaces.--- --------------------------------------------------------------------------------module Data.Linear- ( Module (..)- , Linear (..)- ) where--import Data.Ratio--infixl 6 .+., .-.-infixl 7 .*., ./.---- | The class of R-modules.-class Num r => Module r a | a -> r where- (.*.) :: r -> a -> a- -- ^ scalar multiplication-- (.+.) :: a -> a -> a- -- ^ addition-- lzero :: a- -- ^ identity of '(.+.)'-- -- | negation- lnegate :: a -> a- lnegate x = (-1) .*. x-- -- | subtraction- (.-.) :: a -> a -> a- a .-. b = a .+. lnegate b-- lsum :: [a] -> a- lsum = foldr (.+.) lzero---- | The class of linear spaces.-class (Module k a, Fractional k) => Linear k a | a -> k where- -- | division- (./.) :: a -> k -> a- a ./. b = (1/b) .*. a--instance Integral a => Module (Ratio a) (Ratio a) where- (.*.) = (*)- (.+.) = (+)- lzero = 0--instance Integral a => Linear (Ratio a) (Ratio a)--instance Module Integer Integer where- (.*.) = (*)- (.+.) = (+)- lzero = 0--instance Module Double Double where- (.*.) = (*)- (.+.) = (+)- lzero = 0--instance Linear Double Double
src/Data/Polyhedron.hs view
@@ -24,14 +24,15 @@ import Data.Ratio import qualified Data.IntSet as IS import qualified Data.Map as Map+import Data.VectorSpace import Prelude hiding (null) +import Algebra.Lattice+ import qualified Data.Interval as Interval-import Data.Expr (Variables (..)) import Data.ArithRel import qualified Data.LA as LA-import Data.Linear-import Data.Lattice+import Data.Var type ExprR = LA.Expr Rational type ExprZ = LA.Expr Integer@@ -50,15 +51,25 @@ vars (Polyhedron m) = IS.unions [vars e | e <- Map.keys m] vars Empty = IS.empty -instance Lattice Polyhedron where- top = univ- bottom = empty- meet = intersection+instance JoinSemiLattice Polyhedron where join Empty b = b join a Empty = a join (Polyhedron m1) (Polyhedron m2) = normalize $ Polyhedron (Map.intersectionWith Interval.join m1 m2) +instance MeetSemiLattice Polyhedron where+ meet = intersection++instance Lattice Polyhedron++instance BoundedJoinSemiLattice Polyhedron where+ bottom = empty ++instance BoundedMeetSemiLattice Polyhedron where+ top = univ++instance BoundedLattice Polyhedron+ normalize :: Polyhedron -> Polyhedron normalize (Polyhedron m) | any Interval.null (Map.elems m) = Empty normalize p = p@@ -94,7 +105,7 @@ let rhs1 = - c * fromIntegral d (lhs2,op2,rhs2) = if p lhs1- then (lnegate lhs1, flipOp op, - rhs1)+ then (negateV lhs1, flipOp op, - rhs1) else (lhs1, op, rhs1) ival = case op of
src/Data/Polynomial.hs view
@@ -1,13 +1,13 @@-{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Polynomial--- Copyright : (c) Masahiro Sakai 2012+-- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional--- Portability : non-portable (ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances)+-- Portability : non-portable (ScopedTypeVariables, TypeFamilies) -- -- Polynomials --@@ -122,8 +122,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IM--import Data.Linear+import Data.VectorSpace {-------------------------------------------------------------------- Polynomial type@@ -147,12 +146,14 @@ signum x = 1 -- OK? fromInteger x = constant (fromInteger x) -instance (Eq k, Num k, Ord v, Show v) => Module k (Polynomial k v) where- k .*. p = constant k * p- p .+. q = p + q- lzero = 0+instance (Eq k, Num k, Ord v, Show v) => AdditiveGroup (Polynomial k v) where+ p ^+^ q = p + q+ zeroV = 0+ negateV = negate -instance (Eq k, Fractional k, Ord v, Show v) => Linear k (Polynomial k v)+instance (Eq k, Num k, Ord v, Show v) => VectorSpace (Polynomial k v) where+ type Scalar (Polynomial k v) = k+ k *^ p = constant k * p instance (Show v, Ord v, Show k) => Show (Polynomial k v) where showsPrec d p = showParen (d > 10) $
src/Data/Polynomial/Sturm.hs view
@@ -34,7 +34,7 @@ import Data.Maybe import Data.Polynomial import qualified Data.Interval as Interval-import Data.Interval (Interval)+import Data.Interval (Interval, EndPoint (..), (<..<=), (<=..<=)) -- | Sturm's chain (Sturm's sequence) type SturmChain = [UPolynomial Rational]@@ -67,10 +67,10 @@ | Interval.null ival2 = 0 | otherwise = case (Interval.lowerBound ival2, Interval.upperBound ival2) of- (Just (in1,lb), Just (in2,ub)) ->+ (Finite lb, Finite ub) -> (if lb==ub then 0 else (n lb - n ub)) +- (if in1 && isRootOf lb p then 1 else 0) +- (if not in2 && isRootOf ub p then -1 else 0)+ (if lb `Interval.member` ival2 && isRootOf lb p then 1 else 0) ++ (if ub `Interval.notMember` ival2 && isRootOf ub p then -1 else 0) _ -> error "numRoots'': should not happen" where ival2 = boundInterval p ival@@ -103,7 +103,7 @@ (s,_) = leadingTerm grlex p boundInterval :: UPolynomial Rational -> Interval Rational -> Interval Rational-boundInterval p ival = Interval.intersection ival (Interval.closedInterval lb ub)+boundInterval p ival = Interval.intersection ival (Finite lb <=..<= Finite ub) where (lb,ub) = bounds p @@ -128,7 +128,7 @@ g (lb,ub) = case n lb - n ub of 0 -> []- 1 -> [Interval.interval (Just (False, lb)) (Just (True, ub))]+ 1 -> [Finite lb <..<= Finite ub] _ -> g (lb, mid) ++ g (mid, ub) where mid = (lb + ub) / 2@@ -144,12 +144,12 @@ | numRoots' chain ivalL > 0 = go ivalL | otherwise = go ivalR -- numRoots' chain ivalR > 0 where- (_,lb) = fromJust $ Interval.lowerBound ival- (_,ub) = fromJust $ Interval.upperBound ival+ Finite lb = Interval.lowerBound ival+ Finite ub = Interval.upperBound ival s = ub - lb mid = (lb + ub) / 2- ivalL = Interval.interval (Interval.lowerBound ival) (Just (True,mid))- ivalR = Interval.interval (Just (False,mid)) (Interval.upperBound ival)+ ivalL = Interval.interval (Interval.lowerBound' ival) (Finite mid, True)+ ivalR = Interval.interval (Finite mid, False) (Interval.upperBound' ival) approx :: UPolynomial Rational -> Interval Rational -> Rational -> Rational approx p = approx' (sturmChain p)
+ src/Data/Var.hs view
@@ -0,0 +1,45 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Var+-- Copyright : (c) Masahiro Sakai 2011-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+-- +-----------------------------------------------------------------------------+module Data.Var+ ( Var+ , VarSet+ , VarMap+ , Variables (..)+ , Model+ ) where++import qualified Data.IntMap as IM+import qualified Data.IntSet as IS+import Data.Ratio++-- ---------------------------------------------------------------------------++-- | Variables are represented as non-negative integers+type Var = Int++-- | Set of variables+type VarSet = IS.IntSet++-- | Map from variables+type VarMap = IM.IntMap++-- | collecting free variables+class Variables a where+ vars :: a -> VarSet++instance Variables a => Variables [a] where+ vars = IS.unions . map vars++-- | A @Model@ is a map from variables to values.+type Model r = VarMap r++-- ---------------------------------------------------------------------------
src/SAT.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}-{-# LANGUAGE BangPatterns, DoAndIfThenElse, DoRec, ScopedTypeVariables, CPP #-}+{-# LANGUAGE BangPatterns, DoAndIfThenElse, DoRec, ScopedTypeVariables, CPP, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : SAT@@ -54,6 +54,7 @@ -- * Solving , solve , solveWith+ , BudgetExceeded (..) -- * Extract results , Model@@ -83,6 +84,7 @@ , setRandomFreq , defaultRandomFreq , setRandomSeed+ , setConfBudget -- * Read state , nVars@@ -115,6 +117,7 @@ import qualified Data.IndexedPriorityQueue as PQ import qualified Data.SeqQueue as SQ import Data.Time+import Data.Typeable import System.CPUTime import qualified System.Random as Rand import Text.Printf@@ -243,6 +246,9 @@ , 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)@@ -280,6 +286,8 @@ , svLearningStrategy :: !(IORef LearningStrategy) , svLogger :: !(IORef (Maybe (String -> IO ())))+ , svStartWC :: !(IORef UTCTime)+ , svLastStatWC :: !(IORef UTCTime) , svCheckModel :: !(IORef Bool) @@ -287,6 +295,8 @@ , svRandomGen :: !(IORef Rand.StdGen) , svFailedAssumptions :: !(IORef [Lit])++ , svConfBudget :: !(IORef Int) } markBad :: Solver -> IO ()@@ -324,6 +334,7 @@ modifyIORef (svTrail solver) (lit:) modifyIORef' (svNAssigns solver) (+1)+ when (lv == levelRoot) $ modifyIORef' (svNFixed solver) (+1) bcpEnqueue solver lit when debugMode $ logIO solver $ do@@ -388,7 +399,7 @@ reduceDB :: Solver -> IO () reduceDB solver = do- (n,cs) <- readIORef (svLearntDB solver)+ (_,cs) <- readIORef (svLearntDB solver) xs <- forM cs $ \c -> do p <- constrIsProtected solver c@@ -414,7 +425,7 @@ let cs2 = zs2 ++ map fst ws n2 = length cs2 - log solver $ printf "learnt constraints deletion: %d -> %d" n n2+ -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2 writeIORef (svLearntDB solver) (n2,cs2) type VarActivity = Double@@ -504,6 +515,9 @@ nconflict <- newIORef 0 nrestart <- newIORef 0 nassigns <- newIORef 0+ nfixed <- newIORef 0+ nlearntgc <- newIORef 0+ nremoved <- newIORef 0 claDecay <- newIORef (1 / 0.999) claInc <- newIORef 1@@ -523,12 +537,16 @@ 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@@ -547,6 +565,9 @@ , svNConflict = nconflict , svNRestart = nrestart , svNAssigns = nassigns+ , svNFixed = nfixed+ , svNLearntGC = nlearntgc+ , svNRemovedConstr = nremoved , svVarDecay = varDecay , svVarInc = varInc , svClaDecay = claDecay@@ -562,10 +583,13 @@ , svLearntLimAdjCnt = learntLimAdjCnt , svLearntLimSeq = learntLimSeq , svLogger = logger+ , svStartWC = startWC+ , svLastStatWC = lastStatWC , svCheckModel = checkModel , svRandomFreq = randfreq , svRandomGen = randgen , svFailedAssumptions = failed+ , svConfBudget = confBudget } return solver @@ -788,6 +812,7 @@ solve_ :: Solver -> IO Bool solve_ solver = do log solver "Solving starts ..."+ resetStat solver writeIORef (svModel solver) Nothing writeIORef (svFailedAssumptions solver) [] @@ -828,21 +853,26 @@ let loop [] = error "solve_: should not happen" loop (conflict_lim:rs) = do+ printStat solver True ret <- search solver conflict_lim onConflict case ret of- Just x -> return x- Nothing -> do+ 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 $ do+ when (result == Just True) $ do checkModel <- readIORef (svCheckModel solver) when checkModel $ checkSatisfied solver constructModel solver@@ -851,6 +881,7 @@ when debugMode $ dumpVarActivity solver when debugMode $ dumpClaActivity 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)@@ -858,12 +889,24 @@ (log solver . printf "#conflict = %d") =<< readIORef (svNConflict solver) (log solver . printf "#restart = %d") =<< readIORef (svNRestart solver) - return result+ case result of+ Just x -> return x+ Nothing -> throw BudgetExceeded -search :: Solver -> Int -> IO () -> IO (Maybe Bool)+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 = loop 0 where- loop :: Int -> IO (Maybe Bool)+ loop :: Int -> IO SearchResult loop !c = do sanityCheck solver conflict <- deduce solver@@ -877,17 +920,19 @@ n <- nLearnt solver m <- nAssigns solver learnt_lim <- readIORef (svLearntLim solver)- when (learnt_lim >= 0 && n - m > learnt_lim) $ reduceDB solver+ when (learnt_lim >= 0 && n - m > learnt_lim) $ do+ modifyIORef' (svNLearntGC solver) (+1)+ reduceDB solver r <- pickAssumption case r of- Nothing -> return (Just False)+ Nothing -> return (SRFinished False) Just lit | lit /= litUndef -> decide solver lit >> loop c | otherwise -> do lit2 <- pickBranchLit solver if lit2 == litUndef- then return (Just True)+ then return (SRFinished True) else decide solver lit2 >> loop c Just constr -> do@@ -902,15 +947,24 @@ str <- showConstraint solver constr return $ printf "conflict(level=%d): %s" d str + when (c `mod` 100 == 0) $ do+ printStat solver False++ modifyIORef' (svConfBudget solver) $ \confBudget ->+ if confBudget > 0 then confBudget - 1 else confBudget+ confBudget <- readIORef (svConfBudget solver)+ if d == levelRoot- then markBad solver >> return (Just False)+ then markBad solver >> return (SRFinished False)+ else if confBudget==0 then+ return SRBudgetExceeded else if conflict_lim >= 0 && c+1 >= conflict_lim then- return Nothing+ return SRRestart else do b <- handleConflict constr if b then loop (c+1)- else markBad solver >> return (Just False)+ else markBad solver >> return (SRFinished False) pickAssumption :: IO (Maybe Lit) pickAssumption = do@@ -1004,7 +1058,6 @@ -- | Simplify the clause database according to the current top-level assigment. simplify :: Solver -> IO () simplify solver = do- xs <- readIORef (svClauseDB solver) let loop [] rs !n = return (rs,n) loop (y:ys) rs !n = do b1 <- isSatisfied solver y@@ -1014,11 +1067,20 @@ detach solver y loop ys rs (n+1) else loop ys (y:rs) n- (ys,n) <- loop xs [] (0::Int)- when (n > 0) $ - log solver $ printf "simplify: %d satisfied constraints are removed" n- writeIORef (svClauseDB solver) ys + -- simplify original constraint DB+ do+ xs <- readIORef (svClauseDB solver)+ (ys,n) <- loop xs [] (0::Int)+ modifyIORef' (svNRemovedConstr solver) (+n)+ writeIORef (svClauseDB solver) ys++ -- simplify learnt constraint DB+ do+ (m,xs) <- readIORef (svLearntDB solver)+ (ys,n) <- loop xs [] (0::Int)+ writeIORef (svLearntDB solver) (m-n, ys)+ {-------------------------------------------------------------------- Parameter settings. --------------------------------------------------------------------}@@ -1104,6 +1166,10 @@ setRandomSeed solver seed = do writeIORef (svRandomGen solver) (Rand.mkStdGen seed) +setConfBudget :: Solver -> Maybe Int -> IO ()+setConfBudget solver (Just b) | b >= 0 = writeIORef (svConfBudget solver) b+setConfBudget solver _ = writeIORef (svConfBudget solver) (-1)+ {-------------------------------------------------------------------- API for implementation of @solve@ --------------------------------------------------------------------}@@ -1515,6 +1581,70 @@ forM_ xs $ \c -> constrRescaleActivity solver c modifyIORef' (svClaInc 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 --------------------------------------------------------------------}@@ -2210,10 +2340,14 @@ 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
src/SAT/Integer.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-} module SAT.Integer ( Expr (..) , newVar@@ -10,10 +10,10 @@ import Control.Monad import Data.Array.IArray+import Data.VectorSpace import Text.Printf import Data.ArithRel-import Data.Linear import qualified SAT import qualified SAT.TseitinEncoder as TseitinEncoder @@ -29,10 +29,14 @@ SAT.addPBAtMost solver xs hi' return $ Expr ((lo,[]) : [(c,[x]) | (c,x) <- xs]) -instance Module Integer Expr where- n .*. Expr xs = Expr [(n*m,lits) | (m,lits) <- xs]- Expr xs1 .+. Expr xs2 = Expr (xs1++xs2)- lzero = Expr []+instance AdditiveGroup Expr where+ Expr xs1 ^+^ Expr xs2 = Expr (xs1++xs2)+ zeroV = Expr []+ negateV = ((-1) *^)++instance VectorSpace Expr where+ type Scalar Expr = Integer+ n *^ Expr xs = Expr [(n*m,lits) | (m,lits) <- xs] instance Num Expr where Expr xs1 + Expr xs2 = Expr (xs1++xs2)
src/SAT/MUS.hs view
@@ -26,7 +26,7 @@ data Options = Options { optLogger :: String -> IO ()- , optUpdater :: [Lit] -> IO ()+ , optUpdateBest :: [Lit] -> IO () , optLitPrinter :: Lit -> String } @@ -35,7 +35,7 @@ defaultOptions = Options { optLogger = \_ -> return ()- , optUpdater = \_ -> return ()+ , optUpdateBest = \_ -> return () , optLitPrinter = show } @@ -58,7 +58,7 @@ log = optLogger opt update :: [Lit] -> IO ()- update = optUpdater opt+ update = optUpdateBest opt showLit :: Lit -> String showLit = optLitPrinter opt
src/SAT/PBO.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE DoAndIfThenElse #-} {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} ----------------------------------------------------------------------------- -- | -- Module : SAT.PBO--- Copyright : (c) Masahiro Sakai 2012+-- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style -- -- Maintainer : masahiro.sakai@gmail.com@@ -14,115 +15,197 @@ ----------------------------------------------------------------------------- module SAT.PBO where +import Control.Exception import Control.Monad import Data.List import Data.Ord import Text.Printf import SAT import SAT.Types+import qualified SAT.PBO.UnsatBased as UnsatBased+import qualified SAT.PBO.MSU4 as MSU4 data SearchStrategy = LinearSearch | BinarySearch--- 'nothaddock' is inserted not to confuse haddock- -- nothaddock | AdaptiveSearch+ | AdaptiveSearch+ | UnsatBased+ | MSU4 data Options = Options { optLogger :: String -> IO ()- , optUpdater :: Model -> Integer -> IO ()+ , optUpdateBest :: Model -> Integer -> IO ()+ , optUpdateLB :: Integer -> IO () , optObjFunVarsHeuristics :: Bool , optSearchStrategy :: SearchStrategy+ , optTrialLimitConf :: Int } defaultOptions :: Options defaultOptions = Options { optLogger = \_ -> return ()- , optUpdater = \_ _ -> return ()+ , optUpdateBest = \_ _ -> return ()+ , optUpdateLB = \_ -> return () , optObjFunVarsHeuristics = True , optSearchStrategy = LinearSearch+ , optTrialLimitConf = 1000 } minimize :: Solver -> [(Integer, Lit)] -> Options -> IO (Maybe Model) minimize solver obj opt = do- when (optObjFunVarsHeuristics opt) $ do- forM_ obj $ \(c,l) -> do- let p = if c > 0 then not (litPolarity l) else litPolarity l- setVarPolarity solver (litVar l) p- forM_ (zip [1..] (map snd (sortBy (comparing fst) [(abs c, l) | (c,l) <- obj]))) $ \(n,l) -> do- replicateM n $ varBumpActivity solver (litVar l)+ when (optObjFunVarsHeuristics opt) $ tweakParams solver obj - result <- solve solver- if not result then- return Nothing- else- case optSearchStrategy opt of- LinearSearch -> liftM Just linSearch- BinarySearch -> liftM Just binSearch+ case optSearchStrategy opt of+ UnsatBased -> do+ let opt2 = UnsatBased.defaultOptions+ { UnsatBased.optLogger = optLogger opt+ , UnsatBased.optUpdateBest = optUpdateBest opt+ , UnsatBased.optUpdateLB = optUpdateLB opt+ }+ UnsatBased.solve solver obj opt2+ MSU4 -> do+ let opt2 = MSU4.defaultOptions+ { MSU4.optLogger = optLogger opt+ , MSU4.optUpdateBest = optUpdateBest opt+ , MSU4.optUpdateLB = optUpdateLB opt+ }+ MSU4.solve solver obj opt2+ _ -> do+ updateLB (pbLowerBound obj)+ result <- solve solver+ if not result then+ return Nothing+ else+ case optSearchStrategy opt of+ LinearSearch -> liftM Just linSearch+ BinarySearch -> liftM Just binSearch+ AdaptiveSearch -> liftM Just adaptiveSearch+ _ -> error "SAT.PBO.minimize: should not happen" where- logIO :: String -> IO ()- logIO = optLogger opt+ logIO :: String -> IO ()+ logIO = optLogger opt - update :: Model -> Integer -> IO ()- update = optUpdater opt+ updateBest :: Model -> Integer -> IO ()+ updateBest = optUpdateBest opt - linSearch :: IO Model- linSearch = do- m <- model solver- let v = pbEval m obj- update m v- addPBAtMost solver obj (v - 1)- result <- solve solver- if result- then linSearch- else return m+ updateLB :: Integer -> IO ()+ updateLB = optUpdateLB opt - binSearch :: IO Model- binSearch = do-{-- logIO $ printf "Binary Search: minimizing %s \n" $ - intercalate " "- [c' ++ " " ++ l'- | (c,l) <- obj- , let c' = if c < 0 then show c else "+" ++ show c- , let l' = (if l < 0 then "~" else "") ++ "x" ++ show (litVar l)- ]--}- m0 <- model solver- let v0 = pbEval m0 obj- update m0 v0- let ub0 = v0 - 1- lb0 = pbLowerBound obj- addPBAtMost solver obj ub0+ linSearch :: IO Model+ linSearch = do+ m <- model solver+ let v = pbEval m obj+ updateBest m v+ addPBAtMost solver obj (v - 1)+ result <- solve solver+ if result+ then linSearch+ else return m - let loop lb ub m | ub < lb = return m- loop lb ub m = do- let mid = (lb + ub) `div` 2- logIO $ printf "Binary Search: %d <= obj <= %d; guessing obj <= %d" lb ub mid- sel <- newVar solver- addPBAtMostSoft solver sel obj mid- ret <- solveWith solver [sel]- if ret- then do- m2 <- model solver- let v = pbEval m2 obj- update m2 v- -- deactivating temporary constraint- -- FIXME: 本来は制約の削除をしたい- addClause solver [-sel]- let ub' = v - 1- logIO $ printf "Binary Search: updating upper bound: %d -> %d" ub ub'- addPBAtMost solver obj ub'- loop lb ub' m2- else do- -- deactivating temporary constraint- -- FIXME: 本来は制約の削除をしたい- addClause solver [-sel]- let lb' = mid + 1- logIO $ printf "Binary Search: updating lower bound: %d -> %d" lb lb'- addPBAtLeast solver obj lb'- loop lb' ub m+ binSearch :: IO Model+ binSearch = do+ m0 <- model solver+ let v0 = pbEval m0 obj+ updateBest m0 v0+ let ub0 = v0 - 1+ lb0 = pbLowerBound obj+ addPBAtMost solver obj ub0+ loop lb0 ub0 m0+ where+ loop lb ub m | ub < lb = return m+ loop lb ub m = do+ let mid = (lb + ub) `div` 2+ logIO $ printf "Binary Search: %d <= obj <= %d; guessing obj <= %d" lb ub mid+ sel <- newVar solver+ addPBAtMostSoft solver sel obj mid+ ret <- solveWith solver [sel]+ if ret then do+ m2 <- model solver+ let v = pbEval m2 obj+ updateBest m2 v+ -- deleting temporary constraint+ -- ただし、これに依存した補題を活かすためには残したほうが良い?+ addClause solver [-sel]+ let ub' = v - 1+ logIO $ printf "Binary Search: updating upper bound: %d -> %d" ub ub'+ addPBAtMost solver obj ub'+ loop lb ub' m2+ else do+ -- deleting temporary constraint+ addClause solver [-sel]+ let lb' = mid + 1+ updateLB lb'+ logIO $ printf "Binary Search: updating lower bound: %d -> %d" lb lb'+ addPBAtLeast solver obj lb'+ loop lb' ub m - loop lb0 ub0 m0+ -- adaptive search strategy from pbct-0.1.3 <http://www.residual.se/pbct/>+ adaptiveSearch :: IO Model+ adaptiveSearch = do+ m0 <- model solver+ let v0 = pbEval m0 obj+ updateBest m0 v0+ let ub0 = v0 - 1+ lb0 = pbLowerBound obj+ addPBAtMost solver obj ub0+ loop lb0 ub0 (0::Rational) m0+ where+ loop lb ub _ m | ub < lb = return m+ loop lb ub fraction m = do+ let interval = ub - lb+ mid = ub - floor (fromIntegral interval * fraction)+ if ub == mid then do+ logIO $ printf "Adaptive Search: %d <= obj <= %d" lb ub+ result <- solve solver+ if result then do+ m2 <- model solver+ let v = pbEval m2 obj+ updateBest m2 v+ let ub' = v - 1+ fraction' = min 0.5 (fraction + 0.1)+ loop lb ub' fraction' m2+ else+ return m+ else do+ logIO $ printf "Adaptive Search: %d <= obj <= %d; guessing obj <= %d" lb ub mid+ sel <- newVar solver+ addPBAtMostSoft solver sel obj mid+ setConfBudget solver $ Just (optTrialLimitConf opt)+ ret' <- try $ solveWith solver [sel]+ setConfBudget solver Nothing+ case ret' of+ Left BudgetExceeded -> do+ let fraction' = max 0 (fraction - 0.05)+ loop lb ub fraction' m+ Right ret -> do+ let fraction' = min 0.5 (fraction + 0.1)+ if ret then do+ m2 <- model solver+ let v = pbEval m2 obj+ updateBest m2 v+ -- deleting temporary constraint+ -- ただし、これに依存した補題を活かすためには残したほうが良い?+ addClause solver [-sel]+ let ub' = v - 1+ logIO $ printf "Adaptive Search: updating upper bound: %d -> %d" ub ub'+ addPBAtMost solver obj ub'+ loop lb ub' fraction' m2+ else do+ -- deleting temporary constraint+ addClause solver [-sel]+ let lb' = mid + 1+ updateLB lb'+ logIO $ printf "Adaptive Search: updating lower bound: %d -> %d" lb lb'+ addPBAtLeast solver obj lb'+ loop lb' ub fraction' m++tweakParams :: Solver -> [(Integer, Lit)] -> IO ()+tweakParams solver obj = do+ forM_ obj $ \(c,l) -> do+ let p = if c > 0 then not (litPolarity l) else litPolarity l+ setVarPolarity solver (litVar l) p+ forM_ (zip [1..] (map snd (sortBy (comparing fst) [(abs c, l) | (c,l) <- obj]))) $ \(n,l) -> do+ replicateM n $ varBumpActivity solver (litVar l)
+ src/SAT/PBO/MSU4.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DoAndIfThenElse #-}+{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}+-----------------------------------------------------------------------------+-- |+-- Module : SAT.PBO.MSU4+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+-- +-- Reference:+--+-- * João P. Marques-Silva and Jordi Planes.+-- Algorithms for Maximum Satisfiability using Unsatisfiable Cores.+-- In Design, Automation and Test in Europe, 2008 (DATE '08). March 2008.+-- pp. 408-413, doi:10.1109/date.2008.4484715.+-- <http://dx.doi.org/10.1109/date.2008.4484715>+-- <http://eprints.soton.ac.uk/265000/1/jpms-date08.pdf>+-- <http://www.csi.ucd.ie/staff/jpms/talks/talksite/jpms-date08.pdf>+--+-----------------------------------------------------------------------------+module SAT.PBO.MSU4+ ( Options (..)+ , defaultOptions+ , solve+ , solveWBO+ ) where++import qualified Data.IntSet as IS+import qualified Data.IntMap as IM+import qualified SAT as SAT+import SAT.Types++import Text.Printf++data Options+ = Options+ { optLogger :: String -> IO ()+ , optUpdateBest :: SAT.Model -> Integer -> IO ()+ , optUpdateLB :: Integer -> IO ()+ }++defaultOptions :: Options+defaultOptions+ = Options+ { optLogger = \_ -> return ()+ , optUpdateBest = \_ _ -> return ()+ , optUpdateLB = \_ -> return ()+ }++solve :: SAT.Solver -> [(Integer, SAT.Lit)] -> Options -> IO (Maybe SAT.Model)+solve solver obj opt = do+ result <- solveWBO solver [(-v, c) | (c,v) <- obj'] opt'+ case result of+ Nothing -> return Nothing+ Just (m,_) -> return (Just m)+ where+ (obj',offset) = normalizePBSum (obj,0)+ opt' =+ opt+ { optUpdateBest = \m val -> optUpdateBest opt m (offset + val)+ , optUpdateLB = \val -> optUpdateLB opt (offset + val)+ }++solveWBO :: SAT.Solver -> [(Lit, Integer)] -> Options -> IO (Maybe (SAT.Model, Integer))+solveWBO solver sels opt = do+ optUpdateLB opt 0+ loop (IM.keysSet weights) IS.empty 0 Nothing++ where+ weights = IM.fromList sels+ + loop :: IS.IntSet -> IS.IntSet -> Integer -> Maybe (SAT.Model, Integer) -> IO (Maybe (SAT.Model, Integer))+ loop unrelaxed relaxed lb best = do+ ret <- SAT.solveWith solver (IS.toList unrelaxed)+ if ret then do+ currModel <- SAT.model solver+ let violated = [weights IM.! l | l <- IS.toList relaxed, evalLit currModel l == False]+ currVal = sum violated+ best' <-+ case best of+ Just (_, bestVal)+ | currVal < bestVal -> do+ optUpdateBest opt currModel currVal+ return $ Just (currModel, currVal)+ | otherwise -> do+ return best+ Nothing -> do+ optUpdateBest opt currModel currVal+ return $ Just (currModel, currVal)+ SAT.addPBAtMost solver [(c,-l) | (l,c) <- sels] (currVal - 1)+ cont unrelaxed relaxed lb best'+ else do+ core <- SAT.failedAssumptions solver+ let ls = IS.fromList core `IS.intersection` unrelaxed+ if IS.null ls then do+ return best+ else do+ SAT.addAtLeast solver [-l | l <- IS.toList ls] 1+ let lb' = lb + minimum [weights IM.! l | l <- IS.toList ls]+ optUpdateLB opt lb'+ cont (unrelaxed `IS.difference` ls) (relaxed `IS.union` ls) lb' best++ cont :: IS.IntSet -> IS.IntSet -> Integer -> Maybe (SAT.Model, Integer) -> IO (Maybe (SAT.Model, Integer))+ cont _ _ lb best@(Just (_, bestVal)) | lb == bestVal = return best+ cont unrelaxed relaxed lb best = loop unrelaxed relaxed lb best
+ src/SAT/PBO/UnsatBased.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}+{-# OPTIONS_GHC -Wall #-}+-----------------------------------------------------------------------------+-- |+-- Module : SAT.PBO.UnsatBased+-- Copyright : (c) Masahiro Sakai 2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : non-portable+--+-----------------------------------------------------------------------------+module SAT.PBO.UnsatBased+ ( Options (..)+ , defaultOptions+ , solve+ , solveWBO+ ) where++import Control.Monad+import qualified Data.IntMap as IM+import qualified SAT as SAT+import qualified SAT.Types as SAT++data Options+ = Options+ { optLogger :: String -> IO ()+ , optUpdateBest :: SAT.Model -> Integer -> IO ()+ , optUpdateLB :: Integer -> IO ()+ }++defaultOptions :: Options+defaultOptions+ = Options+ { optLogger = \_ -> return ()+ , optUpdateBest = \_ _ -> return ()+ , optUpdateLB = \_ -> return ()+ }++solve :: SAT.Solver -> [(Integer, SAT.Lit)] -> Options -> IO (Maybe SAT.Model)+solve solver obj opt = do+ result <- solveWBO solver [(-v, c) | (c,v) <- obj'] opt'+ case result of+ Nothing -> return Nothing+ Just (m,_) -> return (Just m)+ where+ (obj',offset) = SAT.normalizePBSum (obj,0)+ opt' =+ opt+ { optUpdateBest = \m val -> optUpdateBest opt m (offset + val)+ , optUpdateLB = \val -> optUpdateLB opt (offset + val)+ }++solveWBO :: SAT.Solver -> [(SAT.Lit, Integer)] -> Options -> IO (Maybe (SAT.Model, Integer))+solveWBO solver sels0 opt = loop 0 (IM.fromList sels0)+ where+ loop :: Integer -> IM.IntMap Integer -> IO (Maybe (SAT.Model, Integer))+ loop !lb sels = do+ optUpdateLB opt lb++ ret <- SAT.solveWith solver (IM.keys sels)+ if ret+ then do+ m <- SAT.model solver+ -- 余計な変数を除去する?+ optUpdateBest opt m lb+ return $ Just (m, lb)+ else do+ core <- SAT.failedAssumptions solver+ case core of+ [] -> return Nothing+ _ -> do+ let !min_c = minimum [sels IM.! sel | sel <- core]+ !lb' = lb + min_c++ xs <- forM core $ \sel -> do+ r <- SAT.newVar solver+ return (sel, r)+ SAT.addAtMost solver (map snd xs) 1+ SAT.addClause solver [-l | l <- core] -- optional constraint but sometimes useful++ ys <- liftM IM.unions $ forM xs $ \(sel, r) -> do+ s <- SAT.newVar solver+ SAT.addClause solver [-s, r, sel]+ let c = sels IM.! sel+ if c > min_c+ then return $ IM.fromList [(s, min_c), (sel, c - min_c)]+ else return $ IM.singleton s min_c+ let sels' = IM.union ys (IM.difference sels (IM.fromList [(sel, ()) | sel <- core]))++ loop lb' sels'
src/SAT/Types.hs view
@@ -30,6 +30,7 @@ , normalizeAtLeast -- * Pseudo Boolean Constraint+ , normalizePBSum , normalizePBAtLeast , normalizePBExactly , cutResolve@@ -130,13 +131,10 @@ lits' = xs `IS.difference` ys n' = n - (IS.size ys `div` 2) --- | normalizing PB constraint of the form /c1 x1 + c2 cn ... cn xn >= b/.-normalizePBAtLeast :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)-normalizePBAtLeast a =- case step2 $ step1 $ a of- (xs,n)- | n > 0 -> step3 (saturate n xs, n)- | otherwise -> ([], 0) -- trivially true+-- | normalizing PB term of the form /c1 x1 + c2 x2 ... cn xn + c/ into+-- /d1 x1 + d2 x2 ... dm xm + d/ where d1,...,dm ≥ 1.+normalizePBSum :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)+normalizePBSum = step2 . step1 where -- 同じ変数が複数回現れないように、一度全部 @v@ に統一。 step1 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)@@ -149,7 +147,7 @@ loop (ys,m) ((c,l):zs) = if litPolarity l then loop (IM.insertWith (+) l c ys, m) zs- else loop (IM.insertWith (+) (litNot l) (negate c) ys, m-c) zs+ else loop (IM.insertWith (+) (litNot l) (negate c) ys, m+c) zs -- 係数が0のものも取り除き、係数が負のリテラルを反転することで、 -- 係数が正になるようにする。@@ -159,9 +157,22 @@ loop (ys,m) [] = (ys,m) loop (ys,m) (t@(c,l):zs) | c == 0 = loop (ys,m) zs- | c < 0 = loop ((negate c,litNot l):ys, m-c) zs+ | c < 0 = loop ((negate c,litNot l):ys, m+c) zs | otherwise = loop (t:ys,m) zs +-- | normalizing PB constraint of the form /c1 x1 + c2 cn ... cn xn >= b/.+normalizePBAtLeast :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)+normalizePBAtLeast a =+ case step1 a of+ (xs,n)+ | n > 0 -> step3 (saturate n xs, n)+ | otherwise -> ([], 0) -- trivially true+ where+ step1 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)+ step1 (xs,n) =+ case normalizePBSum (xs,-n) of+ (ys,m) -> (ys, -m)+ -- degree以上の係数はそこで抑える。 saturate :: Integer -> [(Integer,Lit)] -> [(Integer,Lit)] saturate n xs = [assert (c>0) (min n c, l) | (c,l) <- xs]@@ -176,39 +187,20 @@ -- | normalizing PB constraint of the form /c1 x1 + c2 cn ... cn xn = b/. normalizePBExactly :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer) normalizePBExactly a =- case step2 $ step1 $ a of+ case step1 $ a of (xs,n)- | n >= 0 -> step3 (xs, n)+ | n >= 0 -> step2 (xs, n) | otherwise -> ([], 1) -- false where- -- 同じ変数が複数回現れないように、一度全部 @v@ に統一。 step1 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer) step1 (xs,n) =- case loop (IM.empty,n) xs of- (ys,n') -> ([(c,v) | (v,c) <- IM.toList ys], n')- where- loop :: (VarMap Integer, Integer) -> [(Integer,Lit)] -> (VarMap Integer, Integer)- loop (ys,m) [] = (ys,m)- loop (ys,m) ((c,l):zs) =- if litPolarity l- then loop (IM.insertWith (+) l c ys, m) zs- else loop (IM.insertWith (+) (litNot l) (negate c) ys, m-c) zs-- -- 係数が0のものも取り除き、係数が負のリテラルを反転することで、- -- 係数が正になるようにする。- step2 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)- step2 (xs,n) = loop ([],n) xs- where- loop (ys,m) [] = (ys,m)- loop (ys,m) (t@(c,l):zs)- | c == 0 = loop (ys,m) zs- | c < 0 = loop ((negate c,litNot l):ys, m-c) zs- | otherwise = loop (t:ys,m) zs+ case normalizePBSum (xs,-n) of+ (ys,m) -> (ys, -m) -- omega test と同様の係数の gcd による単純化- step3 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)- step3 ([],n) = ([],n)- step3 (xs,n)+ step2 :: ([(Integer,Lit)], Integer) -> ([(Integer,Lit)], Integer)+ step2 ([],n) = ([],n)+ step2 (xs,n) | n `mod` d == 0 = ([(c `div` d, l) | (c,l) <- xs], n `div` d) | otherwise = ([], 1) -- false where
src/Text/GCNF.hs view
@@ -27,6 +27,7 @@ ) where import qualified SAT.Types as SAT+import Text.Util data GCNF = GCNF@@ -77,15 +78,15 @@ parseLine s = case words s of (('{':w):xs) ->- let ys = map read $ init xs- idx = read $ init w+ let ys = map readInt $ init xs+ idx = readInt $ init w in seq idx $ seqList ys $ (idx, ys) _ -> error "parse error" parseCNFLine :: String -> SAT.Clause parseCNFLine s = seq xs $ seqList xs $ xs where- xs = init (map read (words s))+ xs = init (map readInt (words s)) seqList :: [a] -> b -> b seqList [] b = b
src/Text/MaxSAT.hs view
@@ -26,6 +26,7 @@ ) where import qualified SAT.Types as SAT +import Text.Util data WCNF = WCNF @@ -83,16 +84,17 @@ parseWCNFLine :: String -> WeightedClause parseWCNFLine s = - case map read (words s) of + case words s of (w:xs) -> - let ys = map fromIntegral $ init xs - in seq w $ seqList ys $ (w, ys) + let w' = readUnsignedInteger w + ys = map readInt $ init xs + in seq w' $ seqList ys $ (w', ys) _ -> error "parse error" parseCNFLine :: String -> WeightedClause parseCNFLine s = seq xs $ seqList xs $ (1, xs) where - xs = init (map read (words s)) + xs = init (map readInt (words s)) seqList :: [a] -> b -> b seqList [] b = b
src/Text/PBFile.hs view
@@ -59,6 +59,7 @@ import Data.Word import Control.Exception (assert) import Text.Printf+import Text.Util -- | Pair of /objective function/ and a list of constraints. type Formula = (Maybe Sum, [Constraint])@@ -171,42 +172,6 @@ ds <- many1 digit return $! readUnsignedInteger ds --- | 'read' allocate too many intermediate 'Integer'.--- Therefore we use this optimized implementation instead.--- Many intermediate values in this implementation will be optimized--- away by worker-wrapper transformation and unboxing.-readUnsignedInteger :: String -> Integer -readUnsignedInteger str = assert (result == read str) $ result- where- result :: Integer- result = go 0 str-- lim :: Word- lim = maxBound `div` 10- - go :: Integer -> [Char] -> Integer - go !r [] = r- go !r ds =- case go2 0 1 ds of- (r2,b,ds2) -> go (r * fromIntegral b + fromIntegral r2) ds2-- go2 :: Word -> Word -> [Char] -> (Word, Word, [Char])- go2 !r !b dds | assert (b > r) (b > lim) = (r,b,dds)- go2 !r !b [] = (r, b, [])- go2 !r !b (d:ds) = go2 (r*10 + charToWord d) (b*10) ds-- charToWord :: Char -> Word- charToWord '0' = 0- charToWord '1' = 1- charToWord '2' = 2- charToWord '3' = 3- charToWord '4' = 4- charToWord '5' = 5- charToWord '6' = 6- charToWord '7' = 7- charToWord '8' = 8- charToWord '9' = 9- -- <relational_operator>::= ">=" | "=" relational_operator :: Parser Op relational_operator = (string ">=" >> return Ge) <|> (string "=" >> return Eq)@@ -335,7 +300,7 @@ size = showString (printf "* #variable= %d #constraint= %d\n" nv nc) part1 = case top of- Nothing -> showString "soft: "+ Nothing -> showString "soft: ;\n" Just t -> showString "soft: " . showsPrec 0 t . showString ";\n" part2 = foldr (.) id (map showSoftConstraint cs)
+ src/Text/Util.hs view
@@ -0,0 +1,79 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.Util+-- Copyright : (c) Masahiro Sakai 2012-2013+-- License : BSD-style+-- +-- Maintainer : masahiro.sakai@gmail.com+-- Stability : provisional+-- Portability : portable+--+-----------------------------------------------------------------------------+module Text.Util+ ( readInt+ , readUnsignedInteger+ ) where++import Control.Exception+import Data.Word++{-# INLINABLE readInt #-}+readInt :: String -> Int+readInt ('-':str) = - readUnsignedInt str+readInt str = readUnsignedInt str++{-# INLINABLE readUnsignedInt #-}+readUnsignedInt :: String -> Int+readUnsignedInt str = go 0 str+ where+ go !r [] = r+ go !r (c:cs) = go (r*10 + charToInt c) cs++ charToInt :: Char -> Int+ charToInt '0' = 0+ charToInt '1' = 1+ charToInt '2' = 2+ charToInt '3' = 3+ charToInt '4' = 4+ charToInt '5' = 5+ charToInt '6' = 6+ charToInt '7' = 7+ charToInt '8' = 8+ charToInt '9' = 9++-- | 'read' allocate too many intermediate 'Integer'.+-- Therefore we use this optimized implementation instead.+-- Many intermediate values in this implementation will be optimized+-- away by worker-wrapper transformation and unboxing.+{-# INLINABLE readUnsignedInteger #-}+readUnsignedInteger :: String -> Integer +readUnsignedInteger str = assert (result == read str) $ result+ where+ result :: Integer+ result = go 0 str++ lim :: Word+ lim = maxBound `div` 10+ + go :: Integer -> [Char] -> Integer + go !r [] = r+ go !r ds =+ case go2 0 1 ds of+ (r2,b,ds2) -> go (r * fromIntegral b + fromIntegral r2) ds2++ go2 :: Word -> Word -> [Char] -> (Word, Word, [Char])+ go2 !r !b dds | assert (b > r) (b > lim) = (r,b,dds)+ go2 !r !b [] = (r, b, [])+ go2 !r !b (d:ds) = go2 (r*10 + charToWord d) (b*10) ds++ charToWord :: Char -> Word+ charToWord '0' = 0+ charToWord '1' = 1+ charToWord '2' = 2+ charToWord '3' = 3+ charToWord '4' = 4+ charToWord '5' = 5+ charToWord '6' = 6+ charToWord '7' = 7+ charToWord '8' = 8+ charToWord '9' = 9
src/Version.hs view
@@ -26,6 +26,9 @@ #ifdef VERSION_containers , ("containers", VERSION_containers ) #endif+#ifdef VERSION_data_interval+ , ("data-interval",VERSION_data_interval)+#endif #ifdef VERSION_deepseq , ("deepseq", VERSION_deepseq ) #endif@@ -64,6 +67,9 @@ #endif #ifdef VERSION_unbounded_delays , ("unbounded-delays", VERSION_unbounded_delays)+#endif+#ifdef VERSION_vector_space+ , ("vector-space", VERSION_vector_space) #endif #ifdef VERSION_logic_TPTP , ("logic-TPTP", VERSION_logic_TPTP )
test/TestContiTraverso.hs view
@@ -4,7 +4,9 @@ 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 Data.VectorSpace import Test.HUnit hiding (Test) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.TH@@ -13,27 +15,27 @@ import Algorithm.ContiTraverso import Data.ArithRel-import Data.Linear import qualified Data.LA as LA import Data.OptDir import Data.Polynomial -- http://madscientist.jp/~ikegami/articles/IntroSequencePolynomial.html -- optimum is (3,2,0)-case_ikegami = solve grlex OptMin obj cs @?= Just (IM.fromList [(1,3),(2,2),(3,0)])+case_ikegami = solve grlex (IS.fromList vs) OptMin obj cs @?= Just (IM.fromList [(1,3),(2,2),(3,0)]) where- [x,y,z] = map LA.var [1..3]- cs = [ 2.*.x .+. 2.*.y .+. 2.*.z .==. LA.constant 10- , 3.*.x .+. y .+. z .==. LA.constant 11+ vs = [1..3]+ [x,y,z] = map LA.var vs+ cs = [ 2*^x ^+^ 2*^y ^+^ 2*^z .==. LA.constant 10+ , 3*^x ^+^ y ^+^ z .==. LA.constant 11 , x .>=. LA.constant 0 , y .>=. LA.constant 0 , z .>=. LA.constant 0 ]- obj = x .+. 2.*.y .+. 3.*.z+ obj = x ^+^ 2*^y ^+^ 3*^z -case_ikegami' = solve' grlex obj cs @?= Just (IM.fromList [(1,3),(2,2),(3,0)])+case_ikegami' = solve' grlex (IS.fromList vs) obj cs @?= Just (IM.fromList [(1,3),(2,2),(3,0)]) where- [x,y,z] = [1..3]+ vs@[x,y,z] = [1..3] cs = [ (LA.fromTerms [(2,x),(2,y),(2,z)], 10) , (LA.fromTerms [(3,x),(1,y),(1,z)], 11) ]@@ -41,19 +43,20 @@ -- http://posso.dm.unipi.it/users/traverso/conti-traverso-ip.ps -- optimum is (39, 75, 1, 8, 122)-disabled_case_test1 = solve grlex OptMin obj cs @?= Just (IM.fromList [(1,39), (2,75), (3,1), (4,8), (5,122)])+disabled_case_test1 = solve grlex (IS.fromList vs) OptMin obj cs @?= Just (IM.fromList [(1,39), (2,75), (3,1), (4,8), (5,122)]) where- vs@[x1,x2,x3,x4,x5] = map LA.var [1..5]- cs = [ 2.*.x1 .+. 5.*.x2 .-. 3.*.x3 .+. x4 .-. 2.*.x5 .==. LA.constant 214- , x1 .+. 7.*.x2 .+. 2.*.x3 .+. 3.*.x4 .+. x5 .==. LA.constant 712- , 4.*.x1 .-. 2.*.x2 .-. x3 .-. 5.*.x4 .+. 3.*.x5 .==. LA.constant 331+ vs = [1..5]+ vs2@[x1,x2,x3,x4,x5] = map LA.var vs+ cs = [ 2*^x1 ^+^ 5*^x2 ^-^ 3*^x3 ^+^ x4 ^-^ 2*^x5 .==. LA.constant 214+ , x1 ^+^ 7*^x2 ^+^ 2*^x3 ^+^ 3*^x4 ^+^ x5 .==. LA.constant 712+ , 4*^x1 ^-^ 2*^x2 ^-^ x3 ^-^ 5*^x4 ^+^ 3*^x5 .==. LA.constant 331 ] ++- [ v .>=. LA.constant 0 | v <- vs ]- obj = x1 .+. x2 .+. x3 .+. x4 .+. x5+ [ v .>=. LA.constant 0 | v <- vs2 ]+ obj = x1 ^+^ x2 ^+^ x3 ^+^ x4 ^+^ x5 -disabled_case_test1' = solve' grlex obj cs @?= Just (IM.fromList [(1,39), (2,75), (3,1), (4,8), (5,122)])+disabled_case_test1' = solve' grlex (IS.fromList vs) obj cs @?= Just (IM.fromList [(1,39), (2,75), (3,1), (4,8), (5,122)]) where- [x1,x2,x3,x4,x5] = [1..5]+ vs@[x1,x2,x3,x4,x5] = [1..5] cs = [ (LA.fromTerms [(2, x1), ( 5, x2), (-3, x3), ( 1,x4), (-2, x5)], 214) , (LA.fromTerms [(1, x1), ( 7, x2), ( 2, x3), ( 3,x4), ( 1, x5)], 712) , (LA.fromTerms [(4, x1), (-2, x2), (-1, x3), (-5,x4), ( 3, x5)], 331)@@ -61,30 +64,32 @@ obj = LA.fromTerms [(1,x1),(1,x2),(1,x3),(1,x4),(1,x5)] -- optimum is (0,2,2)-case_test2 = solve grlex OptMin obj cs @?= Just (IM.fromList [(1,0),(2,2),(3,2)])+case_test2 = solve grlex (IS.fromList vs) OptMin obj cs @?= Just (IM.fromList [(1,0),(2,2),(3,2)]) where- vs@[x1,x2,x3] = map LA.var [1..3]- cs = [ 2.*.x1 .+. 3.*.x2 .-. x3 .==. LA.constant 4 ] ++- [ v .>=. LA.constant 0 | v <- vs ]- obj = 2.*.x1 .+. x2+ vs = [1..3]+ vs2@[x1,x2,x3] = map LA.var vs+ cs = [ 2*^x1 ^+^ 3*^x2 ^-^ x3 .==. LA.constant 4 ] +++ [ v .>=. LA.constant 0 | v <- vs2 ]+ obj = 2*^x1 ^+^ x2 -case_test2' = solve' grlex obj cs @?= Just (IM.fromList [(1,0),(2,2),(3,2)])+case_test2' = solve' grlex (IS.fromList vs) obj cs @?= Just (IM.fromList [(1,0),(2,2),(3,2)]) where- [x1,x2,x3] = [1..3]+ vs@[x1,x2,x3] = [1..3] cs = [ (LA.fromTerms [(2, x1), (3, x2), (-1, x3)], 4) ] obj = LA.fromTerms [(2,x1),(1,x2)] -- infeasible-case_test3 = solve grlex OptMin obj cs @?= Nothing+case_test3 = solve grlex (IS.fromList vs) OptMin obj cs @?= Nothing where- vs@[x1,x2,x3] = map LA.var [1..3]- cs = [ 2.*.x1 .+. 2.*.x2 .+. 2.*.x3 .==. LA.constant 3 ] ++- [ v .>=. LA.constant 0 | v <- vs ]+ vs = [1..3]+ vs2@[x1,x2,x3] = map LA.var vs+ cs = [ 2*^x1 ^+^ 2*^x2 ^+^ 2*^x3 .==. LA.constant 3 ] +++ [ v .>=. LA.constant 0 | v <- vs2 ] obj = x1 -case_test3' = solve' grlex obj cs @?= Nothing+case_test3' = solve' grlex (IS.fromList vs) obj cs @?= Nothing where- [x1,x2,x3] = [1..3]+ vs@[x1,x2,x3] = [1..3] cs = [ (LA.fromTerms [(2, x1), (2, x2), (2, x3)], 3) ] obj = LA.fromTerms [(1,x1)]
− test/TestInterval.hs
@@ -1,469 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--import Data.Maybe-import Data.Ratio-import Test.HUnit hiding (Test)-import Test.QuickCheck-import Test.Framework (Test, defaultMain, testGroup)-import Test.Framework.TH-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2--import Data.Linear-import Data.Interval (Interval, (<!), (<=!), (==!), (>=!), (>!), (<?), (<=?), (==?), (>=?), (>?))-import qualified Data.Interval as Interval--{--------------------------------------------------------------------- empty---------------------------------------------------------------------}--prop_empty_is_bottom =- forAll intervals $ \a ->- Interval.isSubsetOf Interval.empty a--prop_null_empty =- forAll intervals $ \a ->- Interval.null a == (a == Interval.empty)--case_null_empty =- Interval.null (Interval.empty :: Interval Rational) @?= True--{--------------------------------------------------------------------- univ---------------------------------------------------------------------}--prop_univ_is_top =- forAll intervals $ \a ->- Interval.isSubsetOf a Interval.univ--case_nonnull_top =- Interval.null (Interval.univ :: Interval Rational) @?= False--{--------------------------------------------------------------------- singleton---------------------------------------------------------------------}--prop_singleton_member =- forAll arbitrary $ \r ->- Interval.member (r::Rational) (Interval.singleton r)--prop_singleton_member_intersection =- forAll intervals $ \a ->- forAll arbitrary $ \r ->- let b = Interval.singleton r- in Interval.member (r::Rational) a- ==> Interval.intersection a b == b--prop_singleton_nonnull =- forAll arbitrary $ \r1 ->- not $ Interval.null $ Interval.singleton (r1::Rational)--prop_distinct_singleton_intersection =- forAll arbitrary $ \r1 ->- forAll arbitrary $ \r2 ->- (r1::Rational) /= r2 ==>- Interval.intersection (Interval.singleton r1) (Interval.singleton r2)- == Interval.empty--{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--prop_intersection_comm =- forAll intervals $ \a ->- forAll intervals $ \b ->- Interval.intersection a b == Interval.intersection b a--prop_intersection_assoc =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- Interval.intersection a (Interval.intersection b c) ==- Interval.intersection (Interval.intersection a b) c--prop_intersection_unitL =- forAll intervals $ \a ->- Interval.intersection Interval.univ a == a--prop_intersection_unitR =- forAll intervals $ \a ->- Interval.intersection a Interval.univ == a--prop_intersection_empty =- forAll intervals $ \a ->- Interval.intersection a Interval.empty == Interval.empty--prop_intersection_isSubsetOf =- forAll intervals $ \a ->- forAll intervals $ \b ->- Interval.isSubsetOf (Interval.intersection a b) a--prop_intersection_isSubsetOf_equiv =- forAll intervals $ \a ->- forAll intervals $ \b ->- (Interval.intersection a b == a)- == Interval.isSubsetOf a b--{--------------------------------------------------------------------- Join---------------------------------------------------------------------}--prop_join_comm =- forAll intervals $ \a ->- forAll intervals $ \b ->- Interval.join a b == Interval.join b a--prop_join_assoc =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- Interval.join a (Interval.join b c) ==- Interval.join (Interval.join a b) c--prop_join_unitL =- forAll intervals $ \a ->- Interval.join Interval.empty a == a--prop_join_unitR =- forAll intervals $ \a ->- Interval.join a Interval.empty == a--prop_join_univ =- forAll intervals $ \a ->- Interval.join a Interval.univ == Interval.univ--prop_join_isSubsetOf =- forAll intervals $ \a ->- forAll intervals $ \b ->- Interval.isSubsetOf a (Interval.join a b)--prop_join_isSubsetOf_equiv =- forAll intervals $ \a ->- forAll intervals $ \b ->- (Interval.join a b == b)- == Interval.isSubsetOf a b--{--------------------------------------------------------------------- member---------------------------------------------------------------------}--prop_member_isSubsetOf =- forAll arbitrary $ \r ->- forAll intervals $ \a ->- Interval.member r a == Interval.isSubsetOf (Interval.singleton r) a--{--------------------------------------------------------------------- isSubsetOf---------------------------------------------------------------------}--prop_isSubsetOf_refl =- forAll intervals $ \a ->- Interval.isSubsetOf a a--prop_isSubsetOf_trans =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- Interval.isSubsetOf a b && Interval.isSubsetOf b c- ==> Interval.isSubsetOf a c---- prop_isSubsetOf_antisym =--- forAll intervals $ \a ->--- forAll intervals $ \b ->--- Interval.isSubsetOf a b && Interval.isSubsetOf b a--- ==> a == b--{--------------------------------------------------------------------- pickup---------------------------------------------------------------------}--prop_pickup_member_null =- forAll intervals $ \a ->- case Interval.pickup a of- Nothing -> Interval.null a- Just x -> Interval.member x a--case_pickup_empty =- Interval.pickup (Interval.empty :: Interval Rational) @?= Nothing--case_pickup_univ =- isJust (Interval.pickup (Interval.univ :: Interval Rational)) @?= True--{--------------------------------------------------------------------- Comparison---------------------------------------------------------------------}--case_lt_all_1 = (a <! b) @?= False- where- a, b :: Interval Rational- a = Interval.interval Nothing (Just (True,0))- b = Interval.interval (Just (True,0)) Nothing--case_lt_all_2 = (a <! b) @?= True- where- a, b :: Interval Rational- a = Interval.interval Nothing (Just (False,0))- b = Interval.interval (Just (True,0)) Nothing--case_lt_all_3 = (a <! b) @?= True- where- a, b :: Interval Rational- a = Interval.interval Nothing (Just (True,0))- b = Interval.interval (Just (False,0)) Nothing--case_lt_all_4 = (a <! b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval (Just (True,1)) Nothing--case_lt_some_1 = (a <? b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval Nothing (Just (True,0))--case_lt_some_2 = (a <? b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (False,0)) Nothing- b = Interval.interval Nothing (Just (True,0))--case_lt_some_3 = (a <? b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval Nothing (Just (False,0))--case_lt_some_4 = (a <! b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval (Just (True,1)) Nothing--case_le_some_1 = (a <=? b) @?= True- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval Nothing (Just (True,0))--case_le_some_2 = (a <=? b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (False,0)) Nothing- b = Interval.interval Nothing (Just (True,0))--case_le_some_3 = (a <=? b) @?= False- where- a, b :: Interval Rational- a = Interval.interval (Just (True,0)) Nothing- b = Interval.interval Nothing (Just (False,0))--prop_lt_all_not_refl =- forAll intervals $ \a -> not (Interval.null a) ==> not (a <! a)--prop_le_some_refl =- forAll intervals $ \a -> not (Interval.null a) ==> a <=? a--prop_lt_all_singleton =- forAll arbitrary $ \a ->- forAll arbitrary $ \b ->- (a::Rational) < b ==> Interval.singleton a <! Interval.singleton b--prop_lt_all_singleton_2 =- forAll arbitrary $ \a ->- not $ Interval.singleton (a::Rational) <! Interval.singleton a--prop_le_all_singleton =- forAll arbitrary $ \a ->- forAll arbitrary $ \b ->- (a::Rational) <= b ==> Interval.singleton a <=! Interval.singleton b--prop_le_all_singleton_2 =- forAll arbitrary $ \a ->- Interval.singleton (a::Rational) <=! Interval.singleton a--prop_lt_some_singleton =- forAll arbitrary $ \a ->- forAll arbitrary $ \b ->- (a::Rational) < b ==> Interval.singleton a <? Interval.singleton b--prop_lt_some_singleton_2 =- forAll arbitrary $ \a ->- not $ Interval.singleton (a::Rational) <? Interval.singleton a--prop_le_some_singleton =- forAll arbitrary $ \a ->- forAll arbitrary $ \b ->- (a::Rational) <= b ==> Interval.singleton a <=? Interval.singleton b--prop_le_some_singleton_2 =- forAll arbitrary $ \a ->- Interval.singleton (a::Rational) <=? Interval.singleton a--{--------------------------------------------------------------------- Num---------------------------------------------------------------------}--prop_scale_empty =- forAll arbitrary $ \r ->- (r::Rational) .*. Interval.empty == Interval.empty--prop_add_comm =- forAll intervals $ \a ->- forAll intervals $ \b ->- a + b == b + a--prop_add_assoc =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- a + (b + c) == (a + b) + c--prop_add_unitL =- forAll intervals $ \a ->- Interval.singleton 0 + a == a--prop_add_unitR =- forAll intervals $ \a ->- a + Interval.singleton 0 == a--prop_add_member =- forAll intervals $ \a ->- forAll intervals $ \b ->- and [ (x+y) `Interval.member` (a+b)- | x <- maybeToList $ Interval.pickup a- , y <- maybeToList $ Interval.pickup b- ]--prop_mult_comm =- forAll intervals $ \a ->- forAll intervals $ \b ->- a * b == b * a--prop_mult_assoc =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- a * (b * c) == (a * b) * c--prop_mult_unitL =- forAll intervals $ \a ->- Interval.singleton 1 * a == a--prop_mult_unitR =- forAll intervals $ \a ->- a * Interval.singleton 1 == a--prop_mult_dist =- forAll intervals $ \a ->- forAll intervals $ \b ->- forAll intervals $ \c ->- (a * (b + c)) `Interval.isSubsetOf` (a * b + a * c)--prop_mult_singleton =- forAll arbitrary $ \r ->- forAll intervals $ \a ->- Interval.singleton r * a == r .*. a--prop_mult_empty =- forAll intervals $ \a ->- Interval.empty * a == Interval.empty--prop_mult_zero = - forAll intervals $ \a ->- not (Interval.null a) ==> Interval.singleton 0 * a == Interval.singleton 0--prop_mult_member =- forAll intervals $ \a ->- forAll intervals $ \b ->- and [ (x*y) `Interval.member` (a*b)- | x <- maybeToList $ Interval.pickup a- , y <- maybeToList $ Interval.pickup b- ]--case_mult_test1 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval (Just (True,1)) (Just (True,2))- ival2 = Interval.interval (Just (True,1)) (Just (True,2))- ival3 = Interval.interval (Just (True,1)) (Just (True,4))--case_mult_test2 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval (Just (True,1)) (Just (True,2))- ival2 = Interval.interval (Just (False,1)) (Just (False,2))- ival3 = Interval.interval (Just (False,1)) (Just (False,4))--case_mult_test3 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval (Just (False,1)) (Just (False,2))- ival2 = Interval.interval (Just (False,1)) (Just (False,2))- ival3 = Interval.interval (Just (False,1)) (Just (False,4))--case_mult_test4 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval (Just (False,2)) Nothing- ival2 = Interval.interval (Just (False,3)) Nothing- ival3 = Interval.interval (Just (False,6)) Nothing--case_mult_test5 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval Nothing (Just (False,-3))- ival2 = Interval.interval Nothing (Just (False,-2))- ival3 = Interval.interval (Just (False,6)) Nothing--case_mult_test6 = ival1 * ival2 @?= ival3- where- ival1 = Interval.interval (Just (False,2)) Nothing- ival2 = Interval.interval Nothing (Just (False,-2))- ival3 = Interval.interval Nothing (Just (False,-4))--{--------------------------------------------------------------------- Fractional---------------------------------------------------------------------}--prop_recip_singleton =- forAll arbitrary $ \r ->- let n = fromIntegral (numerator r)- d = fromIntegral (denominator r)- in Interval.singleton n / Interval.singleton d == Interval.singleton (r::Rational)--case_recip_pos =- recip pos @?= pos--case_recip_neg =- recip neg @?= neg--case_recip_test1 = recip i1 @?= i2- where- i1, i2 :: Interval Rational- i1 = Interval.interval (Just (True,2)) Nothing- i2 = Interval.interval (Just (False,0)) (Just (True,1/2))--{--------------------------------------------------------------------- Generators---------------------------------------------------------------------}--intervals :: Gen (Interval Rational)-intervals = do- lb <- arbitrary- ub <- arbitrary- return $ Interval.interval lb ub--pos :: Interval Rational-pos = Interval.interval (Just (False,0)) Nothing--neg :: Interval Rational-neg = Interval.interval Nothing (Just (False,0))--nonpos :: Interval Rational-nonpos = Interval.interval Nothing (Just (True,0))--nonneg :: Interval Rational-nonneg = Interval.interval (Just (True,0)) Nothing----------------------------------------------------------------------------- Test harness--main :: IO ()-main = $(defaultMainGenerator)
test/TestMIPSolver2.hs view
@@ -6,18 +6,17 @@ import Data.Ratio import qualified Data.IntMap as IM import qualified Data.IntSet as IS+import Data.VectorSpace import Test.HUnit hiding (Test) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.TH import Test.Framework.Providers.HUnit import Text.Printf -import Data.Linear import qualified Data.LA as LA import qualified Algorithm.Simplex2 as Simplex2 import Algorithm.Simplex2 import qualified Algorithm.MIPSolver2 as MIPSolver2---import Algorithm.MIPSolver2 ------------------------------------------------------------------------ @@ -29,11 +28,11 @@ x2 = LA.var 2 x3 = LA.var 3 x4 = LA.var 4- obj = x1 .+. 2 .*. x2 .+. 3 .*. x3 .+. x4+ 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+ [ (-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@@ -67,7 +66,7 @@ lp <- Simplex2.newSolver replicateM 5 (Simplex2.newVar lp) setOptDir lp (f optdir)- setObj lp (lnegate obj)+ setObj lp (negateV obj) mapM_ (Simplex2.assertAtom lp) cs mip <- MIPSolver2.newSolver lp ivs ret <- MIPSolver2.optimize mip (\_ _ -> return ())@@ -90,11 +89,11 @@ where optdir = OptMin [x1,x2,x3] = map LA.var [1..3]- obj = (-1) .*. x1 .-. 3 .*. x2 .-. 5 .*. x3+ 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+ [ 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
test/TestPolynomial.hs view
@@ -18,6 +18,7 @@ import Data.Polynomial.Sturm import qualified Data.Polynomial.Lagrange as Lagrange import qualified Data.Interval as Interval+import Data.Interval (Interval, EndPoint (..), (<=..<=), (<..<=), (<=..<), (<..<)) {-------------------------------------------------------------------- Polynomial type@@ -477,11 +478,11 @@ -- http://mathworld.wolfram.com/SturmFunction.html case_numRoots_1 = sequence_- [ numRoots p (Interval.closedInterval (-2) 0) @?= 2- , numRoots p (Interval.closedInterval 0 2) @?= 1- , numRoots p (Interval.closedInterval (-1.5) (-1.0)) @?= 1- , numRoots p (Interval.closedInterval (-0.5) 0) @?= 1- , numRoots p (Interval.closedInterval 1 (1.5)) @?= 1+ [ numRoots p (Finite (-2) <=..<= Finite 0) @?= 2+ , numRoots p (Finite 0 <=..<= Finite 2) @?= 1+ , numRoots p (Finite (-1.5) <=..<= Finite (-1.0)) @?= 1+ , numRoots p (Finite (-0.5) <=..<= Finite 0) @?= 1+ , numRoots p (Finite 1 <=..<= Finite (1.5)) @?= 1 ] where x = var ()@@ -490,10 +491,10 @@ -- check interpretation of intervals case_numRoots_2 = sequence_- [ numRoots p (Interval.interval (Just (False,2)) (Just (True,3))) @?= 0- , numRoots p (Interval.interval (Just (True,2)) (Just (True,3))) @?= 1- , numRoots p (Interval.interval (Just (False,1)) (Just (False,2))) @?= 0- , numRoots p (Interval.interval (Just (False,1)) (Just (True,2))) @?= 1+ [ numRoots p (Finite 2 <..<= Finite 3) @?= 0+ , numRoots p (Finite 2 <=..<= Finite 3) @?= 1+ , numRoots p (Finite 1 <..< Finite 2) @?= 0+ , numRoots p (Finite 1 <..<= Finite 2) @?= 1 ] where x = var ()
test/TestQE.hs view
@@ -4,7 +4,10 @@ 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@@ -12,9 +15,7 @@ import Data.AlgebraicNumber import Data.ArithRel-import Data.Expr-import Data.Formula-import Data.Linear+import Data.FOL.Arith import qualified Data.LA as LA import qualified Data.Polynomial as P import Data.OptDir@@ -79,8 +80,8 @@ 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+ 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] @@ -125,14 +126,14 @@ where x = LA.var 0 y = LA.var 1- t1 = 11.*.x .+. 13.*.y- t2 = 7.*.x .-. 9.*.y+ t1 = 11*^x ^+^ 13*^y+ t2 = 7*^x ^-^ 9*^y ------------------------------------------------------------------------ case_FourierMotzkin_test1 :: IO () case_FourierMotzkin_test1 = - case FourierMotzkin.solveConj test1' of+ case FourierMotzkin.solve (IS.fromList [0,1,2]) test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> forM_ test1' $ \a -> do@@ -140,7 +141,7 @@ case_FourierMotzkin_test2 :: IO () case_FourierMotzkin_test2 = - case FourierMotzkin.solveConj test2' of+ case FourierMotzkin.solve (IS.fromList [0,1]) test2' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> forM_ test2' $ \a -> do@@ -150,7 +151,7 @@ case_CAD_test1 :: IO () case_CAD_test1 = - case CAD.solve test1'' of+ case CAD.solve (Set.fromList [0,1,2]) test1'' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> forM_ test1'' $ \a -> do@@ -160,7 +161,7 @@ case_CAD_test2 :: IO () case_CAD_test2 = - case CAD.solve test2'' of+ case CAD.solve (Set.fromList [0,1]) test2'' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> forM_ test2'' $ \a -> do@@ -184,7 +185,7 @@ case_OmegaTest_test1 :: IO () case_OmegaTest_test1 = - case OmegaTest.solve test1' of+ case OmegaTest.solve OmegaTest.defaultOptions (IS.fromList [0,1,2]) test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do forM_ test1' $ \a -> do@@ -192,7 +193,7 @@ case_OmegaTest_test2 :: IO () case_OmegaTest_test2 = - case OmegaTest.solve test2' of+ case OmegaTest.solve OmegaTest.defaultOptions (IS.fromList [0,1]) test2' of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return () @@ -200,7 +201,7 @@ case_Cooper_test1 :: IO () case_Cooper_test1 = - case Cooper.solveConj test1' of+ case Cooper.solve (IS.fromList [0,1,2]) test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do forM_ test1' $ \a -> do@@ -208,7 +209,7 @@ case_Cooper_test2 :: IO () case_Cooper_test2 = - case Cooper.solveConj test2' of+ case Cooper.solve (IS.fromList [0,1]) test2' of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return () @@ -236,7 +237,7 @@ disabled_case_ContiTraverso_test1 :: IO () disabled_case_ContiTraverso_test1 = - case ContiTraverso.solve P.grlex OptMin (LA.constant 0) test1' of+ case ContiTraverso.solve P.grlex (IS.fromList [0,1,2]) OptMin (LA.constant 0) test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do forM_ test1' $ \a -> do@@ -244,7 +245,7 @@ disabled_case_ContiTraverso_test2 :: IO () disabled_case_ContiTraverso_test2 = - case ContiTraverso.solve P.grlex OptMin (LA.constant 0) test2' of+ case ContiTraverso.solve P.grlex (IS.fromList [0,1]) OptMin (LA.constant 0) test2' of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return ()
test/TestSAT.hs view
@@ -281,6 +281,19 @@ ------------------------------------------------------------------------ +-- -4*(not x1) + 3*x1 + 10*(not x2)+-- = -4*(1 - x1) + 3*x1 + 10*(not x2)+-- = -4 + 4*x1 + 3*x1 + 10*(not x2)+-- = 7*x1 + 10*(not x2) - 4+case_normalizePBSum :: Assertion+case_normalizePBSum = do+ sort e @?= sort [(7,x1),(10,-x2)]+ c @?= -4+ where+ x1 = 1+ x2 = 2+ (e,c) = normalizePBSum ([(-4,-x1),(3,x1),(10,-x2)], 0)+ -- -4*(not x1) + 3*x1 + 10*(not x2) >= 3 -- ⇔ -4*(1 - x1) + 3*x1 + 10*(not x2) >= 3 -- ⇔ -4 + 4*x1 + 3*x1 + 10*(not x2) >= 3
test/TestSimplex2.hs view
@@ -4,13 +4,13 @@ import Control.Monad import Data.List import Data.Ratio+import Data.VectorSpace import Test.HUnit hiding (Test) import Test.Framework (Test, defaultMain, testGroup) import Test.Framework.TH import Test.Framework.Providers.HUnit import Text.Printf -import Data.Linear import qualified Data.LA as LA import Algorithm.Simplex2
toysat/toysat.hs view
@@ -29,6 +29,7 @@ import Data.Maybe import Data.Ord import Data.Ratio+import Data.VectorSpace import Data.Version import Data.Time import System.IO@@ -52,7 +53,7 @@ #endif import Data.ArithRel-import Data.Linear+import qualified Converter.MaxSAT2WBO as MaxSAT2WBO import qualified SAT import qualified SAT.PBO as PBO import qualified SAT.Integer@@ -166,7 +167,7 @@ , Option [] ["search"] (ReqArg (\val opt -> opt{ optSearchStrategy = parseSearch val }) "<str>")- "Search algorithm used in optimization; linear (default), binary"+ "Search algorithm used in optimization; linear (default), binary, adaptive, unsat" , Option [] ["objfun-heuristics"] (NoArg (\opt -> opt{ optObjFunVarsHeuristics = True })) "Enable heuristics for polarity/activity of variables in objective function (default)"@@ -203,8 +204,11 @@ parseSearch s = case map toLower s of- "linear" -> PBO.LinearSearch- "binary" -> PBO.BinarySearch+ "linear" -> PBO.LinearSearch+ "binary" -> PBO.BinarySearch+ "adaptive" -> PBO.AdaptiveSearch+ "unsat" -> PBO.UnsatBased+ "msu4" -> PBO.MSU4 _ -> error (printf "unknown search strategy %s" s) parseLS "clause" = SAT.LearningClause@@ -400,7 +404,7 @@ solveMUS :: Options -> SAT.Solver -> GCNF.GCNF -> IO () solveMUS opt solver gcnf = do putCommentLine $ printf "#vars %d" (GCNF.numVars gcnf)- putCommentLine $ printf "#constraints %d" (length (GCNF.clauses gcnf))+ putCommentLine $ printf "#constraints %d" (GCNF.numClauses gcnf) putCommentLine $ printf "#groups %d" (GCNF.lastGroupIndex gcnf) SAT.newVars_ solver (GCNF.numVars gcnf)@@ -534,8 +538,9 @@ PBO.defaultOptions { PBO.optObjFunVarsHeuristics = optObjFunVarsHeuristics opt , PBO.optSearchStrategy = optSearchStrategy opt- , PBO.optLogger = putCommentLine- , PBO.optUpdater = update+ , PBO.optLogger = putCommentLine+ , PBO.optUpdateBest = update+ , PBO.optUpdateLB = \val -> putCommentLine $ printf "lower bound updated to %d" val } PBO.minimize solver obj opt2 @@ -625,18 +630,8 @@ Right wcnf -> solveMaxSAT opt solver wcnf solveMaxSAT :: Options -> SAT.Solver -> MaxSAT.WCNF -> IO ()-solveMaxSAT opt solver- MaxSAT.WCNF- { MaxSAT.topCost = top- , MaxSAT.clauses = cs- } = do- solveWBO opt solver True- ( Nothing- , [ (if w >= top then Nothing else Just w- , ([(1,[lit]) | lit<-lits], PBFile.Ge, 1))- | (w,lits) <- cs- ]- )+solveMaxSAT opt solver wcnf =+ solveWBO opt solver True (MaxSAT2WBO.convert wcnf) -- ------------------------------------------------------------------------ @@ -691,7 +686,7 @@ let indicator = LPFile.constrIndicator c (lhs, op, rhs) = LPFile.constrBody c let d = foldl' lcm 1 (map denominator (rhs:[r | LPFile.Term r _ <- lhs]))- lhs' = lsum [asInteger (r * fromIntegral d) .*. product [vmap Map.! v | v <- vs] | LPFile.Term r vs <- lhs]+ lhs' = sumV [asInteger (r * fromIntegral d) *^ product [vmap Map.! v | v <- vs] | LPFile.Term r vs <- lhs] rhs' = asInteger (rhs * fromIntegral d) case indicator of Nothing ->@@ -723,7 +718,7 @@ let (_label,obj) = LPFile.objectiveFunction lp d = foldl' lcm 1 [denominator r | LPFile.Term r _ <- obj] * (if LPFile.dir lp == LPFile.OptMin then 1 else -1)- obj2 = lsum [asInteger (r * fromIntegral d) .*. product [vmap Map.! v | v <- vs] | LPFile.Term r vs <- obj]+ obj2 = sumV [asInteger (r * fromIntegral d) *^ product [vmap Map.! v | v <- vs] | LPFile.Term r vs <- obj] (obj3,obj3_c) <- SAT.Integer.linearize enc obj2 modelRef <- newIORef Nothing
toysolver.cabal view
@@ -1,12 +1,12 @@ Name: toysolver-Version: 0.0.3+Version: 0.0.4 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer: masahiro.sakai@gmail.com-Category: Algorithms+Category: Algorithms, Optimisation, Optimization Cabal-Version: >= 1.8-Synopsis: Assorted decision procedures+Synopsis: Assorted decision procedures for SAT, Max-SAT, PB, MIP, etc Description: Toy-level implementation of some decision procedures Bug-Reports: https://github.com/msakai/toysolver/issues Extra-Source-Files:@@ -18,6 +18,7 @@ src/pbverify.hs src/pigeonhole.hs src/Algorithm/Wang.hs+ samples/gcnf/*.cnf samples/gcnf/*.gcnf samples/lp/*.lp samples/lp/error/*.lp@@ -50,56 +51,73 @@ Build-Depends: base >=4 && <5, containers >= 0.4.2, mtl, array, random, stm >=2.3, parsec, bytestring, filepath, deepseq, time, old-locale, primes,- parse-dimacs, queue, heaps, unbounded-delays,- OptDir+ parse-dimacs, queue, heaps, unbounded-delays, lattices >=1.2.1.1, vector-space >=0.8.6,+ OptDir, data-interval >=0.1.0 Extensions:+ TypeFamilies MultiParamTypeClasses FlexibleInstances BangPatterns DoAndIfThenElse CPP Exposed-Modules:+ Algebra.Lattice.Boolean Algorithm.BoundsInference Algorithm.CAD Algorithm.CongruenceClosure Algorithm.ContiTraverso Algorithm.Cooper+ Algorithm.Cooper.Core+ Algorithm.Cooper.FOL Algorithm.FOLModelFinder Algorithm.FourierMotzkin+ Algorithm.FourierMotzkin.Core+ Algorithm.FourierMotzkin.FOL Algorithm.LPSolver Algorithm.LPSolverHL Algorithm.LPUtil Algorithm.MIPSolverHL Algorithm.MIPSolver2 Algorithm.OmegaTest+ Algorithm.OmegaTest.Misc Algorithm.Simplex Algorithm.Simplex2- Converter.CNF2LP Converter.ObjType- Converter.PB2LP Converter.LP2SMT Converter.MaxSAT2LP+ Converter.MaxSAT2NLPB+ Converter.MaxSAT2WBO+ Converter.PB2LP+ Converter.PB2LSP+ Converter.PB2WBO+ Converter.PBSetObj+ Converter.PB2SMP+ Converter.SAT2PB+ Converter.SAT2LP+ Converter.WBO2PB Data.AlgebraicNumber Data.AlgebraicNumber.Root Data.ArithRel Data.Delta- Data.Expr- Data.Formula+ Data.DNF+ Data.FOL.Arith+ Data.FOL.Formula Data.LA- Data.Lattice+ Data.LA.FOL Data.LBool- Data.Linear- Data.Interval Data.Polynomial Data.Polynomial.FactorZ Data.Polynomial.GBase Data.Polynomial.Lagrange Data.Polynomial.Sturm+ Data.Var SAT SAT.Integer SAT.MUS SAT.CAMUS SAT.PBO+ SAT.PBO.MSU4+ SAT.PBO.UnsatBased SAT.TheorySolver SAT.TseitinEncoder SAT.Types@@ -116,6 +134,7 @@ Other-Modules: Data.IndexedPriorityQueue Data.SeqQueue+ Text.Util Paths_toysolver GHC-Prof-Options: -auto-all @@ -132,7 +151,7 @@ Executable toysat Main-is: toysat.hs HS-Source-Dirs: toysat- Build-Depends: base >=4 && <5, containers >= 0.4.2, array, parsec, bytestring, filepath, parse-dimacs, time, old-locale, unbounded-delays, toysolver+ Build-Depends: base >=4 && <5, containers >= 0.4.2, array, parsec, bytestring, filepath, parse-dimacs, time, old-locale, unbounded-delays, vector-space >=0.8.6, toysolver if impl(ghc >= 7) GHC-Options: -rtsopts GHC-Prof-Options: -auto-all@@ -153,6 +172,11 @@ HS-Source-Dirs: lpconvert Build-Depends: base >=4 && <5, containers, filepath, parse-dimacs, toysolver +Executable pbconvert+ Main-is: pbconvert.hs+ HS-Source-Dirs: pbconvert+ Build-Depends: base >=4 && <5, containers, filepath, parse-dimacs, toysolver+ Test-suite TestSAT Type: exitcode-stdio-1.0 HS-Source-Dirs: test@@ -164,28 +188,21 @@ Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestSimplex2.hs- Build-depends: base >=4 && <5, containers, toysolver, test-framework,test-framework-th,test-framework-hunit,HUnit+ Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, test-framework,test-framework-th,test-framework-hunit,HUnit Extensions: TemplateHaskell, DoAndIfThenElse Test-suite TestMIPSolver2 Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestMIPSolver2.hs- Build-depends: base >=4 && <5, containers, toysolver, test-framework, test-framework-th, test-framework-hunit, HUnit, OptDir, stm+ Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, test-framework, test-framework-th, test-framework-hunit, HUnit, OptDir, stm Extensions: TemplateHaskell, DoAndIfThenElse Test-suite TestPolynomial Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestPolynomial.hs- Build-depends: base >=4 && <5, containers, toysolver, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3- Extensions: TemplateHaskell, DoAndIfThenElse--Test-suite TestInterval- Type: exitcode-stdio-1.0- HS-Source-Dirs: test- Main-is: TestInterval.hs- Build-depends: base >=4 && <5, containers, toysolver, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3+ Build-depends: base >=4 && <5, containers, toysolver, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3, data-interval >=0.1.0 Extensions: TemplateHaskell, DoAndIfThenElse Test-suite TestAReal@@ -199,14 +216,14 @@ Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestQE.hs- Build-depends: base >=4 && <5, containers, toysolver, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3+ Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3 Extensions: TemplateHaskell, DoAndIfThenElse Test-suite TestContiTraverso Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-is: TestContiTraverso.hs- Build-depends: base >=4 && <5, containers, toysolver, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3+ Build-depends: base >=4 && <5, containers, vector-space >=0.8.6, toysolver, OptDir, test-framework,test-framework-th,test-framework-hunit,test-framework-quickcheck2,HUnit,QuickCheck >=2 && <3 Extensions: TemplateHaskell, DoAndIfThenElse Test-suite TestLPFile
toysolver/toysolver.hs view
@@ -32,15 +32,17 @@ import System.IO import Text.Printf import qualified Language.CNF.Parse.ParseDIMACS as DIMACS+import GHC.Conc (getNumProcessors, setNumCapabilities) -import Data.Expr import Data.ArithRel-import Data.Formula (Atom (..))+import Data.FOL.Arith as FOL import Data.OptDir import qualified Data.LA as LA+import qualified Data.LA.FOL as LAFOL import qualified Data.Polynomial as P import qualified Data.AlgebraicNumber as AReal import qualified Algorithm.OmegaTest as OmegaTest+import qualified Algorithm.OmegaTest.Misc as OmegaTest import qualified Algorithm.Cooper as Cooper import qualified Algorithm.MIPSolverHL as MIPSolverHL import qualified Algorithm.Simplex2 as Simplex2@@ -52,7 +54,7 @@ import qualified Text.PBFile as PBFile import qualified Text.MaxSAT as MaxSAT import qualified Text.GurobiSol as GurobiSol-import qualified Converter.CNF2LP as CNF2LP+import qualified Converter.SAT2LP as SAT2LP import qualified Converter.PB2LP as PB2LP import qualified Converter.MaxSAT2LP as MaxSAT2LP import SAT.Printer@@ -74,6 +76,7 @@ | NoMIP | PivotStrategy String | NThread !Int+ | OmegaReal String | Mode !Mode deriving Eq @@ -85,11 +88,11 @@ , Option [] ["print-rational"] (NoArg PrintRational) "print rational numbers instead of decimals" , Option ['w'] [] (ReqArg WriteFile "<filename>") "write solution to filename in Gurobi .sol format" - , Option [] ["print-rational"] (NoArg PrintRational) "print rational numbers instead of decimals"- , 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 [] ["sat"] (NoArg (Mode ModeSAT)) "solve boolean satisfiability problems in .cnf file" , Option [] ["pb"] (NoArg (Mode ModePB)) "solve pseudo boolean problems in .pb file" , Option [] ["wbo"] (NoArg (Mode ModeWBO)) "solve weighted boolean optimization problem in .opb file"@@ -158,46 +161,66 @@ | NoMIP `elem` opt = Set.empty | otherwise = LP.integerVariables lp + vs2 = IM.keysSet varToName ivs2 = IS.fromList . map (nameToVar Map.!) . Set.toList $ ivs solveByQE =- case mapM LA.compileAtom (cs1 ++ cs2) of+ case mapM LAFOL.fromFOLAtom (cs1 ++ cs2) of Nothing -> do putStrLn "s UNKNOWN" exitFailure Just cs ->- case f cs ivs2 of+ case f vs2 cs ivs2 of Nothing -> do putStrLn "s UNSATISFIABLE" exitFailure Just m -> do- putStrLn $ "o " ++ showValue (Data.Expr.eval m obj)+ putStrLn $ "o " ++ showValue (FOL.evalExpr m obj) putStrLn "s SATISFIABLE" let m2 = Map.fromAscList [(v, m IM.! (nameToVar Map.! v)) | v <- Set.toList vs] printModel m2 where f = case solver of- "omega" -> OmegaTest.solveQFLA- "omega-test" -> OmegaTest.solveQFLA+ "omega" -> OmegaTest.solveQFLA omegaOpt+ "omega-test" -> OmegaTest.solveQFLA omegaOpt "cooper" -> Cooper.solveQFLA _ -> error "unknown solver" - solveByMIP =- case MIPSolverHL.optimize (LP.dir lp) obj (cs1 ++ cs2) ivs2 of- OptUnknown -> do+ omegaOpt =+ OmegaTest.defaultOptions+ { OmegaTest.optCheckReal = realSolver+ } + where+ realSolver =+ case last ("fourier-motzkin" : [s | OmegaReal s <- opt]) of+ "fourier-motzkin" -> OmegaTest.checkRealByFM+ "cad" -> OmegaTest.checkRealByCAD+ "simplex" -> OmegaTest.checkRealBySimplex+ "none" -> OmegaTest.checkRealNoCheck+ s -> error ("unknown solver: " ++ s)++ solveByMIP = do+ let m = do+ cs' <- mapM LAFOL.fromFOLAtom (cs1 ++ cs2)+ obj' <- LAFOL.fromFOLExpr obj+ return (cs',obj')+ case m of+ Nothing -> do putStrLn "s UNKNOWN" exitFailure- OptUnsat -> do- putStrLn "s UNSATISFIABLE"- exitFailure- Unbounded -> do- putStrLn "s UNBOUNDED"- exitFailure- Optimum r m -> do- putStrLn $ "o " ++ showValue r- putStrLn "s OPTIMUM FOUND"- let m2 = Map.fromAscList [(v, m IM.! (nameToVar Map.! v)) | v <- Set.toList vs]- printModel m2+ Just (cs',obj') ->+ case MIPSolverHL.optimize (LP.dir lp) obj' cs' ivs2 of+ MIPSolverHL.OptUnsat -> do+ putStrLn "s UNSATISFIABLE"+ exitFailure+ MIPSolverHL.Unbounded -> do+ putStrLn "s UNBOUNDED"+ exitFailure+ MIPSolverHL.Optimum r m -> do+ putStrLn $ "o " ++ showValue r+ putStrLn "s OPTIMUM FOUND"+ let m2 = Map.fromAscList [(v, m IM.! (nameToVar Map.! v)) | v <- Set.toList vs]+ printModel m2 solveByMIP2 = do solver <- Simplex2.newSolver@@ -213,20 +236,26 @@ Simplex2.setLogger solver putCommentLine replicateM (length vsAssoc) (Simplex2.newVar solver) -- XXX Simplex2.setOptDir solver (LP.dir lp)- Simplex2.setObj solver $ fromJust (LA.compileExpr obj)+ Simplex2.setObj solver $ fromJust (LAFOL.fromFOLExpr obj) putCommentLine "Loading constraints... " forM_ (cs1 ++ cs2) $ \c -> do- Simplex2.assertAtom solver $ fromJust (LA.compileAtom c)+ Simplex2.assertAtom solver $ fromJust (LAFOL.fromFOLAtom c) putCommentLine "Loading constraints finished" mip <- MIPSolver2.newSolver solver ivs2 MIPSolver2.setShowRational mip printRat MIPSolver2.setLogger mip putCommentLine- ncap <- getNumCapabilities- MIPSolver2.setNThread mip $++ procs <- if nthreads >= 1- then min ncap nthreads- else ncap+ then return nthreads+ else do+ ncap <- getNumCapabilities+ procs <- getNumProcessors+ return $ max (procs - 1) ncap+ setNumCapabilities procs+ MIPSolver2.setNThread mip procs+ let update m val = do putStrLn $ "o " ++ showValue val ret <- MIPSolver2.optimize mip update@@ -254,14 +283,15 @@ exitFailure | otherwise = do let cs = map g $ cs1 ++ cs2- case CAD.solve cs of+ vs3 = Set.fromAscList $ IS.toAscList vs2+ case CAD.solve vs3 cs of Nothing -> do putStrLn "s UNSATISFIABLE" exitFailure Just m -> do let m2 = IM.map (\x -> AReal.approx x (2^^(-64::Int))) $ IM.fromAscList $ Map.toAscList $ m- putStrLn $ "o " ++ showValue (Data.Expr.eval m2 obj)+ putStrLn $ "o " ++ showValue (FOL.evalExpr m2 obj) putStrLn "s SATISFIABLE" let m3 = Map.fromAscList [(v, m2 IM.! (nameToVar Map.! v)) | v <- Set.toList vs] printModel m3@@ -286,8 +316,8 @@ exitFailure | otherwise = do let tmp = do- linObj <- LA.compileExpr obj- linCon <- mapM LA.compileAtom (cs1 ++ cs2)+ linObj <- LAFOL.fromFOLExpr obj+ linCon <- mapM LAFOL.fromFOLAtom (cs1 ++ cs2) return (linObj, linCon) case tmp of Nothing -> do@@ -295,13 +325,13 @@ putCommentLine "non-linear expressions are not supported by Conti-Traverso algorithm" exitFailure Just (linObj, linCon) -> do- case ContiTraverso.solve P.grlex (LP.dir lp) linObj linCon of+ case ContiTraverso.solve P.grlex vs2 (LP.dir lp) linObj linCon of Nothing -> do putStrLn "s UNSATISFIABLE" exitFailure Just m -> do let m2 = IM.map fromInteger m- putStrLn $ "o " ++ showValue (Data.Expr.eval m2 obj)+ putStrLn $ "o " ++ showValue (FOL.evalExpr m2 obj) putStrLn "s OPTIMUM FOUND" let m3 = Map.fromAscList [(v, m2 IM.! (nameToVar Map.! v)) | v <- Set.toList vs] printModel m3@@ -357,7 +387,7 @@ case ret of Left err -> hPrint stderr err >> exitFailure Right cnf -> do- let (lp,mtrans) = CNF2LP.convert CNF2LP.ObjNone cnf+ let (lp,mtrans) = SAT2LP.convert cnf run (getSolver o) o lp $ \m -> do let m2 = mtrans m satPrintModel stdout m2 0@@ -367,7 +397,7 @@ case ret of Left err -> hPrint stderr err >> exitFailure Right pb -> do- let (lp,mtrans) = PB2LP.convert PB2LP.ObjNone pb+ let (lp,mtrans) = PB2LP.convert pb run (getSolver o) o lp $ \m -> do let m2 = mtrans m pbPrintModel stdout m2 0@@ -387,7 +417,7 @@ case ret of Left err -> hPutStrLn stderr err >> exitFailure Right wcnf -> do- let (lp,mtrans) = MaxSAT2LP.convert wcnf+ let (lp,mtrans) = MaxSAT2LP.convert False wcnf run (getSolver o) o lp $ \m -> do let m2 = mtrans m maxsatPrintModel stdout m2 0