diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,23 @@ +0.7.0 +----- + +* add `toysat-ipasir` foreign library which implements [IPASIR](https://github.com/biotomas/ipasir) API for incremental SAT solving. +* `ToySolver.SAT` + * Restructure SAT solver modules under `ToySolver.SAT.Solver.*` + * add `SequentialCounter`, `ParallelCounter` and `Totalizer` as methods for encoding cardinality constraints + * add `PackedLit` type to reduce memory footprint + * use structure of array (SOA) approach to reduce memory footprint + * add `setLearnCallback`/`clearLearnCallback` and `setTerminateCallback`/`clearTerminateCallback` which correspond to [IPASIR](https://github.com/biotomas/ipasir)'s `ipasir_set_learn()` and `ipasir_set_terminate()`. + * add `clearLogger` + * change `getFailedAssumptions` and `getAssumptionsImplications` to return `IntSet` instead of `[Int]` +* separate `ToySolver.Data.MIP.*` into new [MIP](http://hackage.haskell.org/package/MIP) package's `Numeric.Optimization.MIP.*` +* add `ToySolver.Data.Polynomial.Interpolation.Hermite` +* add `ToySolver.Graph.Base` and `ToySolver.Graph.MaxCut` +* add `ToySolver.Converter.SAT2MIS` +* `ToySolver.Graph.ShortestPath`: fix vertex type to `Int` instead of arbitrary `Hashable` type +* stop supporting GHC-7.10 +* add `ExtraBoundsChecking` flag for debugging + 0.6.0 ----- * new solvers: @@ -13,7 +33,7 @@ info `ToySolver.FileFormat` and `ToySolver.FileFormat.CNF` * allow reading/writing `gzip`ped CNF/WCNF/GCNF/QDimacs/LP/MPS files * rename modules: - * `ToySolver.Arith.Simplex2` to `ToySolver.Arith.Simplex` + * `ToySolver.Arith.Simplex2` to `ToySolver.Arith.Simplex` * `ToySolver.Arith.MIPSolver2` to `ToySolver.Arith.MIP` * `ToySolver.Data.Var` to `ToySolver.Data.IntVar` * `ToySolver.SAT`: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,19 @@ toysolver ========= +[![License](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![Join the chat at https://gitter.im/msakai/toysolver](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/msakai/toysolver) +Hackage: +[![Hackage](https://img.shields.io/hackage/v/toysolver.svg)](https://hackage.haskell.org/package/toysolver) +[![Hackage Deps](https://img.shields.io/hackage-deps/v/toysolver.svg)](https://packdeps.haskellers.com/feed?needle=toysolver) +[![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/toysolver/badge)](https://matrix.hackage.haskell.org/#/package/toysolver) + +Dev: [![Build Status (Travis CI)](https://secure.travis-ci.org/msakai/toysolver.svg?branch=master)](http://travis-ci.org/msakai/toysolver) [![Build Status (AppVeyor)](https://ci.appveyor.com/api/projects/status/w7g615sp8ysiqk7w/branch/master?svg=true)](https://ci.appveyor.com/project/msakai/toysolver/branch/master) +[![Build Status (GitHub Actions)](https://github.com/msakai/toysolver/workflows/build/badge.svg)](https://github.com/msakai/toysolver/actions) [![Coverage Status](https://coveralls.io/repos/msakai/toysolver/badge.svg)](https://coveralls.io/r/msakai/toysolver) -[![Hackage](https://img.shields.io/hackage/v/toysolver.svg)](https://hackage.haskell.org/package/toysolver) -[![License](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) It provides solver implementations of various problems including SAT, SMT, Max-SAT, PBS (Pseudo Boolean Satisfaction), PBO (Pseudo Boolean Optimization), MILP (Mixed Integer Linear Programming) and non-linear real arithmetic. @@ -126,3 +132,15 @@ * [ersatz-toysat](http://hackage.haskell.org/package/ersatz-toysat) - toysat backend driver for [ersatz](http://hackage.haskell.org/package/ersatz) * [satchmo-toysat](http://hackage.haskell.org/package/satchmo-toysat) - toysat backend driver for [satchmo](http://hackage.haskell.org/package/satchmo) + +Spin-off projects and packages +------------------------------ + +* [bytestring-encoding](https://github.com/msakai/bytestring-encoding) +* [data-interval](https://github.com/msakai/data-interval) +* [extended-reals](https://github.com/msakai/extended-reals) +* [finite-field](https://github.com/msakai/finite-field) +* [MIP](https://github.com/msakai/haskell-MIP) +* [OptDir](https://github.com/msakai/haskell-optdir) +* [pseudo-boolean](https://github.com/msakai/pseudo-boolean) +* [sign](https://github.com/msakai/sign) diff --git a/app/toyconvert.hs b/app/toyconvert.hs --- a/app/toyconvert.hs +++ b/app/toyconvert.hs @@ -6,7 +6,7 @@ -- Module : toyconvert -- Copyright : (c) Masahiro Sakai 2012-2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : non-portable @@ -22,7 +22,9 @@ import Data.Default.Class import qualified Data.Foldable as F import Data.Maybe +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Scientific (Scientific) import qualified Data.Text.Lazy.Builder as TextBuilder import qualified Data.Text.Lazy.IO as TLIO @@ -36,8 +38,8 @@ import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Data.PseudoBoolean as PBFile +import qualified Numeric.Optimization.MIP as MIP -import qualified ToySolver.Data.MIP as MIP import ToySolver.Converter import ToySolver.Converter.ObjType import qualified ToySolver.Converter.MIP2SMT as MIP2SMT diff --git a/app/toyfmf.hs b/app/toyfmf.hs --- a/app/toyfmf.hs +++ b/app/toyfmf.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP, TypeFamilies, OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : toyfmf -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (CPP, TypeFamilies, OverloadedStrings) +-- Portability : non-portable -- -- A toy-level model finder -- @@ -19,7 +21,9 @@ import Data.Interned (intern, unintern) import Data.IORef import qualified Data.Map as Map +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ratio import Data.String import qualified Data.Text as Text @@ -104,7 +108,7 @@ quant q vs phi = foldr q' (translateFormula phi) [fromString v | TPTP.V v <- vs] where q' = - case q of + case q of TPTP.All -> MF.Forall TPTP.Exists -> MF.Exists binop phi op psi = op' phi' psi' diff --git a/app/toyqbf.hs b/app/toyqbf.hs --- a/app/toyqbf.hs +++ b/app/toyqbf.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : toyqbf -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (ScopedTypeVariables, CPP) +-- Portability : non-portable -- ----------------------------------------------------------------------------- @@ -18,7 +19,9 @@ import Data.Char import qualified Data.IntSet as IntSet import Data.List +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ord import Data.Version import Options.Applicative diff --git a/app/toysat-ipasir/IPASIR.hs b/app/toysat-ipasir/IPASIR.hs new file mode 100644 --- /dev/null +++ b/app/toysat-ipasir/IPASIR.hs @@ -0,0 +1,249 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +module IPASIR () where + +import Control.Exception +import Control.Monad +import Data.Int +import qualified Data.IntSet as IntSet +import Data.IORef +import Foreign +import Foreign.C + +import qualified ToySolver.SAT as SAT + + +type Solver = Ptr () + +type SolverRep = (SAT.Solver, IORef [Int32], IORef [Int32]) + +withSolverRep :: Solver -> (SolverRep -> IO a) -> IO a +withSolverRep ptr k = do + let sptr :: StablePtr SolverRep + sptr = castPtrToStablePtr ptr + solver <- deRefStablePtr sptr + k solver + +ensureVars :: SAT.Solver -> [Int32] -> IO () +ensureVars _solver [] = return () +ensureVars solver lits = do + let maxVar = maximum $ map (abs . fromIntegral) lits + nv <- SAT.getNVars solver + when (nv < maxVar) $ SAT.newVars_ solver (maxVar - nv) + + +foreign export ccall "toysat_ipasir_init" ipasir_init :: IO Solver + +-- | Construct a new solver and return a pointer to it. +-- +-- Use the returned pointer as the first parameter in each +-- of the following functions. +-- +-- Required state: N/A +-- +-- State after: @INPUT@ +ipasir_init :: IO Solver +ipasir_init = do + solver <- SAT.newSolver + addBuf <- newIORef [] + assumptionRef <- newIORef [] + sptr <- newStablePtr (solver, addBuf, assumptionRef) + return (castStablePtrToPtr sptr) + + +foreign export ccall "toysat_ipasir_release" ipasir_release :: Solver -> IO () + +-- | Release the solver, i.e., all its resoruces and +-- allocated memory (destructor). The solver pointer +-- cannot be used for any purposes after this call. +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: undefined +ipasir_release :: Solver -> IO () +ipasir_release ptr = do + let sptr :: StablePtr SolverRep + sptr = castPtrToStablePtr ptr + freeStablePtr sptr + + +foreign export ccall ipasir_add :: Solver -> Int32 -> IO () + +-- | Add the given literal into the currently added clause +-- or finalize the clause with a 0. +-- +-- Clauses added this way cannot be removed. The addition of +-- removable clauses can be simulated using activation literals +-- and assumptions. +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: @INPUT@ +-- +-- Literals are encoded as (non-zero) integers as in the +-- DIMACS formats. They have to be smaller or equal to +-- @INT_MAX@ and strictly larger than @INT_MIN@ (to avoid +-- negation overflow). This applies to all the literal +-- arguments in API functions. +ipasir_add :: Solver -> Int32 -> IO () +ipasir_add ptr lit = withSolverRep ptr $ \(solver, addBuf, _assumptionRef) -> do + if lit == 0 then do + lits <- readIORef addBuf + ensureVars solver lits + SAT.addClause solver (map fromIntegral (reverse lits)) + else do + modifyIORef addBuf (lit :) + + +foreign export ccall ipasir_assume :: Solver -> Int32 -> IO () + +-- | Add an assumption for the next SAT search (the next call +-- of ipasir_solve). +-- +-- After calling 'ipasir_solve' all the previously added assumptions +-- are cleared. +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: @INPUT@ +ipasir_assume :: Solver -> Int32 -> IO () +ipasir_assume ptr lit = withSolverRep ptr $ \(_solver, _addBuf, assumptionRef) -> do + modifyIORef assumptionRef (lit :) + + +foreign export ccall ipasir_solve :: Solver -> IO CInt + +-- | Solve the formula with specified clauses under the specified assumptions. +-- +-- * If the formula is satisfiable the function returns 10 and the state of the solver is changed to @SAT@. +-- * If the formula is unsatisfiable the function returns 20 and the state of the solver is changed to @UNSAT@. +-- * If the search is interrupted (see 'ipasir_set_terminate') the function returns 0 and the state of the solver is changed to @INPUT@. +-- +-- This function can be called in any defined state of the solver. +-- Note that the state of the solver _during_ execution of @ipasir_solve@ is undefined. +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: @INPUT@ or @SAT@ or @UNSAT@ +ipasir_solve :: Solver -> IO CInt +ipasir_solve ptr = withSolverRep ptr $ \(solver, _addBuf, assumptionRef) -> do + assumptions <- readIORef assumptionRef + writeIORef assumptionRef [] + ensureVars solver (assumptions) + handle (\(_ :: SAT.Canceled) -> return 0) $ do + ret <- SAT.solveWith solver (map fromIntegral assumptions) + if ret then do + return 10 + else do + return 20 + +foreign export ccall ipasir_val :: Solver -> Int32 -> IO CInt + +-- | Get the truth value of the given literal in the found satisfying +-- assignment. +-- +-- Return @lit@ if True, @-lit@ if False; +-- @ipasir_val(lit)@ may return 0 if the found assignment is satisfying for both valuations of lit. +-- Each solution that agrees with all non-zero values of @ipasir_val@ is a model of the formula. +-- +-- This function can only be used if 'ipasir_solve' has returned @10@ +-- and no 'ipasir_add' nor 'ipasir_assume' has been called +-- since then, i.e., the state of the solver is SAT. +-- +-- Required state: @SAT@ +-- +-- State after: @SAT@ +ipasir_val :: Solver -> Int32 -> IO CInt +ipasir_val ptr lit = withSolverRep ptr $ \(solver, _addBuf, _assumptionRef) -> do + nv <- SAT.getNVars solver + if nv < abs (fromIntegral lit) then do + return 0 + else do + m <- SAT.getModel solver + if SAT.evalLit m (fromIntegral lit) then + return (fromIntegral lit) + else + return (- fromIntegral lit) + + +foreign export ccall ipasir_failed :: Solver -> Int32 -> IO CInt + +-- | Check if the given assumption literal was used to prove the +-- unsatisfiability of the formula under the assumptions +-- used for the last SAT search. Return 1 if so, 0 otherwise. +-- +-- The formula remains unsatisfiable even just under assumption literals for which @ipasir_failed@ returns 1. +-- Note that for literals @lit@ which are not assumption literals, the behavior of @ipasir_failed(lit)@ is not specified. +-- +-- This function can only be used if 'ipasir_solve' has returned 20 and +-- no 'ipasir_add' or 'ipasir_assume' has been called since then, i.e., +-- the state of the solver is @UNSAT@. +-- +-- Required state: @UNSAT@ +-- +-- State after: @UNSAT@ +ipasir_failed :: Solver -> Int32 -> IO CInt +ipasir_failed ptr lit = withSolverRep ptr $ \(solver, _addBuf, _assumptionRef) -> do + failedLits <- SAT.getFailedAssumptions solver + return $ if IntSet.member (fromIntegral lit) failedLits then 1 else 0 + + +foreign export ccall ipasir_set_terminate :: Solver -> Ptr a -> FunPtr (Ptr a -> IO CInt) -> IO () + +-- | Set a callback function used to indicate a termination requirement to the +-- solver. +-- +-- The solver will periodically call this function and check its return +-- value during the search. The @ipasir_set_terminate@ function can be called in any +-- state of the solver, the state remains unchanged after the call. +-- The callback function is of the form "@int terminate(void * data)@x" +-- +-- * it returns a non-zero value if the solver should terminate. +-- * the solver calls the callback function with the parameter "data" +-- having the value passed in the @ipasir_set_terminate@ function (2nd parameter). +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: @INPUT@ or @SAT@ or @UNSAT@ +ipasir_set_terminate :: Solver -> Ptr a -> FunPtr (Ptr a -> IO CInt) -> IO () +ipasir_set_terminate ptr info funptr = withSolverRep ptr $ \(solver, _addBuf, _assumptionRef) -> do + if funptr == nullFunPtr then do + SAT.clearTerminateCallback solver + else do + let callback = mkTerminateCallback funptr + SAT.setTerminateCallback solver $ do + ret <- callback info + return (ret /= 0) + + +foreign export ccall ipasir_set_learn :: Solver -> Ptr a -> CInt -> FunPtr (Ptr a -> Ptr Int32 -> IO ()) -> IO () + +-- | Set a callback function used to extract learned clauses up to a given length from the +-- solver. +-- +-- The solver will call this function for each learned clause that satisfies +-- the maximum length (literal count) condition. The @ipasir_set_learn@ function can be called in any +-- state of the solver, the state remains unchanged after the call. +-- The callback function is of the form "@void learn(void * data, int * clause)@" +-- +-- * the solver calls the callback function with the parameter "data" +-- having the value passed in the @ipasir_set_learn@ function (2nd parameter). +-- * the argument "clause" is a pointer to a null terminated integer array containing the learned clause. +-- the solver can change the data at the memory location that "clause" points to after the function call. +-- +-- Required state: @INPUT@ or @SAT@ or @UNSAT@ +-- +-- State after: @INPUT@ or @SAT@ or @UNSAT@ +ipasir_set_learn :: Solver -> Ptr a -> CInt -> FunPtr (Ptr a -> Ptr Int32 -> IO ()) -> IO () +ipasir_set_learn ptr info max_length funptr = withSolverRep ptr $ \(solver, _addBuf, _assumptionRef) -> do + if funptr == nullFunPtr then do + SAT.clearLearnCallback solver + else do + let callback = mkLearnCallback funptr + SAT.setLearnCallback solver $ \clause -> do + when (length clause <= fromIntegral max_length) $ do + withArray0 0 (map fromIntegral clause) (callback info) + +foreign import ccall "dynamic" mkTerminateCallback :: FunPtr (Ptr a -> IO CInt) -> (Ptr a -> IO CInt) + +foreign import ccall "dynamic" mkLearnCallback :: FunPtr (Ptr a -> Ptr Int32 -> IO ()) -> (Ptr a -> Ptr Int32 -> IO ()) diff --git a/app/toysat-ipasir/cbits.c b/app/toysat-ipasir/cbits.c new file mode 100644 --- /dev/null +++ b/app/toysat-ipasir/cbits.c @@ -0,0 +1,48 @@ +#include "HsFFI.h" +#ifdef __GLASGOW_HASKELL__ +#include "Rts.h" +#endif +#include "cabal_macros.h" +#include "ipasir.h" + +extern void *toysat_ipasir_init(); +extern void toysat_ipasir_release(void * solver); + +static _Bool initialized = 0; + +IPASIR_API +const char *ipasir_signature() +{ + return "toysat-" VERSION_toysolver; +} + +IPASIR_API +void *ipasir_init(void) +{ + if (!initialized) { + int argc = 1; + char *argv[] = { "toysat-ipasir", NULL }; + char **pargv = argv; + +#if __GLASGOW_HASKELL__ >= 703 + RtsConfig conf = defaultRtsConfig; + conf.rts_opts_enabled = RtsOptsAll; + hs_init_ghc(&argc, &pargv, conf); +#else + hs_init(&argc, &argv); +#endif + + initialized = 1; + } + + return toysat_ipasir_init(); +} + +IPASIR_API +void ipasir_release(void* solver) +{ + toysat_ipasir_release(solver); + + // Note that we do not call hs_exit() here because GHC currently + // does not support reinitializing the RTS after shutdown. +} diff --git a/app/toysat-ipasir/ipasir.def b/app/toysat-ipasir/ipasir.def new file mode 100644 --- /dev/null +++ b/app/toysat-ipasir/ipasir.def @@ -0,0 +1,11 @@ +EXPORTS +ipasir_signature +ipasir_init +ipasir_release +ipasir_add +ipasir_assume +ipasir_solve +ipasir_val +ipasir_failed +ipasir_set_terminate +ipasir_set_learn diff --git a/app/toysat-ipasir/ipasir.h b/app/toysat-ipasir/ipasir.h new file mode 100644 --- /dev/null +++ b/app/toysat-ipasir/ipasir.h @@ -0,0 +1,209 @@ +/* + * Part of the generic incremental SAT API called 'ipasir'. + * + * Copyright (c) 2014, Tomas Balyo, Karlsruhe Institute of Technology. + * Copyright (c) 2014, Armin Biere, Johannes Kepler University. + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to + * deal in the Software without restriction, including without limitation the + * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or + * sell copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS + * IN THE SOFTWARE. + */ +#ifndef ipasir_h_INCLUDED +#define ipasir_h_INCLUDED + +#include + +/* + * In this header, the macro IPASIR_API is defined as follows: + * - if IPASIR_SHARED_LIB is not defined, then IPASIR_API is defined, but empty. + * - if IPASIR_SHARED_LIB is defined... + * - ...and if BUILDING_IPASIR_SHARED_LIB is not defined, IPASIR_API is + * defined to contain symbol visibility attributes for importing symbols + * of a DSO (including the __declspec rsp. __attribute__ keywords). + * - ...and if BUILDING_IPASIR_SHARED_LIB is defined, IPASIR_API is defined + * to contain symbol visibility attributes for exporting symbols from a + * DSO (including the __declspec rsp. __attribute__ keywords). + */ + +#if defined(IPASIR_SHARED_LIB) + #if defined(_WIN32) || defined(__CYGWIN__) + #if defined(BUILDING_IPASIR_SHARED_LIB) + #if defined(__GNUC__) + #define IPASIR_API __attribute__((dllexport)) + #elif defined(_MSC_VER) + #define IPASIR_API __declspec(dllexport) + #endif + #else + #if defined(__GNUC__) + #define IPASIR_API __attribute__((dllimport)) + #elif defined(_MSC_VER) + #define IPASIR_API __declspec(dllimport) + #endif + #endif + #elif defined(__GNUC__) + #define IPASIR_API __attribute__((visibility("default"))) + #endif + + #if !defined(IPASIR_API) + #if !defined(IPASIR_SUPPRESS_WARNINGS) + #warning "Unknown compiler. Not adding visibility information to IPASIR symbols." + #warning "Define IPASIR_SUPPRESS_WARNINGS to suppress this warning." + #endif + #define IPASIR_API + #endif +#else + #define IPASIR_API +#endif + +#ifdef __cplusplus +extern "C" { +#endif + +/** + * Return the name and the version of the incremental SAT + * solving library. + */ +IPASIR_API const char * ipasir_signature (); + +/** + * Construct a new solver and return a pointer to it. + * Use the returned pointer as the first parameter in each + * of the following functions. + * + * Required state: N/A + * State after: INPUT + */ +IPASIR_API void * ipasir_init (); + +/** + * Release the solver, i.e., all its resoruces and + * allocated memory (destructor). The solver pointer + * cannot be used for any purposes after this call. + * + * Required state: INPUT or SAT or UNSAT + * State after: undefined + */ +IPASIR_API void ipasir_release (void * solver); + +/** + * Add the given literal into the currently added clause + * or finalize the clause with a 0. Clauses added this way + * cannot be removed. The addition of removable clauses + * can be simulated using activation literals and assumptions. + * + * Required state: INPUT or SAT or UNSAT + * State after: INPUT + * + * Literals are encoded as (non-zero) integers as in the + * DIMACS formats. They have to be smaller or equal to + * INT_MAX and strictly larger than INT_MIN (to avoid + * negation overflow). This applies to all the literal + * arguments in API functions. + */ +IPASIR_API void ipasir_add (void * solver, int32_t lit_or_zero); + +/** + * Add an assumption for the next SAT search (the next call + * of ipasir_solve). After calling ipasir_solve all the + * previously added assumptions are cleared. + * + * Required state: INPUT or SAT or UNSAT + * State after: INPUT + */ +IPASIR_API void ipasir_assume (void * solver, int32_t lit); + +/** + * Solve the formula with specified clauses under the specified assumptions. + * If the formula is satisfiable the function returns 10 and the state of the solver is changed to SAT. + * If the formula is unsatisfiable the function returns 20 and the state of the solver is changed to UNSAT. + * If the search is interrupted (see ipasir_set_terminate) the function returns 0 and the state of the solver is changed to INPUT. + * This function can be called in any defined state of the solver. + * Note that the state of the solver _during_ execution of 'ipasir_solve' is undefined. + * + * Required state: INPUT or SAT or UNSAT + * State after: INPUT or SAT or UNSAT + */ +IPASIR_API int ipasir_solve (void * solver); + +/** + * Get the truth value of the given literal in the found satisfying + * assignment. Return 'lit' if True, '-lit' if False; + * 'ipasir_val(lit)' may return '0' if the found assignment is satisfying for both valuations of lit. + * Each solution that agrees with all non-zero values of ipasir_val() is a model of the formula. + * + * This function can only be used if ipasir_solve has returned 10 + * and no 'ipasir_add' nor 'ipasir_assume' has been called + * since then, i.e., the state of the solver is SAT. + * + * Required state: SAT + * State after: SAT + */ +IPASIR_API int ipasir_val (void * solver, int32_t lit); + +/** + * Check if the given assumption literal was used to prove the + * unsatisfiability of the formula under the assumptions + * used for the last SAT search. Return 1 if so, 0 otherwise. + * + * The formula remains unsatisfiable even just under assumption literals for which ipasir_failed() returns 1. + * Note that for literals 'lit' which are not assumption literals, the behavior of 'ipasir_failed(lit)' is not specified. + * + * This function can only be used if ipasir_solve has returned 20 and + * no ipasir_add or ipasir_assume has been called since then, i.e., + * the state of the solver is UNSAT. + * + * Required state: UNSAT + * State after: UNSAT + */ +IPASIR_API int ipasir_failed (void * solver, int32_t lit); + +/** + * Set a callback function used to indicate a termination requirement to the + * solver. The solver will periodically call this function and check its return + * value during the search. The ipasir_set_terminate function can be called in any + * state of the solver, the state remains unchanged after the call. + * The callback function is of the form "int terminate(void * data)" + * - it returns a non-zero value if the solver should terminate. + * - the solver calls the callback function with the parameter "data" + * having the value passed in the ipasir_set_terminate function (2nd parameter). + * + * Required state: INPUT or SAT or UNSAT + * State after: INPUT or SAT or UNSAT + */ +IPASIR_API void ipasir_set_terminate (void * solver, void * data, int (*terminate)(void * data)); + +/** + * Set a callback function used to extract learned clauses up to a given length from the + * solver. The solver will call this function for each learned clause that satisfies + * the maximum length (literal count) condition. The ipasir_set_learn function can be called in any + * state of the solver, the state remains unchanged after the call. + * The callback function is of the form "void learn(void * data, int * clause)" + * - the solver calls the callback function with the parameter "data" + * having the value passed in the ipasir_set_learn function (2nd parameter). + * - the argument "clause" is a pointer to a null terminated integer array containing the learned clause. + * the solver can change the data at the memory location that "clause" points to after the function call. + * + * Required state: INPUT or SAT or UNSAT + * State after: INPUT or SAT or UNSAT + */ +IPASIR_API void ipasir_set_learn (void * solver, void * data, int max_length, void (*learn)(void * data, int32_t * clause)); + +#ifdef __cplusplus +} // closing extern "C" +#endif + +#endif diff --git a/app/toysat-ipasir/ipasir.map b/app/toysat-ipasir/ipasir.map new file mode 100644 --- /dev/null +++ b/app/toysat-ipasir/ipasir.map @@ -0,0 +1,9 @@ +{ + global: + extern "C" { + ipasir_*; + }; + + local: + *; +}; diff --git a/app/toysat/UBCSAT.hs b/app/toysat/UBCSAT.hs deleted file mode 100644 --- a/app/toysat/UBCSAT.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} -module UBCSAT - ( ubcsatBest - , ubcsatBestFeasible - , ubcsatMany - , Options (..) - ) where - -import Control.Exception -import Control.Monad -import Data.Array.IArray -import Data.Char -import Data.Default -import Data.Either -import Data.Function -import Data.List -#if MIN_VERSION_megaparsec(6,0,0) -import Data.Void -#endif -import System.Directory -import System.IO -import System.IO.Temp -import System.Process -import Text.Megaparsec hiding (try) -#if MIN_VERSION_megaparsec(6,0,0) -import Text.Megaparsec.Char -#else -import Text.Megaparsec.String -#endif - -import qualified ToySolver.FileFormat.CNF as CNF -import qualified ToySolver.SAT.Types as SAT - -data Options - = Options - { optCommand :: FilePath - , optTempDir :: Maybe FilePath - , optProblem :: CNF.WCNF - , optProblemFile :: Maybe FilePath - , optVarInit :: [SAT.Lit] - } - -instance Default Options where - def = Options - { optCommand = "ubcsat" - , optTempDir = Nothing - , optProblem = - CNF.WCNF - { CNF.wcnfNumVars = 0 - , CNF.wcnfNumClauses = 0 - , CNF.wcnfTopCost = 1 - , CNF.wcnfClauses = [] - } - , optProblemFile = Nothing - , optVarInit = [] - } - -ubcsatBestFeasible :: Options -> IO (Maybe (Integer, SAT.Model)) -ubcsatBestFeasible opt = do - ret <- ubcsatBest opt - case ret of - Nothing -> return Nothing - Just (obj,_) -> - if obj < CNF.wcnfTopCost (optProblem opt) then - return ret - else - return Nothing - -ubcsatBest :: Options -> IO (Maybe (Integer, SAT.Model)) -ubcsatBest opt = do - sols <- ubcsatMany opt - case sols of - [] -> return Nothing - _ -> return $ Just $ minimumBy (compare `on` fst) sols - -ubcsatMany :: Options -> IO [(Integer, SAT.Model)] -ubcsatMany opt = do - dir <- case optTempDir opt of - Just dir -> return dir - Nothing -> getTemporaryDirectory - - let f fname - | null (optVarInit opt) = ubcsat' opt fname Nothing - | otherwise = do - withTempFile dir ".txt" $ \varInitFile h -> do - hSetBinaryMode h True - hSetBuffering h (BlockBuffering Nothing) - forM_ (split 10 (optVarInit opt)) $ \xs -> do - hPutStrLn h $ intercalate " " (map show xs) - hClose h - ubcsat' opt fname (Just varInitFile) - - case optProblemFile opt of - Just fname -> f fname - Nothing -> do - withTempFile dir ".wcnf" $ \fname h -> do - hClose h - CNF.writeFile fname (optProblem opt) - f fname - -ubcsat' :: Options -> FilePath -> Maybe FilePath -> IO [(Integer, SAT.Model)] -ubcsat' opt fname varInitFile = do - let wcnf = optProblem opt - let args = - [ "-w" | ".wcnf" `isSuffixOf` map toLower fname] ++ - [ "-alg", "irots" - , "-seed", "0" - , "-runs", "10" - , "-cutoff", show (CNF.wcnfNumVars wcnf * 50) - , "-timeout", show (10 :: Int) - , "-gtimeout", show (30 :: Int) - , "-solve" - , "-r", "bestsol" - , "-inst", fname - ] ++ - (case varInitFile of - Nothing -> [] - Just fname2 -> ["-varinitfile", fname2]) - stdinStr = "" - - putStrLn $ "c Running " ++ show (optCommand opt) ++ " with " ++ show args - ret <- try $ readProcess (optCommand opt) args stdinStr - case ret of - Left (err :: IOError) -> do - forM_ (lines (show err)) $ \l -> do - putStr "c " >> putStrLn l - return [] - Right s -> do - forM_ (lines s) $ \l -> putStr "c " >> putStrLn l - return $ scanSolutions (CNF.wcnfNumVars wcnf) s - -scanSolutions :: Int -> String -> [(Integer, SAT.Model)] -scanSolutions nv s = rights $ map (parse (solution nv) "") $ lines s - -#if MIN_VERSION_megaparsec(6,0,0) -solution :: MonadParsec Void String m => Int -> m (Integer, SAT.Model) -#else -solution :: Int -> Parser (Integer, SAT.Model) -#endif -solution nv = do - skipSome digitChar - space - _ <- char '0' <|> char '1' - space - obj <- liftM read $ some digitChar - space - values <- many ((char '0' >> return False) <|> (char '1' >> return True)) - let m = array (1, nv) (zip [1..] values) - return (obj, m) - - -split :: Int -> [a] -> [[a]] -split n = go - where - go [] = [] - go xs = - case splitAt n xs of - (ys, zs) -> ys : go zs diff --git a/app/toysat/toysat.hs b/app/toysat/toysat.hs --- a/app/toysat/toysat.hs +++ b/app/toysat/toysat.hs @@ -7,10 +7,10 @@ -- Module : toysat -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (ScopedTypeVariables, CPP) +-- Portability : non-portable -- -- A toy-level SAT solver based on CDCL. -- @@ -37,7 +37,9 @@ import Data.IORef import Data.List import Data.Maybe +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ord import qualified Data.Vector.Unboxed as V import Data.Version @@ -47,9 +49,6 @@ import qualified Options.Applicative import System.IO import System.Exit -#if !MIN_VERSION_time(1,5,0) -import System.Locale (defaultTimeLocale) -#endif import System.Clock import System.FilePath import qualified System.Info as SysInfo @@ -61,8 +60,9 @@ #endif import qualified Data.PseudoBoolean as PBFile -import qualified ToySolver.Data.MIP as MIP -import qualified ToySolver.Data.MIP.Solution.Gurobi as GurobiSol +import qualified Numeric.Optimization.MIP as MIP +import qualified Numeric.Optimization.MIP.Solution.Gurobi as GurobiSol + import ToySolver.Converter import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.FileFormat as FF @@ -72,15 +72,16 @@ import qualified ToySolver.SAT.Encoder.Integer as Integer import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin import qualified ToySolver.SAT.Encoder.PBNLC as PBNLC -import qualified ToySolver.SAT.MessagePassing.SurveyPropagation as SP +import qualified ToySolver.SAT.Solver.MessagePassing.SurveyPropagation as SP +import qualified ToySolver.SAT.Solver.SLS.UBCSAT as UBCSAT import qualified ToySolver.SAT.MUS as MUS import qualified ToySolver.SAT.MUS.Enum as MUSEnum import ToySolver.SAT.Printer import ToySolver.Version import ToySolver.Internal.Util (showRational, setEncodingChar8) -import qualified UBCSAT + -- ------------------------------------------------------------------------ data Mode = ModeSAT | ModeMUS | ModeAllMUS | ModePB | ModeWBO | ModeMaxSAT | ModeMIP @@ -154,7 +155,7 @@ modeOption :: Parser (Maybe Mode) -- modeOption = liftA msum $ T.sequenceA $ map optional $ - modeOption = optional $ foldr (<|>) empty + modeOption = optional $ F.asum [ flag' ModeSAT $ long "sat" <> help "solve boolean satisfiability problem in .cnf file" , flag' ModeMUS $ long "mus" <> help "solve minimally unsatisfiable subset problem in .gcnf or .cnf file" , flag' ModeAllMUS $ long "all-mus" <> help "enumerate minimally unsatisfiable subset of .gcnf or .cnf file" @@ -408,17 +409,6 @@ <> long "version" <> help "Show version" -#if !MIN_VERSION_optparse_applicative(0,13,0) - --- | Convert a function producing a 'Maybe' into a reader. -maybeReader :: (String -> Maybe a) -> ReadM a -maybeReader f = eitherReader $ \arg -> - case f arg of - Nothing -> Left $ "cannot parse value `" ++ arg ++ "'" - Just a -> Right a - -#endif - main :: IO () main = do #ifdef FORCE_CHAR8 @@ -452,7 +442,7 @@ putCommentLine $ printf "command line = %s" (show fullArgs) let timelim = optTimeout opt * 10^(6::Int) - + ret <- timeout (if timelim > 0 then timelim else (-1)) $ do solver <- newSolver opt case mode of @@ -599,7 +589,7 @@ mainSAT :: Options -> SAT.Solver -> IO () mainSAT opt solver = do ret <- case optInput opt of - "-" -> liftM FF.parse $ BS.hGetContents stdin + "-" -> liftM FF.parse BS.getContents fname -> FF.parseFile fname case ret of Left err -> hPrint stderr err >> exitFailure @@ -695,7 +685,7 @@ mainMUS opt solver = do gcnf <- case optInput opt of "-" -> do - s <- BS.hGetContents stdin + s <- BS.getContents case FF.parse s of Left err -> hPutStrLn stderr err >> exitFailure Right gcnf -> return gcnf @@ -773,7 +763,7 @@ i <- readIORef mcsCounter modifyIORef' mcsCounter (+1) let mcs2 = sort $ map (sel2idx !) $ IntSet.toList mcs - putCommentLine $ "MCS #" ++ show (i :: Int) ++ ": " ++ intercalate " " (map show mcs2) + putCommentLine $ "MCS #" ++ show (i :: Int) ++ ": " ++ unwords (map show mcs2) , MUSEnum.optOnMUSFound = \mus -> do i <- readIORef musCounter modifyIORef' musCounter (+1) @@ -789,7 +779,7 @@ mainPB :: Options -> SAT.Solver -> IO () mainPB opt solver = do ret <- case optInput opt of - "-" -> liftM FF.parse $ BS.hGetContents stdin + "-" -> liftM FF.parse BS.getContents fname -> FF.parseFile fname case ret of Left err -> hPutStrLn stderr err >> exitFailure @@ -812,14 +802,14 @@ PBFile.Ge -> PBNLC.addPBNLAtLeast pbnlc lhs rhs PBFile.Eq -> PBNLC.addPBNLExactly pbnlc lhs rhs - spHighlyBiased <- + spHighlyBiased <- if optInitSP opt then do let (cnf, _) = pb2sat formula initPolarityUsingSP solver nv (CNF.cnfNumVars cnf) [(1.0, clause) | clause <- CNF.cnfClauses cnf] else return IntMap.empty - initialModel <- + initialModel <- if optLocalSearchInitial opt then do let (wbo, info1) = pb2wbo formula (wcnf, info2) = wbo2maxsat wbo @@ -843,7 +833,7 @@ forM_ (assocs m2) $ \(v, val) -> do SAT.setVarPolarity solver v val if obj < CNF.wcnfTopCost wcnf then - return $ Just m2 + return $ Just m2 else return Nothing else @@ -907,7 +897,7 @@ mainWBO :: Options -> SAT.Solver -> IO () mainWBO opt solver = do ret <- case optInput opt of - "-" -> liftM FF.parse $ BS.hGetContents stdin + "-" -> liftM FF.parse BS.getContents fname -> FF.parseFile fname case ret of Left err -> hPutStrLn stderr err >> exitFailure @@ -971,7 +961,7 @@ [(v, SAT.evalPBConstraint a constr) | (v, constr) <- defsPB] let softConstrs = [(c, constr) | (Just c, constr) <- PBFile.wboConstraints formula] - + pbo <- PBO.newOptimizer2 solver objLin $ \m -> sum [if SAT.evalPBConstraint m constr then 0 else w | (w,constr) <- softConstrs] @@ -1005,7 +995,7 @@ putSLine "SATISFIABLE" pbPrintModel stdout m nv writeSOLFile opt m (Just val) nv - else + else putSLine "UNKNOWN" -- ------------------------------------------------------------------------ @@ -1037,7 +1027,7 @@ case optInput opt of fname@"-" -> do F.mapM_ (\s -> hSetEncoding stdin =<< mkTextEncoding s) (optFileEncoding opt) - s <- hGetContents stdin + s <- getContents case MIP.parseLPString def fname s of Right mip -> return mip Left err -> @@ -1074,27 +1064,27 @@ forM_ (Map.toList m) $ \(v, val) -> do printf "v %s = %d\n" (MIP.fromVar v) val hFlush stdout - + writeSol :: Map MIP.Var Integer -> Rational -> IO () - writeSol m val = do + writeSol m objVal = do case optWriteFile opt of Nothing -> return () Just fname -> do let sol = MIP.Solution { MIP.solStatus = MIP.StatusUnknown - , MIP.solObjectiveValue = Just $ Scientific.fromFloatDigits (fromRational val :: Double) + , MIP.solObjectiveValue = Just $ Scientific.fromFloatDigits (fromRational objVal :: Double) , MIP.solVariables = Map.fromList [(v, fromIntegral val) | (v,val) <- Map.toList m] } GurobiSol.writeFile fname sol - + pbo <- PBO.newOptimizer solver linObj setupOptimizer pbo opt PBO.setOnUpdateBestSolution pbo $ \_ val -> do putOLine $ showRational (optPrintRational opt) (transformObjValBackward val) - + finally (PBO.optimize pbo) $ do - ret <- PBO.getBestSolution pbo - case ret of + ret' <- PBO.getBestSolution pbo + case ret' of Nothing -> do b <- PBO.isUnsat pbo if b diff --git a/app/toysmt/ToySolver/SMT/SMTLIB2Solver.hs b/app/toysmt/ToySolver/SMT/SMTLIB2Solver.hs --- a/app/toysmt/ToySolver/SMT/SMTLIB2Solver.hs +++ b/app/toysmt/ToySolver/SMT/SMTLIB2Solver.hs @@ -153,10 +153,10 @@ case t of TermSpecConstant (SpecConstantNumeral n) -> SMT.EValue $ SMT.ValRational $ fromInteger n TermSpecConstant (SpecConstantDecimal s) -> SMT.EValue $ SMT.ValRational $ fst $ head $ readFloat s - TermSpecConstant (SpecConstantHexadecimal s) -> + TermSpecConstant (SpecConstantHexadecimal s) -> let n = fst $ head $ readHex s in SMT.EValue $ SMT.ValBitVec $ BV.nat2bv (length s * 4) n - TermSpecConstant (SpecConstantBinary s) -> + TermSpecConstant (SpecConstantBinary s) -> SMT.EValue $ SMT.ValBitVec $ BV.fromDescBits [c == '1' | c <- s] TermSpecConstant c@(SpecConstantString _s) -> E.throw $ SMT.Error (show c) TermQualIdentifier qid -> f qid [] @@ -218,7 +218,7 @@ TermQualIdentifier $ QIdentifierAs (ISymbol $ "@" ++ show n) (sortToSortTerm s) fsymToIdentifier :: SMT.FSym -> Identifier -fsymToIdentifier (SMT.FSym f indexes) = +fsymToIdentifier (SMT.FSym f indexes) = case indexes of [] -> ISymbol (T.unpack $ unintern f) _ -> I_Symbol (T.unpack $ unintern f) (map g indexes) @@ -278,7 +278,7 @@ produceAssignmentRef <- newIORef False produceModelsRef <- newIORef False produceUnsatAssumptionsRef <- newIORef False - produceUnsatCoresRef <- newIORef False + produceUnsatCoresRef <- newIORef False globalDeclarationsRef <- newIORef False unsatAssumptionsRef <- newIORef undefined return $ @@ -359,7 +359,7 @@ GetModel -> CmdGetModelResponse <$> getModel solver GetProof -> CmdGetProofResponse <$> getProof solver GetUnsatCore -> CmdGetUnsatCoreResponse <$> getUnsatCore solver - GetUnsatAssumptions -> CmdGetUnsatAssumptionsResponse <$> getUnsatAssumptions solver + GetUnsatAssumptions -> CmdGetUnsatAssumptionsResponse <$> getUnsatAssumptions solver Reset -> const (CmdGenResponse Success) <$> reset solver ResetAssertions -> const (CmdGenResponse Success) <$> resetAssertions solver Echo s -> CmdEchoResponse <$> echo solver s @@ -377,7 +377,7 @@ runCommandString :: Solver -> String -> IO CmdResponse runCommandString solver cmd = case Parsec.parse (Parsec.spaces >> CommandsParsers.parseCommand <* Parsec.eof) "" cmd of - Left err -> + Left err -> -- GenResponse type uses strings in printed form. return $ CmdGenResponse $ Error $ "\"" ++ concat [if c == '"' then "\"\"" else [c] | c <- show err] ++ "\"" Right cmd -> @@ -518,7 +518,7 @@ return $ AttrValueSymbol (showSL b) ":print-success" -> do b <- readIORef (svPrintSuccessRef solver) - return $ AttrValueSymbol (showSL b) + return $ AttrValueSymbol (showSL b) ":produce-assertions" -> do b <- readIORef (svProduceAssertionsRef solver) return $ AttrValueSymbol (showSL b) @@ -739,7 +739,7 @@ getValue :: Solver -> [Term] -> IO GetValueResponse getValue solver ts = do - ts <- mapM (processNamed solver) ts + ts <- mapM (processNamed solver) ts mode <- readIORef (svModeRef solver) unless (mode == ModeSat) $ do E.throwIO $ SMT.Error "get-value can only be used in sat mode" @@ -792,7 +792,7 @@ args :: [Term] args = [TermQualIdentifier (QIdentifier (ISymbol x)) | SV x _ <- argsSV] f :: ([SMT.Value], SMT.Value) -> Term -> Term - f (vals,val) tm = + f (vals,val) tm = TermQualIdentifierT (QIdentifier (ISymbol "ite")) [cond, valueToTerm val, tm] where cond = diff --git a/app/toysmt/toysmt.hs b/app/toysmt/toysmt.hs --- a/app/toysmt/toysmt.hs +++ b/app/toysmt/toysmt.hs @@ -8,7 +8,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (CPP) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module Main where @@ -16,7 +16,9 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Version import Options.Applicative hiding (Parser) import qualified Options.Applicative as Opt @@ -79,7 +81,7 @@ solver <- newSolver if optInteractive opt then do mapM_ (loadFile solver) (optFiles opt) - repl solver + repl solver else do if null (optFiles opt) then repl solver diff --git a/app/toysolver.hs b/app/toysolver.hs --- a/app/toysolver.hs +++ b/app/toysolver.hs @@ -1,13 +1,14 @@ {-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------------- -- | -- Module : toysolver --- Copyright : (c) Masahiro Sakai 2011-2014 +-- Copyright : (c) Masahiro Sakai 2011-2019 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : portable +-- Portability : non-portable -- ----------------------------------------------------------------------------- @@ -21,8 +22,9 @@ import Data.Default.Class import Data.List import Data.Maybe +#if !MIN_VERSION_base(4,11,0) import Data.Monoid -import Data.Ratio +#endif import Data.Scientific (Scientific) import qualified Data.Scientific as Scientific import Data.String @@ -35,23 +37,18 @@ import qualified Data.Traversable as T import Options.Applicative hiding (Const) import System.Exit -import System.Environment -import System.FilePath -import System.Console.GetOpt import System.IO import Text.Printf -import GHC.Conc (getNumProcessors, setNumCapabilities) +import GHC.Conc (getNumProcessors) -import Data.OptDir +import qualified Numeric.Optimization.MIP as MIP +import qualified Numeric.Optimization.MIP.Solution.Gurobi as GurobiSol import ToySolver.Data.OrdRel import ToySolver.Data.FOL.Arith as FOL -import qualified ToySolver.Data.LA as LA import qualified ToySolver.Data.LA.FOL as LAFOL import qualified ToySolver.Data.Polynomial as P import qualified ToySolver.Data.AlgebraicNumber.Real as AReal -import qualified ToySolver.Data.MIP as MIP -import qualified ToySolver.Data.MIP.Solution.Gurobi as GurobiSol import qualified ToySolver.Arith.OmegaTest as OmegaTest import qualified ToySolver.Arith.Cooper as Cooper import qualified ToySolver.Arith.Simplex.Textbook.MIPSolver.Simple as TextbookMIP @@ -180,17 +177,6 @@ <> long "version" <> help "Show version" -#if !MIN_VERSION_optparse_applicative(0,13,0) - --- | Convert a function producing a 'Maybe' into a reader. -maybeReader :: (String -> Maybe a) -> ReadM a -maybeReader f = eitherReader $ \arg -> - case f arg of - Nothing -> Left $ "cannot parse value `" ++ arg ++ "'" - Just a -> Right a - -#endif - -- --------------------------------------------------------------------------- run @@ -199,10 +185,10 @@ -> MIP.Problem Rational -> (Map MIP.Var Rational -> IO ()) -> IO () -run solver opt mip printModel = do - unless (Set.null (MIP.semiContinuousVariables mip)) $ do +run solver opt prob printModel = do + unless (Set.null (MIP.semiContinuousVariables prob)) $ do hPutStrLn stderr "semi-continuous variables are not supported." - exitFailure + exitFailure case map toLower solver of s | s `elem` ["omega", "omega-test", "cooper"] -> solveByQE s | s `elem` ["old-mip"] -> solveByMIP @@ -210,7 +196,7 @@ s | s `elem` ["ct", "conti-traverso"] -> solveByContiTraverso _ -> solveByMIP2 where - vs = MIP.variables mip + vs = MIP.variables prob vsAssoc = zip (Set.toList vs) [0..] nameToVar = Map.fromList vsAssoc varToName = IntMap.fromList [(v,name) | (name,v) <- vsAssoc] @@ -219,15 +205,15 @@ compileE = foldr (+) (Const 0) . map compileT . MIP.terms compileT :: MIP.Term Rational -> Expr Rational - compileT (MIP.Term c vs) = - foldr (*) (Const c) [Var (nameToVar Map.! v) | v <- vs] + compileT (MIP.Term c vs3) = + foldr (*) (Const c) [Var (nameToVar Map.! v) | v <- vs3] - obj = compileE $ MIP.objExpr $ MIP.objectiveFunction mip + obj = compileE $ MIP.objExpr $ MIP.objectiveFunction prob cs1 = do v <- Set.toList vs let v2 = Var (nameToVar Map.! v) - let (l,u) = MIP.getBounds mip v + let (l,u) = MIP.getBounds prob v [Const x .<=. v2 | MIP.Finite x <- return l] ++ [v2 .<=. Const x | MIP.Finite x <- return u] cs2 = do @@ -236,7 +222,7 @@ , MIP.constrExpr = e , MIP.constrLB = lb , MIP.constrUB = ub - } <- MIP.constraints mip + } <- MIP.constraints prob case ind of Nothing -> do let e2 = compileE e @@ -254,7 +240,7 @@ ivs | optNoMIP opt = Set.empty - | otherwise = MIP.integerVariables mip + | otherwise = MIP.integerVariables prob vs2 = IntMap.keysSet varToName ivs2 = IntSet.fromList . map (nameToVar Map.!) . Set.toList $ ivs @@ -284,7 +270,7 @@ omegaOpt = def { OmegaTest.optCheckReal = realSolver - } + } where realSolver = case optOmegaReal opt of @@ -297,16 +283,16 @@ s -> error ("unknown solver: " ++ s) solveByMIP = do - let m = do + let prob2 = do cs' <- mapM LAFOL.fromFOLAtom (cs1 ++ cs2) obj' <- LAFOL.fromFOLExpr obj return (cs',obj') - case m of + case prob2 of Nothing -> do putSLine "UNKNOWN" exitFailure Just (cs',obj') -> - case TextbookMIP.optimize (MIP.objDir $ MIP.objectiveFunction mip) obj' cs' ivs2 of + case TextbookMIP.optimize (MIP.objDir $ MIP.objectiveFunction prob) obj' cs' ivs2 of TextbookMIP.OptUnsat -> do putSLine "UNSATISFIABLE" exitFailure @@ -320,7 +306,7 @@ printModel m2 solveByMIP2 = do - solver <- Simplex.newSolver + simplex <- Simplex.newSolver let config = def @@ -329,21 +315,21 @@ } nthreads = optNThread opt - Simplex.setConfig solver config - Simplex.setLogger solver putCommentLine - Simplex.enableTimeRecording solver - replicateM (length vsAssoc) (Simplex.newVar solver) -- XXX - Simplex.setOptDir solver $ MIP.objDir $ MIP.objectiveFunction mip - Simplex.setObj solver $ fromJust (LAFOL.fromFOLExpr obj) + Simplex.setConfig simplex config + Simplex.setLogger simplex putCommentLine + Simplex.enableTimeRecording simplex + replicateM_ (length vsAssoc) (Simplex.newVar simplex) -- XXX + Simplex.setOptDir simplex $ MIP.objDir $ MIP.objectiveFunction prob + Simplex.setObj simplex $ fromJust (LAFOL.fromFOLExpr obj) putCommentLine "Loading constraints... " - forM_ (cs1 ++ cs2) $ \c -> do - Simplex.assertAtom solver $ fromJust (LAFOL.fromFOLAtom c) + forM_ (cs1 ++ cs2) $ \c -> + Simplex.assertAtom simplex $ fromJust (LAFOL.fromFOLAtom c) putCommentLine "Loading constraints finished" - mip <- MIPSolver.newSolver solver ivs2 + mip <- MIPSolver.newSolver simplex ivs2 MIPSolver.setShowRational mip printRat MIPSolver.setLogger mip putCommentLine - MIPSolver.setOnUpdateBestSolution mip $ \m val -> putOLine (showValue val) + MIPSolver.setOnUpdateBestSolution mip $ \_m val -> putOLine (showValue val) procs <- if nthreads >= 1 @@ -371,6 +357,8 @@ putSLine "OPTIMUM FOUND" let m2 = Map.fromAscList [(v, m IntMap.! (nameToVar Map.! v)) | v <- Set.toList vs] printModel m2 + Simplex.ObjLimit -> do + error "should not happen" solveByCAD | not (IntSet.null ivs2) = do @@ -398,7 +386,7 @@ f (e1 :*: e2) = f e1 * f e2 f (e1 :/: e2) | P.deg p > 0 = error "can't handle rational expression" - | otherwise = P.mapCoeff (/ c) $ f e1 + | otherwise = P.mapCoeff (/ c) $ f e1 where p = f e2 c = P.coeff P.mone p @@ -418,8 +406,8 @@ putSLine "UNKNOWN" putCommentLine "non-linear expressions are not supported by Conti-Traverso algorithm" exitFailure - Just (linObj, linCon) -> do - case ContiTraverso.solve P.grlex vs2 (MIP.objDir $ MIP.objectiveFunction mip) linObj linCon of + Just (linObj, linCon) -> + case ContiTraverso.solve P.grlex vs2 (MIP.objDir $ MIP.objectiveFunction prob) linObj linCon of Nothing -> do putSLine "UNSATISFIABLE" exitFailure @@ -437,9 +425,9 @@ showValue = showRational printRat mipPrintModel :: Handle -> Bool -> Map MIP.Var Rational -> IO () -mipPrintModel h asRat m = do - forM_ (Map.toList m) $ \(v, val) -> do - printf "v %s = %s\n" (MIP.fromVar v) (showRational asRat val) +mipPrintModel h asRat m = + forM_ (Map.toList m) $ \(v, val) -> + hPrintf h "v %s = %s\n" (MIP.fromVar v) (showRational asRat val) putCommentLine :: String -> IO () @@ -473,30 +461,30 @@ case fromMaybe ModeMIP (optMode o) of ModeSAT -> do cnf <- FF.readFile (optInput o) - let (mip,info) = sat2ip cnf + let (mip,info2) = sat2ip cnf run (optSolver o) o (fmap fromInteger mip) $ \m -> do - let m2 = transformBackward info m + let m2 = transformBackward info2 m satPrintModel stdout m2 0 writeSOLFileSAT o m2 ModePB -> do pb <- FF.readFile (optInput o) - let (mip,info) = pb2ip pb + let (mip,info2) = pb2ip pb run (optSolver o) o (fmap fromInteger mip) $ \m -> do - let m2 = transformBackward info m + let m2 = transformBackward info2 m pbPrintModel stdout m2 0 writeSOLFileSAT o m2 ModeWBO -> do wbo <- FF.readFile (optInput o) - let (mip,info) = wbo2ip False wbo + let (mip,info2) = wbo2ip False wbo run (optSolver o) o (fmap fromInteger mip) $ \m -> do - let m2 = transformBackward info m + let m2 = transformBackward info2 m pbPrintModel stdout m2 0 writeSOLFileSAT o m2 ModeMaxSAT -> do wcnf <- FF.readFile (optInput o) - let (mip,info) = maxsat2ip False wcnf + let (mip,info2) = maxsat2ip False wcnf run (optSolver o) o (fmap fromInteger mip) $ \m -> do - let m2 = transformBackward info m + let m2 = transformBackward info2 m maxsatPrintModel stdout m2 0 writeSOLFileSAT o m2 ModeMIP -> do @@ -527,7 +515,7 @@ writeSOLFileRaw opt sol writeSOLFileRaw :: Options -> MIP.Solution Scientific -> IO () -writeSOLFileRaw opt sol = do +writeSOLFileRaw opt sol = case optWriteFile opt of Just fname -> GurobiSol.writeFile fname sol Nothing -> return () diff --git a/benchmarks/BenchmarkSubsetSum.hs b/benchmarks/BenchmarkSubsetSum.hs --- a/benchmarks/BenchmarkSubsetSum.hs +++ b/benchmarks/BenchmarkSubsetSum.hs @@ -31,7 +31,7 @@ ++ [ bench "SubsetSum" $ nf (\lhs -> SubsetSum.maxSubsetSum (V.fromList (map fromIntegral lhs)) (fromIntegral rhs)) problem2_items ] | rhs <- [50 :: Int, 100, 200, 500, 1000, 2000, 5000, 10000, 50000, 100000, 150000] - ] ++ + ] ++ [ bgroup ("problem3_" ++ show rhs) $ [ bench "KnapsackBB" $ nf (\lhs -> KnapsackBB.solve [(fromIntegral x, fromIntegral x) | x <- lhs] (fromIntegral rhs)) problem3_items , bench "SubsetSum" $ nf (\lhs -> SubsetSum.maxSubsetSum (V.fromList (map fromIntegral lhs)) (fromIntegral rhs)) problem3_items diff --git a/doc-images/MIP-Status-diagram.png b/doc-images/MIP-Status-diagram.png deleted file mode 100644 Binary files a/doc-images/MIP-Status-diagram.png and /dev/null differ diff --git a/doc-images/MIP-Status-diagram.tex b/doc-images/MIP-Status-diagram.tex deleted file mode 100644 --- a/doc-images/MIP-Status-diagram.tex +++ /dev/null @@ -1,18 +0,0 @@ -\documentclass{article} -\usepackage{tikz} -\begin{document} - -\begin{tikzpicture}[scale=.7] - \node (Optimal) at (-3,2) {Optimal}; - \node (Feasible) at (-3,0) {Feasible}; - \node (InfeasibleOrUnbounded) at (2,0) {InfeasibleOrUnbounded}; - \node (Unbounded) at (2,2) {Unbounded}; - \node (Infeasible) at (6,2) {Infeasible}; - \node (Unknown) at (0,-2) {Unknown}; - \draw (Unknown) -- (Feasible) -- (Optimal); - \draw (Feasible) -- (Unbounded); - \draw (Unknown) -- (InfeasibleOrUnbounded) -- (Unbounded); - \draw (InfeasibleOrUnbounded) -- (Infeasible); -\end{tikzpicture} - -\end{document} diff --git a/samples/programs/htc/htc.hs b/samples/programs/htc/htc.hs --- a/samples/programs/htc/htc.hs +++ b/samples/programs/htc/htc.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main where diff --git a/samples/programs/knapsack/knapsack.hs b/samples/programs/knapsack/knapsack.hs --- a/samples/programs/knapsack/knapsack.hs +++ b/samples/programs/knapsack/knapsack.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main where diff --git a/samples/programs/nonogram/nonogram.hs b/samples/programs/nonogram/nonogram.hs --- a/samples/programs/nonogram/nonogram.hs +++ b/samples/programs/nonogram/nonogram.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main where @@ -38,7 +40,7 @@ checkSolution :: Problem -> Solution -> IO () checkSolution (rows, cols) sol = do let nrows = length rows - ncols = length cols + ncols = length cols forM_ [0..nrows-1] $ \i -> do let row_i_expected = rows !! i row_i_actual = [length g | g <- group [sol ! (i,j) | j <- [0..ncols-1]], head g] @@ -63,13 +65,13 @@ bTrue <- Tseitin.encodeConj enc [] bFalse <- Tseitin.encodeDisj enc [] - + (bs :: UArray (Int,Int) SAT.Lit) <- liftM (array ((0,0),(nrows-1,ncols-1)) . concat) $ forM [0..nrows-1] $ \i -> do forM [0..ncols-1] $ \j -> do b <- SAT.newVar solver return ((i,j),b) - forM_ (zip [0..] rows) $ \(i, xs) -> do + forM_ (zip [0..] rows) $ \(i, xs) -> do ref <- newIORef Map.empty let f j [] | j >= ncols = return bTrue @@ -78,7 +80,7 @@ case Map.lookup (j,[]) m of Just b -> return b Nothing -> do - b' <- f (j+1) [] + b' <- f (j+1) [] b <- Tseitin.encodeConj enc [- (bs ! (i,j)), b'] writeIORef ref (Map.insert (j,[]) b m) return b diff --git a/samples/programs/nqueens/nqueens.hs b/samples/programs/nqueens/nqueens.hs --- a/samples/programs/nqueens/nqueens.hs +++ b/samples/programs/nqueens/nqueens.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main where diff --git a/samples/programs/numberlink/numberlink.hs b/samples/programs/numberlink/numberlink.hs --- a/samples/programs/numberlink/numberlink.hs +++ b/samples/programs/numberlink/numberlink.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} module Main where @@ -169,7 +170,7 @@ let v = vs!a!0 -- v → deg(a)=0 -- SAT.addPBAtMostSoft enc v [(1, evs Map.! e) | e <- adjacentEdges a] 0 - forM_ (adjacentEdges a) $ \e -> SAT.addClause enc [-v, -(evs Map.! e)] + forM_ (adjacentEdges a) $ \e -> SAT.addClause enc [-v, -(evs Map.! e)] -- ¬v → deg(a)=2 SAT.addPBExactlySoft enc (-v) [(1, evs Map.! e) | e <- adjacentEdges a] 2 -- ¬v → deg(a)>0 @@ -225,7 +226,7 @@ let (o1, o2) = fromJust (optOptimize opt) obj1 <- if not o1 then do - return [] + return [] else if optAssumeNoBlank opt then do v <- SAT.newVar enc SAT.addClause enc [v] @@ -265,7 +266,7 @@ k:_ -> return (a,k) [] -> mzero solEdges = Set.fromList [e | e@(a,_) <- edges, a `Set.member` usedCells] - + edges = [e | (e,ev) <- Map.toList evs, SAT.evalLit m ev] adjacents = Map.fromListWith Set.union $ concat $ [[(a, Set.singleton b), (b, Set.singleton a)] | (a,b) <- edges] usedVias = Set.fromList [(x,y,z) | ((x,y),zs) <- Map.toList cs, z <- [Set.findMin zs .. Set.findMax zs]] diff --git a/samples/programs/probsat/probsat.hs b/samples/programs/probsat/probsat.hs --- a/samples/programs/probsat/probsat.hs +++ b/samples/programs/probsat/probsat.hs @@ -13,7 +13,7 @@ import qualified ToySolver.FileFormat as FF import qualified ToySolver.FileFormat.CNF as CNF -import qualified ToySolver.SAT.SLS.ProbSAT as ProbSAT +import qualified ToySolver.SAT.Solver.SLS.ProbSAT as ProbSAT import ToySolver.SAT.Printer (maxsatPrintModel) data Options = Options diff --git a/samples/programs/shortest-path/shortest-path.hs b/samples/programs/shortest-path/shortest-path.hs --- a/samples/programs/shortest-path/shortest-path.hs +++ b/samples/programs/shortest-path/shortest-path.hs @@ -9,11 +9,13 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Data.Char import Data.Foldable (toList) -import qualified Data.HashMap.Strict as HashMap +import qualified Data.IntMap.Strict as IntMap import Data.Int import Data.List import Data.Maybe +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ord import qualified Data.Sequence as Seq import System.Console.GetOpt @@ -58,27 +60,27 @@ vs0 = map read vs' vs = if null vs0 then [1] else vs0 es <- load fname - let g :: ShortestPath.Graph Int Int64 Int - g = fmap toList $ HashMap.fromListWith (<>) [(s, Seq.singleton (t,fromIntegral w,i)) | (i,(s,t,w)) <- zip [(1::Int)..] es] + let g :: ShortestPath.Graph Int64 Int + g = fmap toList $ IntMap.fromListWith (<>) [(s, Seq.singleton (t,fromIntegral w,i)) | (i,(s,t,w)) <- zip [(1::Int)..] es] case filter (\c -> c /= '-' && c /= '_') (map toLower method) of "dijkstra" -> do let ret = ShortestPath.dijkstra ShortestPath.unit g vs _ <- evaluate ret when (PrintResult `elem` o) $ do - forM_ (sortBy (comparing fst) (HashMap.toList ret)) $ \(v, (cost,_)) -> do + forM_ (sortBy (comparing fst) (IntMap.toList ret)) $ \(v, (cost,_)) -> do putStrLn $ show v ++ ": " ++ show cost "bellmanford" -> do let ret = ShortestPath.bellmanFord ShortestPath.unit g vs _ <- evaluate ret when (PrintResult `elem` o) $ do - forM_ (sortBy (comparing fst) (HashMap.toList ret)) $ \(v, (cost,_)) -> do + forM_ (sortBy (comparing fst) (IntMap.toList ret)) $ \(v, (cost,_)) -> do putStrLn $ show v ++ ": " ++ show cost "floydwarshall" -> do let ret = ShortestPath.floydWarshall ShortestPath.unit g _ <- evaluate ret when (PrintResult `elem` o) $ do - forM_ (sortBy (comparing fst) (HashMap.toList ret)) $ \(v, m) -> do - forM_ (sortBy (comparing fst) (HashMap.toList m)) $ \(u, (cost,_)) -> do + forM_ (sortBy (comparing fst) (IntMap.toList ret)) $ \(v, m) -> do + forM_ (sortBy (comparing fst) (IntMap.toList m)) $ \(u, (cost,_)) -> do putStrLn $ show v ++ "-" ++ show u ++ ": " ++ show cost _ -> error ("unknown method: " ++ method) (_,_,errs) -> do diff --git a/samples/programs/sudoku/sudoku.hs b/samples/programs/sudoku/sudoku.hs --- a/samples/programs/sudoku/sudoku.hs +++ b/samples/programs/sudoku/sudoku.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE ScopedTypeVariables, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Main where @@ -39,16 +40,16 @@ p _ = True readBoard :: String -> Array (Int,Int) (Maybe Int) -readBoard s = array ((1,1),(9,9)) $ +readBoard s = array ((1,1),(9,9)) $ [ (idx, if isDigit c then Just (read [c]) else Nothing) | (idx, c) <- zip [(i,j) | i <- [1..9], j <- [1..9]] s ] solve :: Array (Int,Int) (Maybe Int) -> IO (Maybe (Array (Int,Int) Int)) solve board = do - solver <- SAT.newSolver + solver <- SAT.newSolver SAT.setLogger solver (hPutStrLn stderr) - + (vs :: Array (Int,Int,Int) SAT.Var) <- liftM (array ((1,1,1), (9,9,9))) $ forM [(i,j,k) | i<-[1..9], j<-[1..9], k<-[1..9]] $ \idx -> do @@ -56,7 +57,7 @@ return (idx,v) forM_ (assocs board) $ \((i,j), m) -> do - case m of + case m of Nothing -> return () Just k -> SAT.addClause solver [vs ! (i,j,k)] diff --git a/samples/programs/survey-propagation/survey-propagation.hs b/samples/programs/survey-propagation/survey-propagation.hs --- a/samples/programs/survey-propagation/survey-propagation.hs +++ b/samples/programs/survey-propagation/survey-propagation.hs @@ -10,10 +10,10 @@ import System.IO import qualified ToySolver.FileFormat as FF import qualified ToySolver.FileFormat.CNF as CNF -import qualified ToySolver.SAT.MessagePassing.SurveyPropagation as SP +import qualified ToySolver.SAT.Solver.MessagePassing.SurveyPropagation as SP #ifdef ENABLE_OPENCL import Control.Parallel.OpenCL -import qualified ToySolver.SAT.MessagePassing.SurveyPropagation.OpenCL as SPCL +import qualified ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL as SPCL #endif data Options @@ -66,7 +66,7 @@ devs <- clGetDeviceIDs platform CL_DEVICE_TYPE_ALL putStrLn $ " " ++ s ++ " (" ++ show (length devs) ++ " devices)" forM_ (zip [0..] devs) $ \(i,dev) -> do - devname <- clGetDeviceName dev + devname <- clGetDeviceName dev ts <- clGetDeviceType dev let f t = case t of diff --git a/samples/programs/svm2lp/svm2lp.hs b/samples/programs/svm2lp/svm2lp.hs --- a/samples/programs/svm2lp/svm2lp.hs +++ b/samples/programs/svm2lp/svm2lp.hs @@ -11,13 +11,16 @@ import qualified Data.Map as Map import Data.Scientific import qualified Data.Text.Lazy.IO as TLIO -import ToySolver.Data.MIP ((.==.), (.>=.)) -import qualified ToySolver.Data.MIP as MIP import System.Console.GetOpt import System.Environment import System.Exit import System.IO + +import Numeric.Optimization.MIP ((.==.), (.>=.)) +import qualified Numeric.Optimization.MIP as MIP + import ToySolver.Internal.Util (setEncodingChar8) + type Problem = [(Int, IntMap Double)] diff --git a/src/ToySolver/Arith/BoundsInference.hs b/src/ToySolver/Arith/BoundsInference.hs --- a/src/ToySolver/Arith/BoundsInference.hs +++ b/src/ToySolver/Arith/BoundsInference.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.BoundsInference -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- Portability : non-portable -- -- Tightening variable bounds by constraint propagation. --- +-- ----------------------------------------------------------------------------- module ToySolver.Arith.BoundsInference ( BoundsEnv @@ -74,14 +76,14 @@ ub = upperBound' i' case op of Eql -> return i' - Le -> return $ interval (NegInf, False) ub - Ge -> return $ interval lb (PosInf, False) - Lt -> return $ interval (NegInf, False) (strict ub) - Gt -> return $ interval (strict ub) (PosInf, False) + Le -> return $ interval (NegInf, Open) ub + Ge -> return $ interval lb (PosInf, Open) + Lt -> return $ interval (NegInf, Open) (strict ub) + Gt -> return $ interval (strict ub) (PosInf, Open) NEq -> [] -strict :: (Extended r, Bool) -> (Extended r, Bool) -strict (x, _) = (x, False) +strict :: (Extended r, Boundary) -> (Extended r, Boundary) +strict (x, _) = (x, Open) -- | tightening intervals by ceiling lower bounds and flooring upper bounds. tightenToInteger :: forall r. (RealFrac r) => Interval r -> Interval r @@ -92,18 +94,18 @@ lb2 = case x1 of Finite x -> - ( if isInteger x && not in1 + ( if isInteger x && in1 == Open then Finite (x + 1) else Finite (fromInteger (ceiling x)) - , True + , Closed ) _ -> lb ub2 = case x2 of Finite x -> - ( if isInteger x && not in2 + ( if isInteger x && in2 == Open then Finite (x - 1) else Finite (fromInteger (floor x)) - , True + , Closed ) _ -> ub diff --git a/src/ToySolver/Arith/CAD.hs b/src/ToySolver/Arith/CAD.hs --- a/src/ToySolver/Arith/CAD.hs +++ b/src/ToySolver/Arith/CAD.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.CAD -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- Portability : non-portable -- -- References: -- @@ -18,7 +20,7 @@ -- * Arnab Bhattacharyya. -- Something you should know about: Quantifier Elimination (Part I) -- --- +-- -- * Arnab Bhattacharyya. -- Something you should know about: Quantifier Elimination (Part II) -- @@ -240,7 +242,7 @@ buildSignConf ps = do ps2 <- collectPolynomials ps -- normalizePoly後の多項式の次数でソートしておく必要があるので注意 - let ts = sortBy (comparing P.deg) ps2 + let ts = sortOn P.deg ps2 --trace ("collected polynomials: " ++ prettyShow ts) $ return () foldM (flip refineSignConf) emptySignConf ts @@ -270,7 +272,7 @@ :: forall v. (Ord v, Show v, PrettyVar v) => UPolynomial (Polynomial Rational v) -> M v (UPolynomial (Polynomial Rational v)) -normalizePoly p = liftM P.fromTerms $ go $ sortBy (flip (comparing (P.deg . snd))) $ P.terms p +normalizePoly p = liftM P.fromTerms $ go $ sortOn (Down . P.deg . snd) $ P.terms p where go [] = return [] go xxs@((c,d):xs) = @@ -281,10 +283,10 @@ refineSignConf :: forall v. (Show v, Ord v, PrettyVar v) => UPolynomial (Polynomial Rational v) - -> SignConf (Polynomial Rational v) + -> SignConf (Polynomial Rational v) -> M v (SignConf (Polynomial Rational v)) refineSignConf p conf = liftM (extendIntervals 0) $ mapM extendPoint conf - where + where extendPoint :: (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) -> M v (Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign) @@ -292,7 +294,7 @@ s <- signAt pt m return (Point pt, Map.insert p s m) extendPoint x = return x - + extendIntervals :: Int -> [(Cell (Polynomial Rational v), Map (UPolynomial (Polynomial Rational v)) Sign)] @@ -315,7 +317,7 @@ , n1 + 1 ) extendIntervals _ xs = xs - + signAt :: Point (Polynomial Rational v) -> Map (UPolynomial (Polynomial Rational v)) Sign -> M v Sign signAt PosInf _ = signCoeff (P.lc P.nat p) signAt NegInf _ = do @@ -350,7 +352,7 @@ emptyAssumption = (Map.empty, []) propagate :: Ord v => Assumption v -> Maybe (Assumption v) -propagate = go +propagate = go where go a = do a' <- f a @@ -368,7 +370,7 @@ return (m, gb) where f :: Assumption v -> Maybe (Assumption v) - f (m, gb) = + f (m, gb) = case Map.partition (Set.singleton Zero ==) m of (m0, m) -> do let gb' = GB.basis P.grevlex (Map.keys m0 ++ gb) @@ -420,7 +422,7 @@ findSample :: Ord v => Model v -> Cell (Polynomial Rational v) -> Maybe AReal findSample m cell = case evalCell m cell of - Point (RootOf p n) -> + Point (RootOf p n) -> Just $ AReal.realRoots p !! n Interval lb ub -> case I.simplestRationalWithin (f lb I.<..< f ub) of @@ -460,7 +462,7 @@ projectN vs cs = do (cs', mt) <- projectN' vs (map f cs) return (map g cs', mt) - where + where f (OrdRel lhs op rhs) = (lhs - rhs, h op) where h Le = [Zero, Neg] @@ -491,7 +493,7 @@ loop [] cs = return (cs, id) loop (v:vs) cs = do (cs2, cell:_) <- project' [(P.toUPolynomialOf p v, ss) | (p, ss) <- cs] - let mt1 m = + let mt1 m = let Just val = findSample m cell in seq val $ Map.insert v val m (cs3, mt2) <- loop vs cs2 @@ -569,7 +571,7 @@ (Ord v, PrettyVar v, Show v) => [(SignConf (Polynomial Rational v), Assumption v)] -> IO () -dumpSignConf x = +dumpSignConf x = forM_ x $ \(conf, as) -> do putStrLn "============" mapM_ putStrLn $ showSignConf conf diff --git a/src/ToySolver/Arith/ContiTraverso.hs b/src/ToySolver/Arith/ContiTraverso.hs --- a/src/ToySolver/Arith/ContiTraverso.hs +++ b/src/ToySolver/Arith/ContiTraverso.hs @@ -3,7 +3,7 @@ -- Module : ToySolver.Arith.ContiTraverso -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -21,7 +21,7 @@ -- -- * 伊藤雅史, , 平林 隆一, "整数計画問題のための b-Gröbner 基底変換アルゴリズム," -- --- +-- -- ----------------------------------------------------------------------------- module ToySolver.Arith.ContiTraverso diff --git a/src/ToySolver/Arith/Cooper.hs b/src/ToySolver/Arith/Cooper.hs --- a/src/ToySolver/Arith/Cooper.hs +++ b/src/ToySolver/Arith/Cooper.hs @@ -4,19 +4,19 @@ -- Module : ToySolver.Arith.Cooper -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (FlexibleInstances) +-- Portability : portable -- -- Naive implementation of Cooper's algorithm -- -- Reference: --- +-- -- * --- +-- -- * --- +-- -- See also: -- -- * diff --git a/src/ToySolver/Arith/Cooper/Base.hs b/src/ToySolver/Arith/Cooper/Base.hs --- a/src/ToySolver/Arith/Cooper/Base.hs +++ b/src/ToySolver/Arith/Cooper/Base.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -7,19 +8,19 @@ -- Module : ToySolver.Arith.Cooper.Base -- Copyright : (c) Masahiro Sakai 2011-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances) +-- Portability : non-portable -- -- Naive implementation of Cooper's algorithm -- -- Reference: --- +-- -- * --- +-- -- * --- +-- -- See also: -- -- * @@ -125,7 +126,7 @@ instance IsEqRel (LA.Expr Integer) QFFormula where a .==. b = eqZ a b a ./=. b = notB $ eqZ a b - + instance IsOrdRel (LA.Expr Integer) QFFormula where ordRel op lhs rhs = case op of @@ -328,7 +329,7 @@ -- formula1のなかの x < t を真に t < x を偽に置き換えた論理式 formula2 :: QFFormula formula2 = simplify $ BoolExpr.fold f formula1 - where + where f lit@(IsPos e) = case LA.lookupCoeff x e of Nothing -> Atom lit @@ -395,7 +396,7 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solveQFFormula :: VarSet -> QFFormula -> Maybe (Model Integer) solveQFFormula vs formula = listToMaybe $ do (formula2, mt) <- projectCasesN vs formula @@ -408,7 +409,7 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) solve vs cs = solveQFFormula vs $ andB $ map fromLAAtom cs @@ -418,7 +419,7 @@ -- * @FV(φ)@ must be a subset of @{x1,…,xn}@. -- -- * @I@ is a set of integer variables and must be a subset of @{x1,…,xn}@. --- +-- solveQFLIRAConj :: VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) solveQFLIRAConj vs cs ivs = listToMaybe $ do (cs2, mt) <- FM.projectN rvs cs @@ -429,8 +430,8 @@ -- --------------------------------------------------------------------------- -testHagiya :: QFFormula -testHagiya = fst $ project 1 $ andB [c1, c2, c3] +_testHagiya :: QFFormula +_testHagiya = fst $ project 1 $ andB [c1, c2, c3] where [x,y,z] = map LA.var [1..3] c1 = x .<. (y ^+^ y) @@ -443,8 +444,8 @@ (2y>z+1 ∧ 3|z+1) ∨ (2y>z+2 ∧ 3|z+2) ∨ (2y>z+3 ∧ 3|z+3) -} -test3 :: QFFormula -test3 = fst $ project 1 $ andB [p1,p2,p3,p4] +_test3 :: QFFormula +_test3 = fst $ project 1 $ andB [p1,p2,p3,p4] where x = LA.var 0 y = LA.var 1 diff --git a/src/ToySolver/Arith/Cooper/FOL.hs b/src/ToySolver/Arith/Cooper/FOL.hs --- a/src/ToySolver/Arith/Cooper/FOL.hs +++ b/src/ToySolver/Arith/Cooper/FOL.hs @@ -4,11 +4,11 @@ -- Module : ToySolver.Arith.Cooper.FOL -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable --- +-- ----------------------------------------------------------------------------- module ToySolver.Arith.Cooper.FOL ( eliminateQuantifiers @@ -58,7 +58,7 @@ -- * returns @'Unsat'@ when such @M@ does not exists, and -- -- * returns @'Unknown'@ when @φ@ is beyond LIA. --- +-- solveFormula :: VarSet -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Integer solveFormula vs formula = case eliminateQuantifiers formula of diff --git a/src/ToySolver/Arith/DifferenceLogic.hs b/src/ToySolver/Arith/DifferenceLogic.hs --- a/src/ToySolver/Arith/DifferenceLogic.hs +++ b/src/ToySolver/Arith/DifferenceLogic.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Arith.DifferenceLogic -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : portable @@ -18,13 +18,14 @@ ----------------------------------------------------------------------------- module ToySolver.Arith.DifferenceLogic ( SimpleAtom (..) + , Var , Diff (..) , solve ) where import Data.Hashable -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.Monoid @@ -34,42 +35,46 @@ infixl 6 :- infix 4 :<= +type Var = Int + -- | Difference of two variables -data Diff v = v :- v +data Diff = Var :- Var deriving (Eq, Ord, Show) -- | @a :- b :<= k@ represents /a - b ≤ k/ -data SimpleAtom v b = Diff v :<= b +data SimpleAtom b = Diff :<= b deriving (Eq, Ord, Show) --- | Takes labeled list of constraints, and returns either +-- | Takes labeled list of constraints, and returns eithera -- -- * unsatisfiable set of constraints as a set of labels, or -- -- * satisfying assignment. solve - :: (Hashable label, Eq label, Hashable v, Eq v, Real b) - => [(label, SimpleAtom v b)] - -> Either (HashSet label) (HashMap v b) + :: (Hashable label, Eq label, Real b) + => [(label, SimpleAtom b)] + -> Either (HashSet label) (IntMap b) solve xs = case bellmanFordDetectNegativeCycle (monoid' (\(_,_,_,l) -> Endo (l:))) g d of Just f -> Left $ HashSet.fromList $ appEndo f [] Nothing -> Right $ fmap (\(c,_) -> - c) d where vs = HashSet.toList $ HashSet.fromList [v | (_,(a :- b :<= _)) <- xs, v <- [a,b]] - g = HashMap.fromList [(a,[(b,k,l)]) | (l,(a :- b :<= k)) <- xs] + g = IntMap.fromList [(a,[(b,k,l)]) | (l,(a :- b :<= k)) <- xs] d = bellmanFord lastInEdge g vs -- M = {a−b ≤ 2, b−c ≤ 3, c−a ≤ −3} -_test_sat :: Either (HashSet Int) (HashMap Char Int) +_test_sat :: Either (HashSet Int) (IntMap Int) _test_sat = solve xs where - xs :: [(Int, SimpleAtom Char Int)] - xs = [(1, ('a' :- 'b' :<= 2)), (2, ('b' :- 'c' :<= 3)), (3, ('c' :- 'a' :<= -3))] + xs :: [(Int, SimpleAtom Int)] + xs = [(1, (a :- b :<= 2)), (2, (b :- c :<= 3)), (3, (c :- a :<= -3))] + [a,b,c] = [0..2] -- M = {a−b ≤ 2, b−c ≤ 3, c−a ≤ −7} -_test_unsat :: Either (HashSet Int) (HashMap Char Int) +_test_unsat :: Either (HashSet Int) (IntMap Int) _test_unsat = solve xs where - xs :: [(Int, SimpleAtom Char Int)] - xs = [(1, ('a' :- 'b' :<= 2)), (2, ('b' :- 'c' :<= 3)), (3, ('c' :- 'a' :<= -7))] + xs :: [(Int, SimpleAtom Int)] + xs = [(1, (a :- b :<= 2)), (2, (b :- c :<= 3)), (3, (c :- a :<= -7))] + [a,b,c] = [0..2] diff --git a/src/ToySolver/Arith/FourierMotzkin.hs b/src/ToySolver/Arith/FourierMotzkin.hs --- a/src/ToySolver/Arith/FourierMotzkin.hs +++ b/src/ToySolver/Arith/FourierMotzkin.hs @@ -4,13 +4,13 @@ -- Module : ToySolver.Arith.FourierMotzkin -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Naïve implementation of Fourier-Motzkin Variable Elimination --- +-- -- Reference: -- -- * diff --git a/src/ToySolver/Arith/FourierMotzkin/Base.hs b/src/ToySolver/Arith/FourierMotzkin/Base.hs --- a/src/ToySolver/Arith/FourierMotzkin/Base.hs +++ b/src/ToySolver/Arith/FourierMotzkin/Base.hs @@ -1,17 +1,20 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.FourierMotzkin.Base -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- Naïve implementation of Fourier-Motzkin Variable Elimination --- +-- -- Reference: -- -- * @@ -153,7 +156,7 @@ fromLAAtom (OrdRel a op b) = atomR' op (toRat a) (toRat b) where atomR' :: RelOp -> Rat -> Rat -> DNF Constr - atomR' op a b = + atomR' op a b = case op of Le -> DNF [[a `leR` b]] Lt -> DNF [[a `ltR` b]] @@ -187,9 +190,9 @@ [ NegInf <..< Finite (evalRat model x) | x <- us2 ] boundsToConstrs :: Bounds -> Maybe [Constr] -boundsToConstrs (ls1, ls2, us1, us2) = simplify $ +boundsToConstrs (ls1, ls2, us1, us2) = simplify $ [ x `leR` y | x <- ls1, y <- us1 ] ++ - [ x `ltR` y | x <- ls1, y <- us2 ] ++ + [ x `ltR` y | x <- ls1, y <- us2 ] ++ [ x `ltR` y | x <- ls2, y <- us1 ] ++ [ x `ltR` y | x <- ls2, y <- us2 ] @@ -259,10 +262,10 @@ let mt1 m = IM.insert v (evalRat m vdef) m (zs, mt2) <- f (IS.delete v vs) [subst1Constr v (fromRat vdef) c | c <- ys] return (zs, mt1 . mt2) - | otherwise = + | otherwise = case IS.minView vs of Nothing -> return (xs, id) -- should not happen - Just (v,vs') -> + Just (v,vs') -> case collectBounds v xs of (bnd, rest) -> do cond <- boundsToConstrs bnd @@ -293,7 +296,7 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Rational) solve vs cs = msum [solve' vs cs2 | cs2 <- unDNF (constraintsToDNF cs)] diff --git a/src/ToySolver/Arith/FourierMotzkin/FOL.hs b/src/ToySolver/Arith/FourierMotzkin/FOL.hs --- a/src/ToySolver/Arith/FourierMotzkin/FOL.hs +++ b/src/ToySolver/Arith/FourierMotzkin/FOL.hs @@ -1,4 +1,15 @@ {-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.FourierMotzkin.FOL +-- Copyright : (c) Masahiro Sakai 2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.Arith.FourierMotzkin.FOL ( solveFormula , eliminateQuantifiers @@ -21,14 +32,14 @@ -- --------------------------------------------------------------------------- --- | +-- | -- -- * @'solveFormula' {x1,…,xm} φ@ returns @'Sat' M@ such that @M ⊧_LRA φ@ when such @M@ exists, -- -- * returns @'Unsat'@ when such @M@ does not exists, and -- -- * returns @'Unknown'@ when @φ@ is beyond LRA. --- +-- solveFormula :: VarSet -> FOL.Formula (FOL.Atom Rational) -> FOL.SatResult Rational solveFormula vs formula = case eliminateQuantifiers' formula of @@ -41,9 +52,9 @@ -- | Eliminate quantifiers and returns equivalent quantifier-free formula. -- -- @'eliminateQuantifiers' φ@ returns @(ψ, lift)@ such that: --- +-- -- * ψ is a quantifier-free formula and @LRA ⊢ ∀y1, …, yn. φ ↔ ψ@ where @{y1, …, yn} = FV(φ) ⊇ FV(ψ)@, and --- +-- -- * if @M ⊧_LRA ψ@ then @lift M ⊧_LRA φ@. -- -- φ may or may not be a closed formula. diff --git a/src/ToySolver/Arith/FourierMotzkin/Optimization.hs b/src/ToySolver/Arith/FourierMotzkin/Optimization.hs --- a/src/ToySolver/Arith/FourierMotzkin/Optimization.hs +++ b/src/ToySolver/Arith/FourierMotzkin/Optimization.hs @@ -4,13 +4,13 @@ -- Module : ToySolver.Arith.FourierMotzkin.Optimization -- Copyright : (c) Masahiro Sakai 2014-2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Naïve implementation of Fourier-Motzkin Variable Elimination --- +-- -- Reference: -- -- * @@ -42,11 +42,11 @@ -- * @lift@ is a function, that takes @x ∈ I@ and returns the feasible solution with objective value /better than or equal to/ @x@. -- -- Note: --- +-- -- * @'Interval.lowerBound' i@ (resp. @'Interval.upperBound' i@) is the optimal value in case of minimization (resp. maximization). -- -- * If @I@ is empty, then the problem is INFEASIBLE. --- +-- optimize :: VarSet -> OptDir -> LA.Expr Rational -> [LA.Atom Rational] -> (Interval Rational, Rational -> Model Rational) optimize vs dir obj cs = (ival, m) where diff --git a/src/ToySolver/Arith/LPUtil.hs b/src/ToySolver/Arith/LPUtil.hs --- a/src/ToySolver/Arith/LPUtil.hs +++ b/src/ToySolver/Arith/LPUtil.hs @@ -1,3 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Arith.LPUtil +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.Arith.LPUtil ( toStandardForm , toStandardForm' diff --git a/src/ToySolver/Arith/MIP.hs b/src/ToySolver/Arith/MIP.hs --- a/src/ToySolver/Arith/MIP.hs +++ b/src/ToySolver/Arith/MIP.hs @@ -1,21 +1,23 @@ -{-# LANGUAGE ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.MIP -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, Rank2Types) +-- Portability : non-portable -- -- Naïve implementation of MIP solver based on Simplex module --- +-- -- Reference: -- -- * --- +-- -- * Ralph E. Gomory. -- \"An Algorithm for the Mixed Integer Problem\", Technical Report -- RM-2597, 1960, The Rand Corporation, Santa Monica, CA. @@ -25,12 +27,12 @@ -- \"Outline of an algorithm for integer solutions to linear programs\". -- Bull. Amer. Math. Soc., Vol. 64, No. 5. (1958), pp. 275-278. -- --- +-- -- * R. C. Daniel and Martyn Jeffreys. -- \"Unboundedness in Integer and Discrete Programming L.P. Relaxations\" -- The Journal of the Operational Research Society, Vol. 30, No. 12. (1979) -- --- +-- ----------------------------------------------------------------------------- module ToySolver.Arith.MIP ( @@ -303,7 +305,7 @@ else printf "%.2f%%" (fromRational (abs (dualBound - val) * 100 / abs val) :: Double) return (p, g) d <- showValue solver dualBound - + let range = case dir of OptMin -> p ++ " >= " ++ d diff --git a/src/ToySolver/Arith/OmegaTest.hs b/src/ToySolver/Arith/OmegaTest.hs --- a/src/ToySolver/Arith/OmegaTest.hs +++ b/src/ToySolver/Arith/OmegaTest.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Arith.OmegaTest -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -25,7 +25,7 @@ -- ----------------------------------------------------------------------------- module ToySolver.Arith.OmegaTest - ( + ( -- * Solving Model , solve diff --git a/src/ToySolver/Arith/OmegaTest/Base.hs b/src/ToySolver/Arith/OmegaTest/Base.hs --- a/src/ToySolver/Arith/OmegaTest/Base.hs +++ b/src/ToySolver/Arith/OmegaTest/Base.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.OmegaTest.Base -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- (incomplete) implementation of Omega Test -- @@ -67,7 +70,7 @@ -- ^ optCheckReal is used for checking whether real shadow is satisfiable. -- -- * If it returns @True@, the real shadow may or may not be satisfiable. - -- + -- -- * If it returns @False@, the real shadow must be unsatisfiable } @@ -159,8 +162,8 @@ evalBoundsZ :: Model Integer -> BoundsZ -> IntervalZ evalBoundsZ model (ls,us) = - foldl' intersectZ univZ $ - [ (Just (ceiling (LA.eval model x % c)), Nothing) | (x,c) <- ls ] ++ + foldl' intersectZ univZ $ + [ (Just (ceiling (LA.eval model x % c)), Nothing) | (x,c) <- ls ] ++ [ (Nothing, Just (floor (LA.eval model x % c))) | (x,c) <- us ] collectBoundsZ :: Var -> [Constr] -> (BoundsZ, [Constr]) @@ -169,7 +172,7 @@ phi :: Constr -> (BoundsZ,[Constr]) -> (BoundsZ,[Constr]) phi constr@(IsNonneg t) ((ls,us),xs) = case LA.extract v t of - (c,t') -> + (c,t') -> case c `compare` 0 of EQ -> ((ls, us), constr : xs) GT -> (((negateV t', c) : ls, us), xs) -- 0 ≤ cx + M ⇔ -M/c ≤ x @@ -266,7 +269,7 @@ xk_def = (- signum ak * m) *^ LA.var sigma ^+^ LA.fromTerms [(signum ak * (a `zmod` m), x) | (a,x) <- LA.terms e, x /= xk] -- e2 is normalized version of (LA.applySubst1 xk xk_def e). - e2 = (- abs ak) *^ LA.var sigma ^+^ + e2 = (- abs ak) *^ LA.var sigma ^+^ LA.fromTerms [((floor (a%m + 1/2) + (a `zmod` m)), x) | (a,x) <- LA.terms e, x /= xk] assert (m *^ e2 == LA.applySubst1 xk xk_def e) $ return () let mt :: Model Integer -> Model Integer @@ -296,7 +299,7 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solve :: Options -> VarSet -> [LA.Atom Rational] -> Maybe (Model Integer) solve opt vs cs = msum [solve' opt vs cs | cs <- unDNF dnf] where @@ -325,7 +328,7 @@ -- * @FV(φ)@ must be a subset of @{x1,…,xn}@. -- -- * @I@ is a set of integer variables and must be a subset of @{x1,…,xn}@. --- +-- solveQFLIRAConj :: Options -> VarSet -> [LA.Atom Rational] -> VarSet -> Maybe (Model Rational) solveQFLIRAConj opt vs cs ivs = listToMaybe $ do (cs2, mt) <- FM.projectN rvs cs diff --git a/src/ToySolver/Arith/Simplex.hs b/src/ToySolver/Arith/Simplex.hs --- a/src/ToySolver/Arith/Simplex.hs +++ b/src/ToySolver/Arith/Simplex.hs @@ -1,21 +1,27 @@ -{-# LANGUAGE ScopedTypeVariables, Rank2Types, TypeOperators, TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.Simplex -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, Rank2Types, TypeOperators, TypeSynonymInstances, FlexibleInstances, TypeFamilies, CPP) +-- Portability : non-portable -- -- Naïve implementation of Simplex method --- +-- -- Reference: -- -- * --- +-- -- * Bruno Dutertre and Leonardo de Moura. -- A Fast Linear-Arithmetic Solver for DPLL(T). -- Computer Aided Verification In Computer Aided Verification, Vol. 4144 (2006), pp. 81-94. @@ -347,7 +353,7 @@ "largest-coefficient" -> Just PivotStrategyLargestCoefficient _ -> Nothing -{-# DEPRECATED nVars "Use setConfig instead" #-} +{-# DEPRECATED setPivotStrategy "Use setConfig instead" #-} setPivotStrategy :: PrimMonad m => GenericSolverM m v -> PivotStrategy -> m () setPivotStrategy solver ps = modifyConfig solver $ \config -> config{ configPivotStrategy = ps } @@ -500,7 +506,7 @@ c = c1 * c2 c1 = fromIntegral $ foldl' lcm 1 [denominator c | (c, _) <- LA.terms e] c2 = signum $ head ([c | (c,x) <- LA.terms e] ++ [1]) - + assertLower :: (PrimMonad m, SolverValue v) => GenericSolverM m v -> Var -> v -> m () assertLower solver x l = assertLB solver x (Just (l, IntSet.empty)) @@ -512,7 +518,7 @@ assertLB solver x (Just (l, cidSet)) = do l0 <- getLB solver x u0 <- getUB solver x - case (l0,u0) of + case (l0,u0) of (Just (l0', _), _) | l <= l0' -> return () (_, Just (u0', cidSet2)) | u0' < l -> do setExplanation solver $ cidSet `IntSet.union` cidSet2 @@ -558,7 +564,7 @@ setRow solver v e = do modifyMutVar (svTableau solver) $ \t -> IntMap.insert v (LA.applySubst t e) t - modifyMutVar (svModel solver) $ \m -> + modifyMutVar (svModel solver) $ \m -> IntMap.insert v (LA.evalLinear m (toValue 1) e) m setOptDir :: PrimMonad m => GenericSolverM m v -> OptDir -> m () @@ -950,7 +956,7 @@ prune solver opt = case objLimit opt of Nothing -> return False - Just lim -> do + Just lim -> do o <- getObjValue solver dir <- getOptDir solver case dir of @@ -1127,9 +1133,9 @@ return result showDelta :: Bool -> Delta Rational -> String -showDelta asRatio v = +showDelta asRatio v = case v of - (Delta r k) -> + (Delta r k) -> f r ++ case compare k 0 of EQ -> "" @@ -1171,7 +1177,7 @@ endCPU <- getTime ProcessCPUTime endWC <- getTime Monotonic let durationSecs :: TimeSpec -> TimeSpec -> Double - durationSecs start end = fromIntegral (toNanoSecs (end `diffTimeSpec` start)) / 10^(9::Int) + durationSecs start end = fromIntegral (toNanoSecs (end `diffTimeSpec` start)) / 10^(9::Int) (log solver . printf "cpu time = %.3fs") (durationSecs startCPU endCPU) (log solver . printf "wall clock time = %.3fs") (durationSecs startWC endWC) return result @@ -1257,7 +1263,7 @@ log solver "Assignments and Bounds:" objVal <- getValue solver objVar log solver $ printf "beta(obj) = %s" (showValue True objVal) - xs <- variables solver + xs <- variables solver forM_ xs $ \x -> do l <- getLB solver x u <- getUB solver x diff --git a/src/ToySolver/Arith/Simplex/Simple.hs b/src/ToySolver/Arith/Simplex/Simple.hs --- a/src/ToySolver/Arith/Simplex/Simple.hs +++ b/src/ToySolver/Arith/Simplex/Simple.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Arith.Simplex.Simple -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -40,7 +40,7 @@ Simplex.assertAtomEx solver (fmap (LA.applySubst s') a) ret <- Simplex.check solver if ret then do - m <- Simplex.getModel solver + m <- Simplex.getModel solver return $ Just $ mtrans m else return Nothing diff --git a/src/ToySolver/Arith/Simplex/Textbook.hs b/src/ToySolver/Arith/Simplex/Textbook.hs --- a/src/ToySolver/Arith/Simplex/Textbook.hs +++ b/src/ToySolver/Arith/Simplex/Textbook.hs @@ -1,17 +1,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.Simplex.Textbook -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- Naïve implementation of Simplex method --- +-- -- Reference: -- -- * @@ -119,7 +120,7 @@ normalizeRow :: (Num r, Eq r) => Tableau r -> Row r -> Row r normalizeRow a (row0,val0) = obj' where - obj' = g $ foldl' f (IM.empty, val0) $ + obj' = g $ foldl' f (IM.empty, val0) $ [ case IM.lookup j a of Nothing -> (IM.singleton j x, 0) Just (row,val) -> (IM.map ((-x)*) (IM.delete j row), -x*val) @@ -166,7 +167,7 @@ vs = IM.keysSet tbl' isFeasible :: Real r => Tableau r -> Bool -isFeasible tbl = +isFeasible tbl = and [val >= 0 | (v, (_,val)) <- IM.toList tbl, v /= objRowIndex] isOptimal :: Real r => OptDir -> Tableau r -> Bool @@ -178,7 +179,7 @@ OptMax -> (0>) isImproving :: Real r => OptDir -> Tableau r -> Tableau r -> Bool -isImproving OptMin from to = currentObjValue to <= currentObjValue from +isImproving OptMin from to = currentObjValue to <= currentObjValue from isImproving OptMax from to = currentObjValue to >= currentObjValue from -- --------------------------------------------------------------------------- @@ -262,7 +263,7 @@ tbl1' = go tbl1 go tbl2 | currentObjValue tbl2 == 0 = tbl2 - | otherwise = + | otherwise = case primalPivot optdir tbl2 of PivotSuccess tbl2' -> assert (isImproving optdir tbl2 tbl2') $ go tbl2' PivotFinished -> assert (isOptimal optdir tbl2) tbl2 diff --git a/src/ToySolver/Arith/Simplex/Textbook/LPSolver.hs b/src/ToySolver/Arith/Simplex/Textbook/LPSolver.hs --- a/src/ToySolver/Arith/Simplex/Textbook/LPSolver.hs +++ b/src/ToySolver/Arith/Simplex/Textbook/LPSolver.hs @@ -1,17 +1,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.Simplex.Textbook.LPSolver -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- Naïve implementation of Simplex method --- +-- -- Reference: -- -- * @@ -128,9 +129,9 @@ -- | Add a contraint and maintain feasibility condition by introducing artificial variable (if necessary). -- -- * Disequality is not supported. --- +-- -- * Unlike 'addConstraint', an equality contstraint becomes one row with an artificial variable. --- +-- addConstraintWithArtificialVariable :: Real r => LA.Atom r -> LP r () addConstraintWithArtificialVariable c = do c2 <- expandDefs' c @@ -162,7 +163,7 @@ -- * Disequality is not supported. -- -- * Unlike 'addConstraintWithArtificialVariable', an equality constraint becomes two rows. --- +-- addConstraint :: Real r => LA.Atom r -> LP r () addConstraint c = do OrdRel lhs rop rhs <- expandDefs' c diff --git a/src/ToySolver/Arith/Simplex/Textbook/LPSolver/Simple.hs b/src/ToySolver/Arith/Simplex/Textbook/LPSolver/Simple.hs --- a/src/ToySolver/Arith/Simplex/Textbook/LPSolver/Simple.hs +++ b/src/ToySolver/Arith/Simplex/Textbook/LPSolver/Simple.hs @@ -1,14 +1,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.Simplex.Textbook.LPSolver.Simple -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- High-Level API for LPSolver.hs -- @@ -70,7 +71,7 @@ LPSolver.Unbounded -> return Unbounded LPSolver.Optimum -> do m <- getModel vs - tbl <- getTableau + tbl <- getTableau return $ Optimum (Simplex.currentObjValue tbl) m where vs = vars cs `IS.union` vars obj @@ -95,7 +96,7 @@ test_3_2 :: Bool test_3_2 = - uncurry maximize example_3_2 == + uncurry maximize example_3_2 == Optimum (27/5) (IM.fromList [(1,1/5),(2,0),(3,8/5)]) example_3_5 :: (LA.Expr Rational, [LA.Atom Rational]) @@ -259,8 +260,8 @@ uncurry minimize kuhn_7_3 == Optimum (-2) (IM.fromList [(1,2),(2,0),(3,0),(4,2),(5,0),(6,2),(7,0)]) -testAll :: Bool -testAll = and +_testAll :: Bool +_testAll = and [ test_3_2 , test_3_5 , test_4_1 diff --git a/src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs b/src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs --- a/src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs +++ b/src/ToySolver/Arith/Simplex/Textbook/MIPSolver/Simple.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Arith.Simplex.Textbook.MIPSolver.Simple @@ -8,10 +9,10 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- References: --- +-- -- * [Gomory1960] -- Ralph E. Gomory. -- An Algorithm for the Mixed Integer Problem, Technical Report @@ -78,7 +79,7 @@ minimize = optimize OptMin optimize :: RealFrac r => OptDir -> LA.Expr r -> [LA.Atom r] -> VarSet -> OptResult r -optimize optdir obj cs ivs = +optimize optdir obj cs ivs = case mkInitialNode optdir obj cs ivs of Left err -> case err of @@ -97,8 +98,8 @@ -} case OmegaTest.solveQFLIRAConj def (vars cs `IS.union` ivs) (map conv cs) ivs of Nothing -> OptUnsat - Just _ -> Unbounded - Right (node0, ivs2) -> + Just _ -> Unbounded + Right (node0, ivs2) -> case traverseBBTree optdir obj ivs2 node0 of Left ErrUnbounded -> error "shoud not happen" Left ErrUnsat -> OptUnsat @@ -200,7 +201,7 @@ ] svs = [execState (addConstraint c) (ndSolver node) | c <- cs] in Just $ [node{ ndSolver = sv, ndDepth = ndDepth node + 1 } | Just sv <- map reopt svs] - + where tbl :: Simplex.Tableau r tbl = ndTableau node @@ -236,16 +237,16 @@ ] ivs = IS.singleton 4 -test1 :: Bool -test1 = result==expected +_test1 :: Bool +_test1 = result==expected where (optdir, obj, cs, ivs) = example1 result, expected :: OptResult Rational result = optimize optdir obj cs ivs expected = Optimum (245/2) (IM.fromList [(1,40),(2,21/2),(3,39/2),(4,3)]) -test1' :: Bool -test1' = result==expected +_test1' :: Bool +_test1' = result==expected where (optdir, obj, cs, ivs) = example1 f OptMin = OptMax @@ -271,8 +272,8 @@ ] ivs = IS.fromList [1,2] -test2 :: Bool -test2 = result == expected +_test2 :: Bool +_test2 = result == expected where result, expected :: OptResult Rational result = optimize optdir obj cs ivs diff --git a/src/ToySolver/Arith/VirtualSubstitution.hs b/src/ToySolver/Arith/VirtualSubstitution.hs --- a/src/ToySolver/Arith/VirtualSubstitution.hs +++ b/src/ToySolver/Arith/VirtualSubstitution.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Arith.VirtualSubstitution -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -12,10 +12,10 @@ -- Naive implementation of virtual substitution -- -- Reference: --- +-- -- * V. Weispfenning. The complexity of linear problems in fields. -- Journal of Symbolic Computation, 5(1-2): 3-27, Feb.-Apr. 1988. --- +-- -- * Hirokazu Anai, Shinji Hara. Parametric Robust Control by Quantifier Elimination. -- J.JSSAC, Vol. 10, No. 1, pp. 41-51, 2003. -- @@ -142,7 +142,7 @@ * if @M ⊧_LRA ψ_i@ then @lift_i M ⊧_LRA φ@. -} projectCasesN :: VarSet -> QFFormula -> [(QFFormula, Model Rational -> Model Rational)] -projectCasesN vs = f (IS.toList vs) +projectCasesN vs = f (IS.toList vs) where f [] phi = return (phi, id) f (v:vs) phi = do @@ -182,7 +182,7 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solveQFFormula :: VarSet -> QFFormula -> Maybe (Model Rational) solveQFFormula vs formula = listToMaybe $ do (formula2, mt) <- projectCasesN vs formula @@ -195,6 +195,6 @@ -- such @M@ exists, returns @Nothing@ otherwise. -- -- @FV(φ)@ must be a subset of @{x1,…,xn}@. --- +-- solve :: VarSet -> [LA.Atom Rational] -> Maybe (Model Rational) solve vs cs = solveQFFormula vs (andB [Atom c | c <- cs]) diff --git a/src/ToySolver/BitVector.hs b/src/ToySolver/BitVector.hs --- a/src/ToySolver/BitVector.hs +++ b/src/ToySolver/BitVector.hs @@ -1,3 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.BitVector +-- Copyright : (c) Masahiro Sakai 2016 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.BitVector ( module ToySolver.BitVector.Base diff --git a/src/ToySolver/BitVector/Base.hs b/src/ToySolver/BitVector/Base.hs --- a/src/ToySolver/BitVector/Base.hs +++ b/src/ToySolver/BitVector/Base.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,9 +9,10 @@ -- Module : ToySolver.BitVector.Base -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.BitVector.Base @@ -45,7 +47,9 @@ import Data.Bits import Data.Map (Map) import qualified Data.Map as Map +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ord import qualified Data.Semigroup as Semigroup import qualified Data.Vector as V @@ -118,7 +122,7 @@ {-# MINIMAL (bvule | bvult), (bvsle | bvslt) #-} -- ------------------------------------------------------------------------ - + newtype BV = BV (VU.Vector Bool) deriving (Eq) @@ -171,7 +175,7 @@ bit = error "bit is not implemented" - setBit x@(BV bs) i + setBit x@(BV bs) i | 0 <= i && i < w = BV $ bs VG.// [(i,True)] | otherwise = x where @@ -211,7 +215,7 @@ bvor (BV bs1) (BV bs2) | VG.length bs1 /= VG.length bs2 = error "width mismatch" | otherwise = BV $ VG.zipWith (||) bs1 bs2 - bvxor (BV bs1) (BV bs2) + bvxor (BV bs1) (BV bs2) | VG.length bs1 /= VG.length bs2 = error "width mismatch" | otherwise = BV $ VG.zipWith (/=) bs1 bs2 diff --git a/src/ToySolver/BitVector/Solver.hs b/src/ToySolver/BitVector/Solver.hs --- a/src/ToySolver/BitVector/Solver.hs +++ b/src/ToySolver/BitVector/Solver.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,13 +8,14 @@ -- Module : ToySolver.BitVector.Solver -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.BitVector.Solver - ( + ( -- * BitVector solver Solver , newSolver @@ -158,11 +160,11 @@ m <- SAT.getModel (svSATSolver solver) vss <- Vec.getElems (svVars solver) let f = fromAscBits . map (SAT.evalLit m) . VG.toList - isZero = not . or . toAscBits + isZero' = not . or . toAscBits env = VG.fromList [f vs | vs <- vss] xs <- readIORef (svDivRemTable solver) - let divTable = Map.fromList [(f s, f d) | (s,t,d,_r) <- xs, isZero (f t)] - remTable = Map.fromList [(f s, f r) | (s,t,_d,r) <- xs, isZero (f t)] + let divTable = Map.fromList [(f s, f d) | (s,t,d,_r) <- xs, isZero' (f t)] + remTable = Map.fromList [(f s, f r) | (s,t,_d,r) <- xs, isZero' (f t)] return (env, divTable, remTable) explain :: Solver -> IO IntSet @@ -170,7 +172,7 @@ xs <- SAT.getFailedAssumptions (svSATSolver solver) size <- Vec.getSize (svContexts solver) m <- Vec.read (svContexts solver) (size - 1) - return $ IntSet.fromList $ catMaybes [m IntMap.! x | x <- xs] + return $ IntSet.fromList $ catMaybes [m IntMap.! x | x <- IntSet.toList xs] pushBacktrackPoint :: Solver -> IO () pushBacktrackPoint solver = do @@ -265,11 +267,7 @@ SQ.enqueue q x forM_ xss $ \xs -> do -#if MIN_VERSION_vector(0,11,0) VG.imapM insert xs -#else - VG.mapM (uncurry insert) (VG.indexed xs) -#endif let loop i ret | i >= w = do @@ -355,7 +353,7 @@ e = bs VG.! j Tseitin.encodeITE enc b t e foldM go s (zip [(0::Int)..] (VG.toList t)) - + encodeLShr :: Tseitin.Encoder IO -> SBV -> SBV -> IO SBV encodeLShr enc s t = do let w = VG.length s @@ -407,7 +405,7 @@ when (w /= VG.length t) $ error "invalid width" if w == 0 then return VG.empty - else do + else do s' <- encodeNegate (svTseitin solver) s t' <- encodeNegate (svTseitin solver) t let msb_s = VG.last s diff --git a/src/ToySolver/Combinatorial/BipartiteMatching.hs b/src/ToySolver/Combinatorial/BipartiteMatching.hs --- a/src/ToySolver/Combinatorial/BipartiteMatching.hs +++ b/src/ToySolver/Combinatorial/BipartiteMatching.hs @@ -1,5 +1,7 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.BipartiteMatching @@ -8,11 +10,11 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- Portability : non-portable -- -- This module provides functions for computing several kind of bipartite --- matching. --- +-- matching. +-- -- Reference: -- -- * Friedrich Eisenbrand. “Linear and Discrete Optimization”. @@ -20,7 +22,7 @@ -- ----------------------------------------------------------------------------- module ToySolver.Combinatorial.BipartiteMatching - ( + ( -- * Maximum cardinality bipartite matching maximumCardinalityMatching @@ -58,7 +60,7 @@ -> IntSet -- ^ vertex set B -> [(Int,Int)] -- ^ set of edges E⊆A×B -> IntMap Int -maximumCardinalityMatching _as bs es = +maximumCardinalityMatching _as bs es = case maximumCardinalityMatching' bs (\b -> IntMap.findWithDefault IntSet.empty b e_b2a) IntMap.empty of (m, _, _) -> m where @@ -149,7 +151,7 @@ tbl :: IntMap (IntMap w) tbl = IntMap.fromListWith IntMap.union [(a, (IntMap.singleton b v)) | (a,b,v) <- w] f a b = do - t <- IntMap.lookup a tbl + t <- IntMap.lookup a tbl v <- IntMap.lookup b t guard $ v >= 0 return v @@ -368,7 +370,7 @@ | IntMap.size cb /= IntSet.size bs = Nothing | otherwise = case maximumCardinalityMatching as bs es of - m -> + m -> let ma = IntMap.keysSet m mb = IntSet.fromList $ IntMap.elems m m2 = Set.unions diff --git a/src/ToySolver/Combinatorial/HittingSet/DAA.hs b/src/ToySolver/Combinatorial/HittingSet/DAA.hs --- a/src/ToySolver/Combinatorial/HittingSet/DAA.hs +++ b/src/ToySolver/Combinatorial/HittingSet/DAA.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- @@ -9,7 +9,7 @@ -- Module : ToySolver.Combinatorial.HittingSet.DAA -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable @@ -23,7 +23,7 @@ -- in Proceedings of the Sixteenth ACM SIGACT-SIGMOD-SIGART Symposium -- on Principles of Database Systems, ser. PODS '97. 1997, pp. 209-216. -- --- +-- -- * [BaileyStuckey2015] -- J. Bailey and P. Stuckey, Discovery of minimal unsatisfiable -- subsets of constraints using hitting set dualization," in Practical diff --git a/src/ToySolver/Combinatorial/HittingSet/FredmanKhachiyan1996.hs b/src/ToySolver/Combinatorial/HittingSet/FredmanKhachiyan1996.hs --- a/src/ToySolver/Combinatorial/HittingSet/FredmanKhachiyan1996.hs +++ b/src/ToySolver/Combinatorial/HittingSet/FredmanKhachiyan1996.hs @@ -54,7 +54,6 @@ import Control.Exception (assert) import Control.Monad import Data.Foldable (all, any) -import Data.Function import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import Data.List hiding (all, any, intersect) @@ -165,7 +164,7 @@ -- | @'isRedundant' F@ tests whether /F/ contains redundant implicants. isRedundant :: Set IntSet -> Bool -isRedundant = loop . sortBy (compare `on` IntSet.size) . Set.toList +isRedundant = loop . sortOn IntSet.size . Set.toList where loop :: [IntSet] -> Bool loop [] = False @@ -176,7 +175,7 @@ -- | Removes redundant implicants from a given DNF. deleteRedundancy :: Set IntSet -> Set IntSet -deleteRedundancy = foldl' f Set.empty . sortBy (compare `on` IntSet.size) . Set.toList +deleteRedundancy = foldl' f Set.empty . sortOn IntSet.size . Set.toList where f :: Set IntSet -> IntSet -> Set IntSet f xss ys = @@ -291,7 +290,7 @@ -- If they are indeed mutually dual it returns @Nothing@, otherwise -- it returns @Just cs@ such that {xi ↦ (if xi∈cs then True else False) | i∈{1…n}} -- is a solution of f(x1,…,xn) = g(¬x1,…,xn)). --- +-- -- Note that this function does not care about redundancy of DNFs. -- -- Complexity: /O(n^o(log n))/ where @n = 'Set.size' f + 'Set.size' g@. diff --git a/src/ToySolver/Combinatorial/HittingSet/GurvichKhachiyan1999.hs b/src/ToySolver/Combinatorial/HittingSet/GurvichKhachiyan1999.hs --- a/src/ToySolver/Combinatorial/HittingSet/GurvichKhachiyan1999.hs +++ b/src/ToySolver/Combinatorial/HittingSet/GurvichKhachiyan1999.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.HittingSet.GurvichKhachiyan1999 @@ -9,7 +10,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : portable +-- Portability : non-portable -- -- References: -- @@ -81,13 +82,13 @@ -- CNF representation /f/ and DNF representation of /f/ respectively. -- -- Given a subset /C' ⊆ C/ and /D' ⊆ D/, @'findPrimeImplicateOrPrimeImplicant' S f C' D'@ returns --- +-- -- * @Just (Left I)@ where I ∈ C \\ C', -- -- * @Just (Right I)@ where J ∈ D \\ D', or -- -- * @Nothing@ if /C'=C/ and /D'=D/. --- +-- findPrimeImplicateOrPrimeImplicant :: IntSet -- ^ Set of variables /V/ -> (IntSet -> Bool) -- ^ A monotone boolean function /f/ from /{0,1}^|V| ≅ P(V)/ to @Bool@ @@ -145,15 +146,15 @@ _evalCNF cnf xs = and [not $ IntSet.null $ is `IntSet.intersection` xs | is <- Set.toList cnf] -f, g :: Set IntSet -f = Set.fromList $ map IntSet.fromList [[2,4,7], [7,8], [9]] -g = Set.fromList $ map IntSet.fromList [[7,9], [4,8,9], [2,8,9]] +_f, _g :: Set IntSet +_f = Set.fromList $ map IntSet.fromList [[2,4,7], [7,8], [9]] +_g = Set.fromList $ map IntSet.fromList [[7,9], [4,8,9], [2,8,9]] -testA1, testA2, testA3, testA4 :: Maybe ImplicateOrImplicant -testA1 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF f) Set.empty f -testA2 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF f) (Set.singleton (IntSet.fromList [2,8,9])) f -testA3 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF f) (Set.fromList [IntSet.fromList [2,8,9], IntSet.fromList [4,8,9]]) f -testA4 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF f) (Set.fromList [IntSet.fromList [2,8,9], IntSet.fromList [4,8,9], IntSet.fromList [7,9]]) f +_testA1, _testA2, _testA3, _testA4 :: Maybe ImplicateOrImplicant +_testA1 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF _f) Set.empty _f +_testA2 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF _f) (Set.singleton (IntSet.fromList [2,8,9])) _f +_testA3 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF _f) (Set.fromList [IntSet.fromList [2,8,9], IntSet.fromList [4,8,9]]) _f +_testA4 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF _f) (Set.fromList [IntSet.fromList [2,8,9], IntSet.fromList [4,8,9], IntSet.fromList [7,9]]) _f -testB1 :: Maybe ImplicateOrImplicant -testB1 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF f) g Set.empty +_testB1 :: Maybe ImplicateOrImplicant +_testB1 = findPrimeImplicateOrPrimeImplicant (IntSet.fromList [2,4,7,8,9]) (evalDNF _f) _g Set.empty diff --git a/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs b/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs --- a/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs +++ b/src/ToySolver/Combinatorial/HittingSet/HTCBDD.hs @@ -1,14 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.HittingSet.HTCBDD -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (DeriveDataTypeable) +-- Portability : non-portable -- -- Wrapper for htcbdd command. -- @@ -31,7 +32,6 @@ import qualified Data.IntSet as IntSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.List import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable @@ -77,7 +77,7 @@ minimalHittingSets opt es = do withSystemTempFile "htcbdd-input.dat" $ \fname1 h1 -> do forM_ (Set.toList es) $ \e -> do - hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] + hPutStrLn h1 $ unwords [show (encTable IntMap.! v) | v <- IntSet.toList e] hClose h1 withSystemTempFile "htcbdd-out.dat" $ \fname2 h2 -> do hClose h2 diff --git a/src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs b/src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs --- a/src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs +++ b/src/ToySolver/Combinatorial/HittingSet/InterestingSets.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} @@ -8,7 +9,7 @@ -- Module : ToySolver.Combinatorial.HittingSet.InterestingSets -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable diff --git a/src/ToySolver/Combinatorial/HittingSet/MARCO.hs b/src/ToySolver/Combinatorial/HittingSet/MARCO.hs --- a/src/ToySolver/Combinatorial/HittingSet/MARCO.hs +++ b/src/ToySolver/Combinatorial/HittingSet/MARCO.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -9,7 +10,7 @@ -- Module : ToySolver.Combinatorial.HittingSet.MARCO -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable @@ -109,7 +110,7 @@ } minimalHittingSets :: Set IntSet -> Set IntSet -minimalHittingSets xss = +minimalHittingSets xss = case generateCNFAndDNF (IntSet.unions $ Set.toList xss) (evalDNF xss) Set.empty xss of (yss, _) -> yss diff --git a/src/ToySolver/Combinatorial/HittingSet/SHD.hs b/src/ToySolver/Combinatorial/HittingSet/SHD.hs --- a/src/ToySolver/Combinatorial/HittingSet/SHD.hs +++ b/src/ToySolver/Combinatorial/HittingSet/SHD.hs @@ -1,15 +1,16 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.HittingSet.SHD -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (DeriveDataTypeable) --- +-- Portability : non-portable +-- -- Wrapper for shd command. -- -- * Hypergraph Dualization Repository @@ -30,7 +31,6 @@ import qualified Data.IntSet as IntSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import Data.List import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable @@ -68,7 +68,7 @@ minimalHittingSets opt es = do withSystemTempFile "shd-input.dat" $ \fname1 h1 -> do forM_ (Set.toList es) $ \e -> do - hPutStrLn h1 $ intercalate " " [show (encTable IntMap.! v) | v <- IntSet.toList e] + hPutStrLn h1 $ unwords [show (encTable IntMap.! v) | v <- IntSet.toList e] hClose h1 withSystemTempFile "shd-out.dat" $ \fname2 h2 -> do hClose h2 diff --git a/src/ToySolver/Combinatorial/HittingSet/Simple.hs b/src/ToySolver/Combinatorial/HittingSet/Simple.hs --- a/src/ToySolver/Combinatorial/HittingSet/Simple.hs +++ b/src/ToySolver/Combinatorial/HittingSet/Simple.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Combinatorial.HittingSet.Simple -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/Combinatorial/HittingSet/Util.hs b/src/ToySolver/Combinatorial/HittingSet/Util.hs --- a/src/ToySolver/Combinatorial/HittingSet/Util.hs +++ b/src/ToySolver/Combinatorial/HittingSet/Util.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Combinatorial.HittingSet.Util -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/Combinatorial/Knapsack/BB.hs b/src/ToySolver/Combinatorial/Knapsack/BB.hs --- a/src/ToySolver/Combinatorial/Knapsack/BB.hs +++ b/src/ToySolver/Combinatorial/Knapsack/BB.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.Knapsack.BB -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : portable +-- Portability : non-portable -- -- Simple 0-1 knapsack problem solver that uses branch-and-bound with LP-relaxation based upper bound. -- diff --git a/src/ToySolver/Combinatorial/Knapsack/DPDense.hs b/src/ToySolver/Combinatorial/Knapsack/DPDense.hs --- a/src/ToySolver/Combinatorial/Knapsack/DPDense.hs +++ b/src/ToySolver/Combinatorial/Knapsack/DPDense.hs @@ -1,13 +1,14 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.Knapsack.DPDense -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- Simple 0-1 knapsack problem solver that uses DP. -- diff --git a/src/ToySolver/Combinatorial/Knapsack/DPSparse.hs b/src/ToySolver/Combinatorial/Knapsack/DPSparse.hs --- a/src/ToySolver/Combinatorial/Knapsack/DPSparse.hs +++ b/src/ToySolver/Combinatorial/Knapsack/DPSparse.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.Knapsack.DPSparse @@ -8,7 +10,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) +-- Portability : non-portable -- -- Simple 0-1 knapsack problem solver that uses DP. -- @@ -37,7 +39,7 @@ -> weight -> (value, weight, [Bool]) solve = solveGeneric - + solveGeneric :: forall value weight. (Real value, Real weight) => [(value, weight)] @@ -117,7 +119,7 @@ splitLE :: Int -> IntMap v -> IntMap v splitLE k m | k == maxBound = m - | otherwise = + | otherwise = case IntMap.splitLookup (k+1) m of (lo, _, _) -> lo diff --git a/src/ToySolver/Combinatorial/SubsetSum.hs b/src/ToySolver/Combinatorial/SubsetSum.hs --- a/src/ToySolver/Combinatorial/SubsetSum.hs +++ b/src/ToySolver/Combinatorial/SubsetSum.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Combinatorial.SubsetSum -- Copyright : (c) Masahiro Sakai 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns, FlexibleContexts) +-- Portability : non-portable -- -- References -- @@ -84,11 +87,11 @@ VM.write w2 i wi loop (i+1) offset offset <- loop 0 (0::Integer) - w2 <- VG.unsafeFreeze w2 + w2' <- VG.unsafeFreeze w2 let trans (obj, bs) = (obj + offset, bs2) where bs2 = VU.imap (\i bi -> if w ! i < 0 then not bi else bi) bs - return (w2, c - offset, trans) + return (w2', c - offset, trans) normalize2 :: (V.Vector Weight, Weight) @@ -143,7 +146,7 @@ maxSubsetSumInteger' w c wsum where wsum = VG.sum w - + maxSubsetSumInteger' :: V.Vector Weight -> Weight -> Weight -> (Weight, VU.Vector Bool) maxSubsetSumInteger' w !c wsum = assert (wbar <= c) $ assert (wbar + (w ! b) > c) $ runST $ do objRef <- newSTRef (wbar, [], []) @@ -327,7 +330,7 @@ case IntMap.splitLookup k m of (lo, Nothing, _) -> lo (lo, Just v, _) -> IntMap.insert k v lo - + -- | Minimize Σ_{i=1}^n wi xi subject to Σ_{i=1}^n wi x≥ l and xi ∈ {0,1}. -- -- Note: 0 (resp. 1) is identified with False (resp. True) in the assignment. @@ -346,7 +349,7 @@ Just (obj, bs) -> Just (wsum - obj, VG.map not bs) where wsum = VG.sum w - + {- minimize Σ wi xi = Σ wi (1 - ¬xi) = Σ wi - (Σ wi ¬xi) subject to Σ wi xi ≥ n @@ -364,7 +367,7 @@ -- -- Note that this is different from usual definition of the subset sum problem, -- as this definition allows all xi to be zero. --- +-- -- Note: 0 (resp. 1) is identified with False (resp. True) in the assignment. subsetSum :: VG.Vector v Weight diff --git a/src/ToySolver/Converter.hs b/src/ToySolver/Converter.hs --- a/src/ToySolver/Converter.hs +++ b/src/ToySolver/Converter.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Converter -- Copyright : (c) Masahiro Sakai 2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : portable @@ -24,6 +24,7 @@ , module ToySolver.Converter.SAT2KSAT , module ToySolver.Converter.SAT2MaxCut , module ToySolver.Converter.SAT2MaxSAT + , module ToySolver.Converter.SAT2MIS , module ToySolver.Converter.Tseitin ) where @@ -40,4 +41,5 @@ import ToySolver.Converter.SAT2KSAT import ToySolver.Converter.SAT2MaxCut import ToySolver.Converter.SAT2MaxSAT +import ToySolver.Converter.SAT2MIS import ToySolver.Converter.Tseitin diff --git a/src/ToySolver/Converter/Base.hs b/src/ToySolver/Converter/Base.hs --- a/src/ToySolver/Converter/Base.hs +++ b/src/ToySolver/Converter/Base.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -6,7 +7,7 @@ -- Module : ToySolver.Converter.Base -- Copyright : (c) Masahiro Sakai 2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : non-portable diff --git a/src/ToySolver/Converter/GCNF2MaxSAT.hs b/src/ToySolver/Converter/GCNF2MaxSAT.hs --- a/src/ToySolver/Converter/GCNF2MaxSAT.hs +++ b/src/ToySolver/Converter/GCNF2MaxSAT.hs @@ -1,11 +1,12 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.GCNF2MaxSAT -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : non-portable @@ -42,7 +43,9 @@ = ( CNF.WCNF { CNF.wcnfTopCost = top - , CNF.wcnfClauses = [(top, if g==0 then c else VG.cons (-(nv+g)) c) | (g,c) <- cs] ++ [(1, SAT.packClause [v]) | v <- [nv+1..nv+lastg]] + , CNF.wcnfClauses = + [(top, if g==0 then c else VG.cons (- SAT.packLit (nv+g)) c) | (g,c) <- cs] ++ + [(1, SAT.packClause [v]) | v <- [nv+1..nv+lastg]] , CNF.wcnfNumVars = nv + lastg , CNF.wcnfNumClauses = nc + lastg } diff --git a/src/ToySolver/Converter/MIP2PB.hs b/src/ToySolver/Converter/MIP2PB.hs --- a/src/ToySolver/Converter/MIP2PB.hs +++ b/src/ToySolver/Converter/MIP2PB.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -9,7 +10,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (MultiParamTypeClasses) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.MIP2PB @@ -31,8 +32,9 @@ import Data.VectorSpace import qualified Data.PseudoBoolean as PBFile +import qualified Numeric.Optimization.MIP as MIP + import ToySolver.Converter.Base -import qualified ToySolver.Data.MIP as MIP import ToySolver.Data.OrdRel import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.Encoder.Integer as Integer diff --git a/src/ToySolver/Converter/MIP2SMT.hs b/src/ToySolver/Converter/MIP2SMT.hs --- a/src/ToySolver/Converter/MIP2SMT.hs +++ b/src/ToySolver/Converter/MIP2SMT.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.MIP2SMT -- Copyright : (c) Masahiro Sakai 2012-2014,2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (OverloadedStrings) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.MIP2SMT @@ -23,7 +25,9 @@ import Data.Interned import Data.Ord import Data.List +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ratio import qualified Data.Set as Set import Data.Map (Map) @@ -35,7 +39,7 @@ import qualified Data.Text.Lazy.Builder.Int as B import Text.Printf -import qualified ToySolver.Data.MIP as MIP +import qualified Numeric.Optimization.MIP as MIP import ToySolver.Internal.Util (showRationalAsFiniteDecimal, isInteger) -- | Translation options. @@ -242,7 +246,7 @@ case optLanguage opt of -- In SMT-LIB2 format, inequalities can be chained. -- For example, "(<= 0 x 10)" is equivalent to "(and (<= 0 x) (<= x 10))". - -- + -- -- Supported solvers: cvc4-1.1, yices-2.2.1, z3-4.3.0 -- Unsupported solvers: z3-4.0 SMTLIB2 @@ -254,10 +258,10 @@ lb2 = case lb of MIP.NegInf -> [] MIP.PosInf -> error "should not happen" - MIP.Finite x + MIP.Finite x | isInt mip v -> [intNum opt (ceiling x)] | otherwise -> [realNum opt x] - ub2 = case ub of + ub2 = case ub of MIP.NegInf -> error "should not happen" MIP.PosInf -> [] MIP.Finite x @@ -374,7 +378,7 @@ ] encode :: Options -> T.Text -> T.Text -encode opt s = +encode opt s = case optLanguage opt of SMTLIB2 | T.all p s -> s @@ -398,16 +402,16 @@ -- ------------------------------------------------------------------------ -testFile :: FilePath -> IO () -testFile fname = do +_testFile :: FilePath -> IO () +_testFile fname = do mip <- MIP.readLPFile def fname TLIO.putStrLn $ B.toLazyText $ mip2smt def (fmap toRational mip) -test :: IO () -test = TLIO.putStrLn $ B.toLazyText $ mip2smt def testdata +_test :: IO () +_test = TLIO.putStrLn $ B.toLazyText $ mip2smt def _testdata -testdata :: MIP.Problem Rational -Right testdata = fmap (fmap toRational) $ MIP.parseLPString def "test" $ unlines +_testdata :: MIP.Problem Rational +Right _testdata = fmap (fmap toRational) $ MIP.parseLPString def "test" $ unlines [ "Maximize" , " obj: x1 + 2 x2 + 3 x3 + x4" , "Subject To" diff --git a/src/ToySolver/Converter/NAESAT.hs b/src/ToySolver/Converter/NAESAT.hs --- a/src/ToySolver/Converter/NAESAT.hs +++ b/src/ToySolver/Converter/NAESAT.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -54,11 +55,11 @@ evalNAESAT :: SAT.IModel m => m -> NAESAT -> Bool evalNAESAT m (_,cs) = all (evalNAEClause m) cs -type NAEClause = VU.Vector SAT.Lit +type NAEClause = VU.Vector SAT.PackedLit evalNAEClause :: SAT.IModel m => m -> NAEClause -> Bool evalNAEClause m c = - VG.any (SAT.evalLit m) c && VG.any (not . SAT.evalLit m) c + VG.any (SAT.evalLit m . SAT.unpackLit) c && VG.any (not . SAT.evalLit m . SAT.unpackLit) c -- ------------------------------------------------------------------------ @@ -74,7 +75,7 @@ z = CNF.cnfNumVars cnf + 1 ret = ( CNF.cnfNumVars cnf + 1 - , [VG.snoc clause z | clause <- CNF.cnfClauses cnf] + , [VG.snoc clause (SAT.packLit z) | clause <- CNF.cnfClauses cnf] ) instance Transformer SAT2NAESATInfo where @@ -85,7 +86,7 @@ transformForward (SAT2NAESATInfo z) m = array (1,z) $ (z,False) : assocs m instance BackwardTransformer SAT2NAESATInfo where - transformBackward (SAT2NAESATInfo z) m = + transformBackward (SAT2NAESATInfo z) m = SAT.restrictModel (z - 1) $ if SAT.evalVar m z then amap not m else m @@ -124,7 +125,7 @@ (i, tbl) <- get let w = i+1 seq w $ put (w, (w,cs1,cs2) : tbl) - go (VG.cons (-w) cs2) (VG.snoc cs1 w : r) + go (VG.cons (SAT.packLit (- w)) cs2) (VG.snoc cs1 (SAT.packLit w) : r) go c [] instance Transformer NAESAT2NAEKSATInfo where @@ -139,8 +140,8 @@ go im ((w,cs1,cs2) : tbl) = go (IntMap.insert w val im) tbl where ev x - | x > 0 = im IntMap.! x - | otherwise = not $ im IntMap.! (- x) + | x > 0 = im IntMap.! (SAT.unpackLit x) + | otherwise = not $ im IntMap.! (- SAT.unpackLit x) needTrue = VG.all ev cs2 || VG.all (not . ev) cs1 needFalse = VG.all ev cs1 || VG.all (not . ev) cs2 val @@ -195,7 +196,7 @@ nc' = length cs' (cs', t) = foldl f ([],0) cs where - f :: ([CNF.WeightedClause], Integer) -> VU.Vector SAT.Lit -> ([CNF.WeightedClause], Integer) + f :: ([CNF.WeightedClause], Integer) -> NAEClause -> ([CNF.WeightedClause], Integer) f (cs, !t) c = case SAT.unpackClause c of [] -> error "nae3sat2max2sat: should not happen" diff --git a/src/ToySolver/Converter/ObjType.hs b/src/ToySolver/Converter/ObjType.hs --- a/src/ToySolver/Converter/ObjType.hs +++ b/src/ToySolver/Converter/ObjType.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Converter.ObjType -- Copyright : (c) Masahiro Sakai 2011-2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : portable diff --git a/src/ToySolver/Converter/PB.hs b/src/ToySolver/Converter/PB.hs --- a/src/ToySolver/Converter/PB.hs +++ b/src/ToySolver/Converter/PB.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} @@ -218,7 +219,7 @@ degGe3Terms :: Set IntSet degGe3Terms = collectDegGe3Terms formula - + m :: Map IntSet (IntSet,IntSet) m = Product.decomposeToBinaryProducts degGe3Terms @@ -246,7 +247,7 @@ where f t | IntSet.size t == 1 = head (IntSet.toList t) - | otherwise = + | otherwise = case Map.lookup t toV of Nothing -> error "quadratizePB.prodDefs: should not happen" Just v -> v @@ -485,7 +486,7 @@ wbo2pb wbo = runST $ do let nv = PBFile.wboNumVars wbo db <- newPBStore - (obj, defs) <- addWBO db wbo + (obj, defs) <- addWBO db wbo formula <- getPBFormula db return ( formula{ PBFile.pbObjectiveFunction = Just obj } @@ -511,29 +512,47 @@ SAT.newVars_ db $ PBFile.wboNumVars wbo objRef <- newMutVar [] + objOffsetRef <- newMutVar 0 defsRef <- newMutVar [] + trueLitRef <- newMutVar SAT.litUndef + forM_ (PBFile.wboConstraints wbo) $ \(cost, constr@(lhs,op,rhs)) -> do case cost of Nothing -> do case op of PBFile.Ge -> SAT.addPBNLAtLeast db lhs rhs PBFile.Eq -> SAT.addPBNLExactly db lhs rhs + trueLit <- readMutVar trueLitRef + when (trueLit == SAT.litUndef) $ do + case detectTrueLit constr of + Nothing -> return () + Just l -> writeMutVar trueLitRef l Just w -> do case op of PBFile.Ge -> do case lhs of - [(1,ls)] | rhs == 1 -> do + [(c,ls)] | c > 0 && (rhs + c - 1) `div` c == 1 -> do + -- c ∧L ≥ rhs ⇔ ∧L ≥ ⌈rhs / c⌉ -- ∧L ≥ 1 ⇔ ∧L -- obj += w * (1 - ∧L) - modifyMutVar objRef (\obj -> (w,[]) : (-w,ls) : obj) - [(-1,ls)] | rhs == 0 -> do - -- -1*∧L ≥ 0 ⇔ (1 - ∧L) ≥ 1 ⇔ ￢∧L + unless (null ls) $ do + modifyMutVar objRef (\obj -> (-w,ls) : obj) + modifyMutVar objOffsetRef (+ w) + [(c,ls)] | c < 0 && (rhs + abs c - 1) `div` abs c + 1 == 1 -> do + -- c*∧L ≥ rhs ⇔ -1*∧L ≥ ⌈rhs / abs c⌉ ⇔ (1 - ∧L) ≥ ⌈rhs / abs c⌉ + 1 ⇔ ¬∧L ≥ ⌈rhs / abs c⌉ + 1 + -- ￢∧L ≥ 1 ⇔ ￢∧L -- obj += w * ∧L - modifyMutVar objRef ((w,ls) :) - _ | and [c==1 && length ls == 1 | (c,ls) <- lhs] && rhs == 1 -> do + if null ls then do + modifyMutVar objOffsetRef (+ w) + else do + modifyMutVar objRef ((w,ls) :) + _ | rhs > 0 && and [c >= rhs && length ls == 1 | (c,ls) <- lhs] -> do -- ∑L ≥ 1 ⇔ ∨L ⇔ ￢∧￢L -- obj += w * ∧￢L - modifyMutVar objRef ((w, [-l | (_,[l]) <- lhs]) :) + if null lhs then do + modifyMutVar objOffsetRef (+ w) + else do + modifyMutVar objRef ((w, [-l | (_,[l]) <- lhs]) :) _ -> do sel <- SAT.newVar db SAT.addPBNLAtLeastSoft db sel lhs rhs @@ -544,6 +563,20 @@ SAT.addPBNLExactlySoft db sel lhs rhs modifyMutVar objRef ((w,[-sel]) :) modifyMutVar defsRef ((sel,constr) :) + + offset <- readMutVar objOffsetRef + when (offset /= 0) $ do + l <- readMutVar trueLitRef + trueLit <- + if l /= SAT.litUndef then + return l + else do + v <- SAT.newVar db + SAT.addClause db [v] + modifyMutVar defsRef ((v, ([], PBFile.Ge, 0)) :) + return v + modifyMutVar objRef ((offset,[trueLit]) :) + obj <- liftM reverse $ readMutVar objRef defs <- liftM reverse $ readMutVar defsRef @@ -553,6 +586,22 @@ return (obj, defs) + +detectTrueLit :: PBFile.Constraint -> Maybe SAT.Lit +detectTrueLit (lhs, op, rhs) = + case op of + PBFile.Ge -> f lhs rhs + PBFile.Eq -> f lhs rhs `mplus` f [(- c, ls) | (c,ls) <- lhs] (- rhs) + where + f [(c, [l])] rhs + | c > 0 && (rhs + c - 1) `div` c == 1 = + -- c l ≥ rhs ↔ l ≥ ⌈rhs / c⌉ + return l + | c < 0 && rhs `div` c == 0 = + -- c l ≥ rhs ↔ l ≤ ⌊rhs / c⌋ + return (- l) + f _ _ = Nothing + -- ----------------------------------------------------------------------------- type SAT2PBInfo = IdentityTransformer SAT.Model @@ -578,7 +627,7 @@ -- * if M ⊨ φ then f(M) ⊨ ψ -- -- * if M ⊨ ψ then g(M) ⊨ φ --- +-- pb2sat :: PBFile.Formula -> (CNF.CNF, PB2SATInfo) pb2sat formula = runST $ do db <- newCNFStore diff --git a/src/ToySolver/Converter/PB/Internal/LargestIntersectionFinder.hs b/src/ToySolver/Converter/PB/Internal/LargestIntersectionFinder.hs --- a/src/ToySolver/Converter/PB/Internal/LargestIntersectionFinder.hs +++ b/src/ToySolver/Converter/PB/Internal/LargestIntersectionFinder.hs @@ -1,4 +1,17 @@ -{-# OPTIONS -Wall #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Converter.PB.Internal.LargestIntersectionFinder +-- Copyright : (c) Masahiro Sakai 2018 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.Converter.PB.Internal.LargestIntersectionFinder ( Table , empty @@ -17,7 +30,9 @@ import Data.List hiding (insert) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Ord import Data.Set (Set) import qualified Data.Set as Set diff --git a/src/ToySolver/Converter/PB/Internal/Product.hs b/src/ToySolver/Converter/PB/Internal/Product.hs --- a/src/ToySolver/Converter/PB/Internal/Product.hs +++ b/src/ToySolver/Converter/PB/Internal/Product.hs @@ -1,4 +1,15 @@ {-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Converter.PB.Internal.Product +-- Copyright : (c) Masahiro Sakai 2018 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.Converter.PB.Internal.Product ( decomposeToBinaryProducts ) where @@ -42,7 +53,7 @@ else if IntSet.null s2 then -- i.e. s⊆s0 case Map.lookup s0 r of Nothing -> error "should not happen" - Just Nothing -> + Just Nothing -> let s3 = s0 IntSet.\\ s in ( LargestIntersectionFinder.insert s3 $ LargestIntersectionFinder.insert s t , -- union is left-biased diff --git a/src/ToySolver/Converter/PB2IP.hs b/src/ToySolver/Converter/PB2IP.hs --- a/src/ToySolver/Converter/PB2IP.hs +++ b/src/ToySolver/Converter/PB2IP.hs @@ -1,11 +1,12 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.PB2IP -- Copyright : (c) Masahiro Sakai 2011-2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : non-portable @@ -20,7 +21,7 @@ , sat2ip , SAT2IPInfo , maxsat2ip - , MaxSAT2IPInfo + , MaxSAT2IPInfo ) where import Data.Array.IArray @@ -30,10 +31,11 @@ import qualified Data.Map as Map import qualified Data.PseudoBoolean as PBFile +import qualified Numeric.Optimization.MIP as MIP +import Numeric.Optimization.MIP ((.==.), (.<=.), (.>=.)) + import ToySolver.Converter.Base import ToySolver.Converter.PB -import qualified ToySolver.Data.MIP as MIP -import ToySolver.Data.MIP ((.==.), (.<=.), (.>=.)) import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT @@ -126,7 +128,7 @@ } topConstr :: [MIP.Constraint Integer] - topConstr = + topConstr = case PBFile.wboTopCost formula of Nothing -> [] Just t -> @@ -166,7 +168,7 @@ where e2 = MIP.Expr [t | t@(MIP.Term _ (_:_)) <- MIP.terms e] c = sum [c | MIP.Term c [] <- MIP.terms e] - + relaxGE :: MIP.Var -> (MIP.Expr Integer, Integer) -> (MIP.Expr Integer, Integer) relaxGE v (lhs, rhs) = (MIP.constExpr (rhs - lhs_lb) * MIP.varExpr v + lhs, rhs) where diff --git a/src/ToySolver/Converter/PB2LSP.hs b/src/ToySolver/Converter/PB2LSP.hs --- a/src/ToySolver/Converter/PB2LSP.hs +++ b/src/ToySolver/Converter/PB2LSP.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.PB2LSP -- Copyright : (c) Masahiro Sakai 2013-2014,2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (OverloadedStrings) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.PB2LSP @@ -18,7 +20,9 @@ import Data.ByteString.Builder import Data.List +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import qualified Data.PseudoBoolean as PBFile pb2lsp :: PBFile.Formula -> Builder diff --git a/src/ToySolver/Converter/PB2SMP.hs b/src/ToySolver/Converter/PB2SMP.hs --- a/src/ToySolver/Converter/PB2SMP.hs +++ b/src/ToySolver/Converter/PB2SMP.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Converter.PB2SMP -- Copyright : (c) Masahiro Sakai 2013,2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (OverloadedStrings) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Converter.PB2SMP @@ -17,7 +19,9 @@ import Data.ByteString.Builder import Data.List +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import qualified Data.PseudoBoolean as PBFile pb2smp :: Bool -> PBFile.Formula -> Builder @@ -38,7 +42,7 @@ if isUnix then byteString "#include \"simple.h\"\nvoid ufun()\n{\n\n" else mempty - + footer = if isUnix then "\n}\n" diff --git a/src/ToySolver/Converter/PBSetObj.hs b/src/ToySolver/Converter/PBSetObj.hs --- a/src/ToySolver/Converter/PBSetObj.hs +++ b/src/ToySolver/Converter/PBSetObj.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Converter.PBSetObj -- Copyright : (c) Masahiro Sakai 2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental -- Portability : portable diff --git a/src/ToySolver/Converter/QBF2IPC.hs b/src/ToySolver/Converter/QBF2IPC.hs --- a/src/ToySolver/Converter/QBF2IPC.hs +++ b/src/ToySolver/Converter/QBF2IPC.hs @@ -7,7 +7,7 @@ -- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable +-- Portability : portable -- -- References: -- diff --git a/src/ToySolver/Converter/QUBO.hs b/src/ToySolver/Converter/QUBO.hs --- a/src/ToySolver/Converter/QUBO.hs +++ b/src/ToySolver/Converter/QUBO.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -6,11 +7,11 @@ -- Module : ToySolver.Converter.QUBO -- Copyright : (c) Masahiro Sakai 2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable --- +-- ----------------------------------------------------------------------------- module ToySolver.Converter.QUBO ( qubo2pb diff --git a/src/ToySolver/Converter/SAT2KSAT.hs b/src/ToySolver/Converter/SAT2KSAT.hs --- a/src/ToySolver/Converter/SAT2KSAT.hs +++ b/src/ToySolver/Converter/SAT2KSAT.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} @@ -51,7 +52,7 @@ SAT.addClause db (toList (lits1 |> (-v))) modifySTRef' defsRef (|> (v, toList lits1)) loop (v <| lits2) - loop $ Seq.fromList $ SAT.unpackClause clause + loop $ Seq.fromList $ SAT.unpackClause clause cnf2 <- getCNFFormula db defs <- readSTRef defsRef return (cnf2, SAT2KSATInfo nv1 (CNF.cnfNumVars cnf2) defs) diff --git a/src/ToySolver/Converter/SAT2MIS.hs b/src/ToySolver/Converter/SAT2MIS.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Converter/SAT2MIS.hs @@ -0,0 +1,187 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE TypeFamilies #-} +module ToySolver.Converter.SAT2MIS + ( + -- * SAT to independent set problem conversion + satToIS + , SAT2ISInfo + + -- * 3-SAT to independent set problem conversion + , sat3ToIS + , SAT3ToISInfo + + -- * Maximum independent problem to MaxSAT/PB problem conversion + , is2pb + , mis2MaxSAT + , IS2SATInfo + ) where + +import Control.Monad +import Control.Monad.ST +import Data.Array.IArray +import Data.Array.ST +import Data.Array.Unboxed +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) +import Data.Maybe +import Data.STRef + +import qualified Data.PseudoBoolean as PBFile + +import ToySolver.Converter.Base +import ToySolver.Converter.SAT2KSAT +import qualified ToySolver.FileFormat.CNF as CNF +import ToySolver.Graph.Base +import ToySolver.SAT.Store.CNF +import ToySolver.SAT.Store.PB +import qualified ToySolver.SAT.Types as SAT + +-- ------------------------------------------------------------------------ + +satToIS :: CNF.CNF -> ((Graph, Int), SAT2ISInfo) +satToIS x = (x2, (ComposedTransformer info1 info2)) + where + (x1, info1) = sat2ksat 3 x + (x2, info2) = sat3ToIS x1 + +type SAT2ISInfo = ComposedTransformer SAT2KSATInfo SAT3ToISInfo + +-- ------------------------------------------------------------------------ + +sat3ToIS :: CNF.CNF -> ((Graph, Int), SAT3ToISInfo) +sat3ToIS cnf = runST $ do + nRef <- newSTRef 0 + litToNodesRef <- newSTRef IntMap.empty + nodeToLitRef <- newSTRef [] + let newNode lit = do + n <- readSTRef nRef + writeSTRef nRef $! n + 1 + modifySTRef' litToNodesRef (IntMap.alter (Just . (n :) . fromMaybe []) lit) + modifySTRef nodeToLitRef (lit :) + return n + + clusters <- forM (CNF.cnfClauses cnf) $ \clause -> do + mapM newNode (SAT.unpackClause clause) + + litToNodes <- readSTRef litToNodesRef + let es = concat $ + [ [(node1, node2, ()) | (node1, node2) <- pairs nodes] | nodes <- clusters ] ++ + [ [(node1, node2, ()) | node1 <- nodes1, node2 <- nodes2] + | (lit, nodes1) <- IntMap.toList litToNodes + , let nodes2 = IntMap.findWithDefault [] (- lit) litToNodes + ] + + n <- readSTRef nRef + let g = graphFromUnorderedEdges n es + + xs <- readSTRef nodeToLitRef + let nodeToLit = runSTUArray $ do + a <- newArray_ (0,n-1) + forM_ (zip [n-1,n-2..] xs) $ \(i, lit) -> do + writeArray a i lit + return a + + return ((g, CNF.cnfNumClauses cnf), SAT3ToISInfo (CNF.cnfNumVars cnf) clusters nodeToLit) + + +data SAT3ToISInfo = SAT3ToISInfo Int [[Int]] (UArray Int SAT.Lit) + deriving (Eq, Show) +-- Note that array <0.5.4.0 did not provided Read instance of UArray + +instance Transformer SAT3ToISInfo where + type Source SAT3ToISInfo = SAT.Model + type Target SAT3ToISInfo = IntSet + +instance ForwardTransformer SAT3ToISInfo where + transformForward (SAT3ToISInfo _nv clusters nodeToLit) m = IntSet.fromList $ do + nodes <- clusters + let xs = [node | node <- nodes, SAT.evalLit m (nodeToLit ! node)] + if null xs then + error "not a model" + else + return (head xs) + +instance BackwardTransformer SAT3ToISInfo where + transformBackward (SAT3ToISInfo nv _clusters nodeToLit) indep_set = runSTUArray $ do + a <- newArray (1, nv) False + forM_ (IntSet.toList lits) $ \lit -> do + writeArray a (SAT.litVar lit) (SAT.litPolarity lit) + return a + where + lits = IntSet.map (nodeToLit !) indep_set + +-- ------------------------------------------------------------------------ + +is2pb :: (Graph, Int) -> (PBFile.Formula, IS2SATInfo) +is2pb (g, k) = runST $ do + let (lb, ub) = bounds g + db <- newPBStore + vs <- SAT.newVars db (rangeSize (bounds g)) + forM_ (graphToUnorderedEdges g) $ \(node1, node2, _) -> do + SAT.addClause db [- (node1 - lb + 1), - (node2 - lb + 1)] + SAT.addPBAtLeast db [(1,v) | v <- vs] (fromIntegral k) + formula <- getPBFormula db + return + ( formula + , IS2SATInfo (lb, ub) + ) + +mis2MaxSAT :: Graph -> (CNF.WCNF, IS2SATInfo) +mis2MaxSAT g = runST $ do + let (lb,ub) = bounds g + n = ub - lb + 1 + db <- newCNFStore + vs <- SAT.newVars db n + forM_ (graphToUnorderedEdges g) $ \(node1, node2, _) -> do + SAT.addClause db [- (node1 - lb + 1), - (node2 - lb + 1)] + cnf <- getCNFFormula db + let top = fromIntegral n + 1 + return + ( CNF.WCNF + { CNF.wcnfNumVars = CNF.cnfNumVars cnf + , CNF.wcnfNumClauses = CNF.cnfNumClauses cnf + n + , CNF.wcnfTopCost = top + , CNF.wcnfClauses = + [(top, clause) | clause <- CNF.cnfClauses cnf] ++ + [(1, SAT.packClause [v]) | v <- vs] + } + , IS2SATInfo (lb,ub) + ) + +newtype IS2SATInfo = IS2SATInfo (Int, Int) + deriving (Eq, Show, Read) + +instance Transformer IS2SATInfo where + type Source IS2SATInfo = IntSet + type Target IS2SATInfo = SAT.Model + +instance ForwardTransformer IS2SATInfo where + transformForward (IS2SATInfo (lb, ub)) indep_set = runSTUArray $ do + let n = ub - lb + 1 + a <- newArray (1, n) False + forM_ (IntSet.toList indep_set) $ \node -> do + writeArray a (node - lb + 1) True + return a + +instance BackwardTransformer IS2SATInfo where + transformBackward (IS2SATInfo (lb, ub)) m = + IntSet.fromList [node | node <- range (lb, ub), SAT.evalVar m (node - lb + 1)] + +instance ObjValueTransformer IS2SATInfo where + type SourceObjValue IS2SATInfo = Int + type TargetObjValue IS2SATInfo = Integer + +instance ObjValueForwardTransformer IS2SATInfo where + transformObjValueForward (IS2SATInfo (lb, ub)) k = fromIntegral $ (ub - lb + 1) - k + +instance ObjValueBackwardTransformer IS2SATInfo where + transformObjValueBackward (IS2SATInfo (lb, ub)) k = (ub - lb + 1) - fromIntegral k + +-- ------------------------------------------------------------------------ + +pairs :: [a] -> [(a,a)] +pairs [] = [] +pairs (x:xs) = [(x,x2) | x2 <- xs] ++ pairs xs + +-- ------------------------------------------------------------------------ diff --git a/src/ToySolver/Converter/SAT2MaxCut.hs b/src/ToySolver/Converter/SAT2MaxCut.hs --- a/src/ToySolver/Converter/SAT2MaxCut.hs +++ b/src/ToySolver/Converter/SAT2MaxCut.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -37,7 +38,8 @@ import qualified Data.Vector.Unboxed as VU import qualified ToySolver.FileFormat.CNF as CNF -import qualified ToySolver.MaxCut as MaxCut +import ToySolver.Graph.Base +import qualified ToySolver.Graph.MaxCut as MaxCut import qualified ToySolver.SAT.Types as SAT import ToySolver.Converter.Base import ToySolver.Converter.NAESAT (NAESAT) @@ -72,17 +74,17 @@ nae3sat2maxcut :: NAESAT -> ((MaxCut.Problem Integer, Integer), NAE3SAT2MaxCutInfo) nae3sat2maxcut (n,cs) | any (\c -> VG.length c < 2) cs' = - ( (MaxCut.fromEdges (n*2) [], 1) + ( (graphFromUnorderedEdges (n*2) [], 1) , NAE3SAT2MaxCutInfo ) | otherwise = - ( ( MaxCut.fromEdges (n*2) (variableEdges ++ clauseEdges) + ( ( graphFromUnorderedEdgesWith (+) (n*2) (variableEdges ++ clauseEdges) , bigM * fromIntegral n + clauseEdgesObjMax ) , NAE3SAT2MaxCutInfo ) where - cs' = map (VG.fromList . IntSet.toList . IntSet.fromList . VG.toList) cs + cs' = map (VG.fromList . IntSet.toList . IntSet.fromList . SAT.unpackClause) cs bigM = clauseEdgesObjMax + 1 diff --git a/src/ToySolver/Converter/SAT2MaxSAT.hs b/src/ToySolver/Converter/SAT2MaxSAT.hs --- a/src/ToySolver/Converter/SAT2MaxSAT.hs +++ b/src/ToySolver/Converter/SAT2MaxSAT.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- @@ -57,14 +58,15 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet -import Data.List +import Data.List hiding (insert) import Data.Monoid import Data.Set (Set) import qualified Data.Set as Set import qualified ToySolver.FileFormat.CNF as CNF import ToySolver.Converter.Base import ToySolver.Converter.SAT2KSAT -import qualified ToySolver.MaxCut as MaxCut +import ToySolver.Graph.Base +import qualified ToySolver.Graph.MaxCut as MaxCut import qualified ToySolver.SAT.Types as SAT -- ------------------------------------------------------------------------ @@ -191,7 +193,7 @@ , SimpleMaxSAT2ToSimpleMaxCutInfo ) simpleMaxSAT2ToSimpleMaxCut (n, cs, threshold) = - ( ( MaxCut.fromEdges numNodes [(a,b,1) | (a,b) <- (basicFramework ++ additionalEdges)] + ( ( graphFromUnorderedEdgesWith (+) numNodes [(a,b,1) | (a,b) <- (basicFramework ++ additionalEdges)] , w ) , SimpleMaxSAT2ToSimpleMaxCutInfo n p diff --git a/src/ToySolver/Converter/Tseitin.hs b/src/ToySolver/Converter/Tseitin.hs --- a/src/ToySolver/Converter/Tseitin.hs +++ b/src/ToySolver/Converter/Tseitin.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | diff --git a/src/ToySolver/Data/AlgebraicNumber/Complex.hs b/src/ToySolver/Data/AlgebraicNumber/Complex.hs --- a/src/ToySolver/Data/AlgebraicNumber/Complex.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Complex.hs @@ -3,13 +3,13 @@ -- Module : ToySolver.Data.AlgebraicNumber.Complex -- Copyright : (c) Masahiro Sakai 2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Algebraic Numbers --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.AlgebraicNumber.Complex ( @@ -112,7 +112,7 @@ -- | Roots of the polynomial roots :: UPolynomial Rational -> [AComplex] roots f = do - let cs1 = [ (u, [Sign.Zero]), (v, [Sign.Zero]) ] + let cs1 = [ (u, [Sign.Zero]), (v, [Sign.Zero]) ] (cs2, cells2) <- CAD.project' [(P.toUPolynomialOf p 0, ss) | (p,ss) <- cs1] (cs3, cells3) <- CAD.project' [(P.toUPolynomialOf p 1, ss) | (p,ss) <- cs2] guard $ and [Sign.signOf v `elem` ss | (p,ss) <- cs3, let v = P.eval (\_ -> undefined) p] @@ -129,7 +129,7 @@ -- f(x + yi) = u(x,y) + v(x,y)i f1 :: P.Polynomial Rational Int f1 = P.subst f (\X -> P.var 0 + P.var 1 * P.var 2) - f2 = P.toUPolynomialOf (P.reduce P.grevlex f1 [P.var 2 * P.var 2 + 1]) 2 + f2 = P.toUPolynomialOf (P.reduce P.grevlex f1 [P.var 2 * P.var 2 + 1]) 2 u = P.coeff P.mone f2 v = P.coeff (P.var X) f2 diff --git a/src/ToySolver/Data/AlgebraicNumber/Graeffe.hs b/src/ToySolver/Data/AlgebraicNumber/Graeffe.hs --- a/src/ToySolver/Data/AlgebraicNumber/Graeffe.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Graeffe.hs @@ -3,19 +3,19 @@ -- Module : ToySolver.Data.AlgebraicNumber.Graeffe -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable --- +-- -- Graeffe's Method -- -- Reference: --- +-- -- * --- +-- -- * --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.AlgebraicNumber.Graeffe diff --git a/src/ToySolver/Data/AlgebraicNumber/Real.hs b/src/ToySolver/Data/AlgebraicNumber/Real.hs --- a/src/ToySolver/Data/AlgebraicNumber/Real.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Real.hs @@ -1,13 +1,14 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.AlgebraicNumber.Real -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (Rank2Types) +-- Portability : non-portable -- -- Algebraic reals -- @@ -15,7 +16,7 @@ -- -- * Why the concept of a field extension is a natural one -- --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.AlgebraicNumber.Real ( @@ -91,7 +92,7 @@ return $ realRoot' p i realRoot :: UPolynomial Rational -> Interval Rational -> AReal -realRoot p i = +realRoot p i = case [q | (q,_) <- P.factor p, P.deg q > 0, Sturm.numRoots q i == 1] of p2:_ -> realRoot' p2 i [] -> error "ToySolver.Data.AlgebraicNumber.Real.realRoot: invalid interval" @@ -274,7 +275,7 @@ -- | Same as 'round'. round' :: Integral b => AReal -> b -round' x = +round' x = case signum (abs r - 0.5) of -1 -> n 0 -> if even n then n else m @@ -378,7 +379,7 @@ isolatingInterval (RealRoot _ i) = i -- | Degree of the algebraic number. --- +-- -- If the algebraic number's 'minimalPolynomial' has degree @n@, -- then the algebraic number is said to be degree @n@. instance P.Degree AReal where @@ -440,7 +441,7 @@ Misc --------------------------------------------------------------------} --- | Golden ratio +-- | Golden ratio goldenRatio :: AReal goldenRatio = (1 + root5) / 2 where diff --git a/src/ToySolver/Data/AlgebraicNumber/Root.hs b/src/ToySolver/Data/AlgebraicNumber/Root.hs --- a/src/ToySolver/Data/AlgebraicNumber/Root.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Root.hs @@ -1,20 +1,22 @@ -{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.AlgebraicNumber.Root -- Copyright : (c) Masahiro Sakai 2012-2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (Rank2Types, ScopedTypeVariables) +-- Portability : non-portable -- -- Manipulating polynomials for corresponding operations for algebraic numbers. --- +-- -- Reference: -- -- * --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.AlgebraicNumber.Root where @@ -94,7 +96,7 @@ -- findPoly P [P1..Pn] computes a non-zero polynomial Q such that Q[P] = 0 modulo {P1,…,Pn}. findPoly :: forall k. (Fractional k, Ord k) => Polynomial k Var -> [Polynomial k Var] -> UPolynomial k findPoly c ps = normalizePoly $ sum [P.constant coeff * (P.var X) ^ n | (n,coeff) <- zip [0..] coeffs] - where + where vn :: Var vn = if Set.null vs then 0 else Set.findMax vs + 1 where diff --git a/src/ToySolver/Data/AlgebraicNumber/Sturm.hs b/src/ToySolver/Data/AlgebraicNumber/Sturm.hs --- a/src/ToySolver/Data/AlgebraicNumber/Sturm.hs +++ b/src/ToySolver/Data/AlgebraicNumber/Sturm.hs @@ -3,19 +3,19 @@ -- Module : ToySolver.Data.AlgebraicNumber.Sturm -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable --- +-- -- Reference: --- +-- -- * \"/Sturm's theorem/.\" Wikipedia, The Free Encyclopedia. Wikimedia Foundation, Inc. -- 2012-06-23. --- +-- -- * Weisstein, Eric W. \"/Sturm Function/.\" From MathWorld--A Wolfram Web Resource. -- --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.AlgebraicNumber.Sturm @@ -127,7 +127,7 @@ if lb `P.isRootOf` p then Interval.singleton lb : g (lb,ub) else g (lb,ub) - + g (lb,ub) = case n lb - n ub of 0 -> [] @@ -148,8 +148,8 @@ Finite lb = Interval.lowerBound ival Finite ub = Interval.upperBound ival mid = (lb + ub) / 2 - ivalL = Interval.interval (Interval.lowerBound' ival) (Finite mid, True) - ivalR = Interval.interval (Finite mid, False) (Interval.upperBound' ival) + ivalL = Interval.interval (Interval.lowerBound' ival) (Finite mid, Interval.Closed) + ivalR = Interval.interval (Finite mid, Interval.Open) (Interval.upperBound' ival) narrow :: UPolynomial Rational -> Interval Rational -> Rational -> Interval Rational narrow p ival size = narrow' (sturmChain p) ival size diff --git a/src/ToySolver/Data/BoolExpr.hs b/src/ToySolver/Data/BoolExpr.hs --- a/src/ToySolver/Data/BoolExpr.hs +++ b/src/ToySolver/Data/BoolExpr.hs @@ -1,17 +1,21 @@ -{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.BoolExpr -- Copyright : (c) Masahiro Sakai 2014-2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses, DeriveDataTypeable, FlexibleContexts, FlexibleInstances) +-- Portability : non-portable -- -- Boolean expression over a given type of atoms --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.BoolExpr ( @@ -136,7 +140,7 @@ ys = concat [f x | Simplify x <- xs] f (Or zs) = zs f z = [z] - andB xs + andB xs | any isFalse ys = Simplify false | otherwise = Simplify $ And ys where diff --git a/src/ToySolver/Data/Boolean.hs b/src/ToySolver/Data/Boolean.hs --- a/src/ToySolver/Data/Boolean.hs +++ b/src/ToySolver/Data/Boolean.hs @@ -1,17 +1,18 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Boolean -- Copyright : (c) Masahiro Sakai 2012-2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses) +-- Portability : non-portable -- -- Type classes for lattices and boolean algebras. --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.Boolean ( diff --git a/src/ToySolver/Data/DNF.hs b/src/ToySolver/Data/DNF.hs --- a/src/ToySolver/Data/DNF.hs +++ b/src/ToySolver/Data/DNF.hs @@ -1,16 +1,17 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.DNF -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : portable +-- Portability : non-portable -- -- Disjunctive Normal Form --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.DNF ( DNF (..) diff --git a/src/ToySolver/Data/Delta.hs b/src/ToySolver/Data/Delta.hs --- a/src/ToySolver/Data/Delta.hs +++ b/src/ToySolver/Data/Delta.hs @@ -1,18 +1,19 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Delta -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeFamilies) +-- Portability : non-portable -- -- Augmenting number types with infinitesimal parameter δ. -- -- Reference: --- +-- -- * Bruno Dutertre and Leonardo de Moura, -- \"/A Fast Linear-Arithmetic Solver for DPLL(T)/\", -- Computer Aided Verification In Computer Aided Verification, Vol. 4144 @@ -95,7 +96,7 @@ Delta r1 k1 / Delta r2 k2 = error "Fractional{ToySolver.Data.Delta.Delta}.(/): divisor must be a proper real" fromRational x = Delta (fromRational x) 0 - + instance (Real r, Eq r) => Real (Delta r) where toRational (Delta r 0) = toRational r toRational (Delta r k) = diff --git a/src/ToySolver/Data/FOL/Arith.hs b/src/ToySolver/Data/FOL/Arith.hs --- a/src/ToySolver/Data/FOL/Arith.hs +++ b/src/ToySolver/Data/FOL/Arith.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.FOL.Arith -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- Arithmetic language (not limited to linear ones). --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.FOL.Arith ( diff --git a/src/ToySolver/Data/FOL/Formula.hs b/src/ToySolver/Data/FOL/Formula.hs --- a/src/ToySolver/Data/FOL/Formula.hs +++ b/src/ToySolver/Data/FOL/Formula.hs @@ -1,16 +1,17 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.FOL.Formula -- Copyright : (c) Masahiro Sakai 2011-2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : portable +-- Portability : non-portable -- -- Formula of first order logic. --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.FOL.Formula ( diff --git a/src/ToySolver/Data/IntVar.hs b/src/ToySolver/Data/IntVar.hs --- a/src/ToySolver/Data/IntVar.hs +++ b/src/ToySolver/Data/IntVar.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.IntVar -- Copyright : (c) Masahiro Sakai 2011-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses) --- +-- Portability : non-portable +-- ----------------------------------------------------------------------------- module ToySolver.Data.IntVar ( Var diff --git a/src/ToySolver/Data/LA.hs b/src/ToySolver/Data/LA.hs --- a/src/ToySolver/Data/LA.hs +++ b/src/ToySolver/Data/LA.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE TypeFamilies, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.LA -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeFamilies, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- Some definition for Theory of Linear Arithmetics. --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.LA ( @@ -222,7 +226,7 @@ extract v (Expr m) = (IntMap.findWithDefault 0 v m, Expr (IntMap.delete v m)) {- -- Alternative implementation which may be faster but allocte more memory -extract v (Expr m) = +extract v (Expr m) = case IntMap.updateLookupWithKey (\_ _ -> Nothing) v m of (Nothing, _) -> (0, Expr m) (Just c, m2) -> (c, Expr m2) diff --git a/src/ToySolver/Data/LA/FOL.hs b/src/ToySolver/Data/LA/FOL.hs --- a/src/ToySolver/Data/LA/FOL.hs +++ b/src/ToySolver/Data/LA/FOL.hs @@ -1,4 +1,15 @@ {-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.LA.FOL +-- Copyright : (c) Masahiro Sakai 2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.Data.LA.FOL ( fromFOLAtom , toFOLFormula diff --git a/src/ToySolver/Data/LBool.hs b/src/ToySolver/Data/LBool.hs --- a/src/ToySolver/Data/LBool.hs +++ b/src/ToySolver/Data/LBool.hs @@ -3,16 +3,16 @@ -- Module : ToySolver.Data.LBool -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Lifted boolean type. --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.LBool - ( LBool + ( LBool (..) , lTrue , lFalse , lUndef diff --git a/src/ToySolver/Data/MIP.hs b/src/ToySolver/Data/MIP.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.MIP --- Copyright : (c) Masahiro Sakai 2011-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable --- --- Mixed-Integer Programming Problems with some commmonly used extensions --- ------------------------------------------------------------------------------ -module ToySolver.Data.MIP - ( module ToySolver.Data.MIP.Base - , readFile - , readLPFile - , readMPSFile - , parseLPString - , parseMPSString - , writeFile - , writeLPFile - , writeMPSFile - , toLPString - , toMPSString - , ParseError - ) where - -import Prelude hiding (readFile, writeFile) -import Control.Exception -import Data.Char -import Data.Scientific (Scientific) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO -import System.FilePath (takeExtension, splitExtension) -import System.IO hiding (readFile, writeFile) - -import ToySolver.Data.MIP.Base -import ToySolver.Data.MIP.FileUtils (ParseError) -import qualified ToySolver.Data.MIP.LPFile as LPFile -import qualified ToySolver.Data.MIP.MPSFile as MPSFile - -#ifdef WITH_ZLIB -import qualified Codec.Compression.GZip as GZip -import qualified Data.ByteString.Lazy as BL -import Data.ByteString.Lazy.Encoding (encode, decode) -import qualified Data.CaseInsensitive as CI -import GHC.IO.Encoding (getLocaleEncoding) -#endif - --- | Parse .lp or .mps file based on file extension -readFile :: FileOptions -> FilePath -> IO (Problem Scientific) -readFile opt fname = - case getExt fname of - ".lp" -> readLPFile opt fname - ".mps" -> readMPSFile opt fname - ext -> ioError $ userError $ "unknown extension: " ++ ext - --- | Parse a file containing LP file data. -readLPFile :: FileOptions -> FilePath -> IO (Problem Scientific) -#ifndef WITH_ZLIB -readLPFile = LPFile.parseFile -#else -readLPFile opt fname = do - s <- readTextFile opt fname - let ret = LPFile.parseString opt fname s - case ret of - Left e -> throw e - Right a -> return a -#endif - --- | Parse a file containing MPS file data. -readMPSFile :: FileOptions -> FilePath -> IO (Problem Scientific) -#ifndef WITH_ZLIB -readMPSFile = MPSFile.parseFile -#else -readMPSFile opt fname = do - s <- readTextFile opt fname - let ret = MPSFile.parseString opt fname s - case ret of - Left e -> throw e - Right a -> return a -#endif - -readTextFile :: FileOptions -> FilePath -> IO TL.Text -#ifndef WITH_ZLIB -readTextFile opt fname = do - h <- openFile fname ReadMode - case MIP.optFileEncoding opt of - Nothing -> return () - Just enc -> hSetEncoding h enc - TLIO.hGetContents h -#else -readTextFile opt fname = do - enc <- case optFileEncoding opt of - Nothing -> getLocaleEncoding - Just enc -> return enc - let f = if CI.mk (takeExtension fname) == ".gz" then GZip.decompress else id - s <- BL.readFile fname - return $ decode enc $ f s -#endif - --- | Parse a string containing LP file data. -parseLPString :: FileOptions -> String -> String -> Either (ParseError String) (Problem Scientific) -parseLPString = LPFile.parseString - --- | Parse a string containing MPS file data. -parseMPSString :: FileOptions -> String -> String -> Either (ParseError String) (Problem Scientific) -parseMPSString = MPSFile.parseString - -writeFile :: FileOptions -> FilePath -> Problem Scientific -> IO () -writeFile opt fname prob = - case getExt fname of - ".lp" -> writeLPFile opt fname prob - ".mps" -> writeMPSFile opt fname prob - ext -> ioError $ userError $ "unknown extension: " ++ ext - -getExt :: String -> String -getExt name | (base, ext) <- splitExtension name = - case map toLower ext of -#ifdef WITH_ZLIB - ".gz" -> getExt base -#endif - s -> s - -writeLPFile :: FileOptions -> FilePath -> Problem Scientific -> IO () -writeLPFile opt fname prob = - case LPFile.render opt prob of - Left err -> ioError $ userError err - Right s -> writeTextFile opt fname s - -writeMPSFile :: FileOptions -> FilePath -> Problem Scientific -> IO () -writeMPSFile opt fname prob = - case MPSFile.render opt prob of - Left err -> ioError $ userError err - Right s -> writeTextFile opt fname s - -writeTextFile :: FileOptions -> FilePath -> TL.Text -> IO () -writeTextFile opt fname s = do - let writeSimple = do - withFile fname WriteMode $ \h -> do - case optFileEncoding opt of - Nothing -> return () - Just enc -> hSetEncoding h enc - TLIO.hPutStr h s -#ifdef WITH_ZLIB - if CI.mk (takeExtension fname) /= ".gz" then do - writeSimple - else do - enc <- case optFileEncoding opt of - Nothing -> getLocaleEncoding - Just enc -> return enc - BL.writeFile fname $ GZip.compress $ encode enc s -#else - writeSimple -#endif - -toLPString :: FileOptions -> Problem Scientific -> Either String TL.Text -toLPString = LPFile.render - -toMPSString :: FileOptions -> Problem Scientific -> Either String TL.Text -toMPSString = MPSFile.render diff --git a/src/ToySolver/Data/MIP/Base.hs b/src/ToySolver/Data/MIP/Base.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Base.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.MIP.Base --- Copyright : (c) Masahiro Sakai 2011-2019 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- --- Mixed-Integer Programming Problems with some commmonly used extensions --- ------------------------------------------------------------------------------ -module ToySolver.Data.MIP.Base - ( - -- * The MIP Problem type - Problem (..) - , Label - - -- * Variables - , Var - , toVar - , fromVar - - -- ** Variable types - , VarType (..) - , getVarType - - -- ** Variable bounds - , BoundExpr - , Extended (..) - , Bounds - , defaultBounds - , defaultLB - , defaultUB - , getBounds - - -- ** Variable getters - , variables - , integerVariables - , semiContinuousVariables - , semiIntegerVariables - - -- * Expressions - , Expr (..) - , varExpr - , constExpr - , terms - , Term (..) - - -- * Objective function - , OptDir (..) - , ObjectiveFunction (..) - - -- * Constraints - - -- ** Linear (or Quadratic or Polynomial) constraints - , Constraint (..) - , (.==.) - , (.<=.) - , (.>=.) - , RelOp (..) - - -- ** SOS constraints - , SOSType (..) - , SOSConstraint (..) - - -- * Solutions - , Solution (..) - , Status (..) - , meetStatus - - -- * File I/O options - , FileOptions (..) - - -- * Utilities - , Variables (..) - , intersectBounds - ) where - -#if !MIN_VERSION_lattices(2,0,0) -import Algebra.Lattice -#endif -import Algebra.PartialOrd -import Control.Arrow ((***)) -import Data.Default.Class -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Interned (unintern) -import Data.Interned.Text -import Data.ExtendedReal -import Data.OptDir -import Data.String -import qualified Data.Text as T -import System.IO (TextEncoding) - -infix 4 .<=., .>=., .==. - --- --------------------------------------------------------------------------- - --- | Problem -data Problem c - = Problem - { name :: Maybe T.Text - , objectiveFunction :: ObjectiveFunction c - , constraints :: [Constraint c] - , sosConstraints :: [SOSConstraint c] - , userCuts :: [Constraint c] - , varType :: Map Var VarType - , varBounds :: Map Var (Bounds c) - } - deriving (Show, Eq, Ord) - -instance Default (Problem c) where - def = Problem - { name = Nothing - , objectiveFunction = def - , constraints = [] - , sosConstraints = [] - , userCuts = [] - , varType = Map.empty - , varBounds = Map.empty - } - -instance Functor Problem where - fmap f prob = - prob - { objectiveFunction = fmap f (objectiveFunction prob) - , constraints = map (fmap f) (constraints prob) - , sosConstraints = map (fmap f) (sosConstraints prob) - , userCuts = map (fmap f) (userCuts prob) - , varBounds = fmap (fmap f *** fmap f) (varBounds prob) - } - --- | label -type Label = T.Text - --- --------------------------------------------------------------------------- - --- | variable -type Var = InternedText - --- | convert a string into a variable -toVar :: String -> Var -toVar = fromString - --- | convert a variable into a string -fromVar :: Var -> String -fromVar = T.unpack . unintern - -data VarType - = ContinuousVariable - | IntegerVariable - | SemiContinuousVariable - | SemiIntegerVariable - deriving (Eq, Ord, Show) - -instance Default VarType where - def = ContinuousVariable - --- | looking up bounds for a variable -getVarType :: Problem c -> Var -> VarType -getVarType mip v = Map.findWithDefault def v (varType mip) - --- | type for representing lower/upper bound of variables -type BoundExpr c = Extended c - --- | type for representing lower/upper bound of variables -type Bounds c = (BoundExpr c, BoundExpr c) - --- | default bounds -defaultBounds :: Num c => Bounds c -defaultBounds = (defaultLB, defaultUB) - --- | default lower bound (0) -defaultLB :: Num c => BoundExpr c -defaultLB = Finite 0 - --- | default upper bound (+∞) -defaultUB :: BoundExpr c -defaultUB = PosInf - --- | looking up bounds for a variable -getBounds :: Num c => Problem c -> Var -> Bounds c -getBounds mip v = Map.findWithDefault defaultBounds v (varBounds mip) - -intersectBounds :: Ord c => Bounds c -> Bounds c -> Bounds c -intersectBounds (lb1,ub1) (lb2,ub2) = (max lb1 lb2, min ub1 ub2) - --- --------------------------------------------------------------------------- - --- | expressions -newtype Expr c = Expr [Term c] - deriving (Eq, Ord, Show) - -varExpr :: Num c => Var -> Expr c -varExpr v = Expr [Term 1 [v]] - -constExpr :: (Eq c, Num c) => c -> Expr c -constExpr 0 = Expr [] -constExpr c = Expr [Term c []] - -terms :: Expr c -> [Term c] -terms (Expr ts) = ts - -instance Num c => Num (Expr c) where - Expr e1 + Expr e2 = Expr (e1 ++ e2) - Expr e1 * Expr e2 = Expr [Term (c1*c2) (vs1 ++ vs2) | Term c1 vs1 <- e1, Term c2 vs2 <- e2] - negate (Expr e) = Expr [Term (-c) vs | Term c vs <- e] - abs = id - signum _ = 1 - fromInteger 0 = Expr [] - fromInteger c = Expr [Term (fromInteger c) []] - -instance Functor Expr where - fmap f (Expr ts) = Expr $ map (fmap f) ts - -splitConst :: Num c => Expr c -> (Expr c, c) -splitConst e = (e2, c2) - where - e2 = Expr [t | t@(Term _ (_:_)) <- terms e] - c2 = sum [c | Term c [] <- terms e] - --- | terms -data Term c = Term c [Var] - deriving (Eq, Ord, Show) - -instance Functor Term where - fmap f (Term c vs) = Term (f c) vs - --- --------------------------------------------------------------------------- - --- | objective function -data ObjectiveFunction c - = ObjectiveFunction - { objLabel :: Maybe Label - , objDir :: OptDir - , objExpr :: Expr c - } - deriving (Eq, Ord, Show) - -instance Default (ObjectiveFunction c) where - def = - ObjectiveFunction - { objLabel = Nothing - , objDir = OptMin - , objExpr = Expr [] - } - -instance Functor ObjectiveFunction where - fmap f obj = obj{ objExpr = fmap f (objExpr obj) } - --- --------------------------------------------------------------------------- - --- | constraint -data Constraint c - = Constraint - { constrLabel :: Maybe Label - , constrIndicator :: Maybe (Var, c) - , constrExpr :: Expr c - , constrLB :: BoundExpr c - , constrUB :: BoundExpr c - , constrIsLazy :: Bool - } - deriving (Eq, Ord, Show) - -(.==.) :: Num c => Expr c -> Expr c -> Constraint c -lhs .==. rhs = - case splitConst (lhs - rhs) of - (e, c) -> def{ constrExpr = e, constrLB = Finite (- c), constrUB = Finite (- c) } - -(.<=.) :: Num c => Expr c -> Expr c -> Constraint c -lhs .<=. rhs = - case splitConst (lhs - rhs) of - (e, c) -> def{ constrExpr = e, constrUB = Finite (- c) } - -(.>=.) :: Num c => Expr c -> Expr c -> Constraint c -lhs .>=. rhs = - case splitConst (lhs - rhs) of - (e, c) -> def{ constrExpr = e, constrLB = Finite (- c) } - -instance Default (Constraint c) where - def = Constraint - { constrLabel = Nothing - , constrIndicator = Nothing - , constrExpr = Expr [] - , constrLB = NegInf - , constrUB = PosInf - , constrIsLazy = False - } - -instance Functor Constraint where - fmap f c = - c - { constrIndicator = fmap (id *** f) (constrIndicator c) - , constrExpr = fmap f (constrExpr c) - , constrLB = fmap f (constrLB c) - , constrUB = fmap f (constrUB c) - } - --- | relational operators -data RelOp = Le | Ge | Eql - deriving (Eq, Ord, Enum, Show) - --- --------------------------------------------------------------------------- - --- | types of SOS (special ordered sets) constraints -data SOSType - = S1 -- ^ Type 1 SOS constraint - | S2 -- ^ Type 2 SOS constraint - deriving (Eq, Ord, Enum, Show, Read) - --- | SOS (special ordered sets) constraints -data SOSConstraint c - = SOSConstraint - { sosLabel :: Maybe Label - , sosType :: SOSType - , sosBody :: [(Var, c)] - } - deriving (Eq, Ord, Show) - -instance Functor SOSConstraint where - fmap f c = c{ sosBody = map (id *** f) (sosBody c) } - --- --------------------------------------------------------------------------- - --- | MIP status with the following partial order: --- --- <> -data Status - = StatusUnknown - | StatusFeasible - | StatusOptimal - | StatusInfeasibleOrUnbounded - | StatusInfeasible - | StatusUnbounded - deriving (Eq, Ord, Enum, Bounded, Show) - -instance PartialOrd Status where - leq a b = (a,b) `Set.member` rel - where - rel = unsafeLfpFrom rel0 $ \r -> - Set.union r (Set.fromList [(a,c) | (a,b) <- Set.toList r, (b',c) <- Set.toList r, b == b']) - rel0 = Set.fromList $ - [(a,a) | a <- [minBound .. maxBound]] ++ - [ (StatusUnknown, StatusFeasible) - , (StatusUnknown, StatusInfeasibleOrUnbounded) - , (StatusFeasible, StatusOptimal) - , (StatusFeasible, StatusUnbounded) - , (StatusInfeasibleOrUnbounded, StatusUnbounded) - , (StatusInfeasibleOrUnbounded, StatusInfeasible) - ] - - -meetStatus :: Status -> Status -> Status -StatusUnknown `meetStatus` b = StatusUnknown -StatusFeasible `meetStatus` b - | StatusFeasible `leq` b = StatusFeasible - | otherwise = StatusUnknown -StatusOptimal `meetStatus` StatusOptimal = StatusOptimal -StatusOptimal `meetStatus` b - | StatusFeasible `leq` b = StatusFeasible - | otherwise = StatusUnknown -StatusInfeasibleOrUnbounded `meetStatus` b - | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded - | otherwise = StatusUnknown -StatusInfeasible `meetStatus` StatusInfeasible = StatusInfeasible -StatusInfeasible `meetStatus` b - | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded - | otherwise = StatusUnknown -StatusUnbounded `meetStatus` StatusUnbounded = StatusUnbounded -StatusUnbounded `meetStatus` b - | StatusFeasible `leq` b = StatusFeasible - | StatusInfeasibleOrUnbounded `leq` b = StatusInfeasibleOrUnbounded - | otherwise = StatusUnknown - -#if !MIN_VERSION_lattices(2,0,0) - -instance MeetSemiLattice Status where - meet = meetStatus - -#endif - - -data Solution r - = Solution - { solStatus :: Status - , solObjectiveValue :: Maybe r - , solVariables :: Map Var r - } - deriving (Eq, Ord, Show) - -instance Functor Solution where - fmap f (Solution status obj vs) = Solution status (fmap f obj) (fmap f vs) - -instance Default (Solution r) where - def = Solution - { solStatus = StatusUnknown - , solObjectiveValue = Nothing - , solVariables = Map.empty - } - --- --------------------------------------------------------------------------- - -class Variables a where - vars :: a -> Set Var - -instance Variables a => Variables [a] where - vars = Set.unions . map vars - -instance (Variables a, Variables b) => Variables (Either a b) where - vars (Left a) = vars a - vars (Right b) = vars b - -instance Variables (Problem c) where - vars = variables - -instance Variables (Expr c) where - vars (Expr e) = vars e - -instance Variables (Term c) where - vars (Term _ xs) = Set.fromList xs - -instance Variables (ObjectiveFunction c) where - vars ObjectiveFunction{ objExpr = e } = vars e - -instance Variables (Constraint c) where - vars Constraint{ constrIndicator = ind, constrExpr = e } = Set.union (vars e) vs2 - where - vs2 = maybe Set.empty (Set.singleton . fst) ind - -instance Variables (SOSConstraint c) where - vars SOSConstraint{ sosBody = xs } = Set.fromList (map fst xs) - --- --------------------------------------------------------------------------- - -variables :: Problem c -> Set Var -variables mip = Map.keysSet $ varType mip - -integerVariables :: Problem c -> Set Var -integerVariables mip = Map.keysSet $ Map.filter (IntegerVariable ==) (varType mip) - -semiContinuousVariables :: Problem c -> Set Var -semiContinuousVariables mip = Map.keysSet $ Map.filter (SemiContinuousVariable ==) (varType mip) - -semiIntegerVariables :: Problem c -> Set Var -semiIntegerVariables mip = Map.keysSet $ Map.filter (SemiIntegerVariable ==) (varType mip) - --- --------------------------------------------------------------------------- - -data FileOptions - = FileOptions - { optFileEncoding :: Maybe TextEncoding - } deriving (Show) - -instance Default FileOptions where - def = - FileOptions - { optFileEncoding = Nothing - } diff --git a/src/ToySolver/Data/MIP/FileUtils.hs b/src/ToySolver/Data/MIP/FileUtils.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/FileUtils.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.MIP.FileUtils --- Copyright : (c) Masahiro Sakai 2018 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- ------------------------------------------------------------------------------ -module ToySolver.Data.MIP.FileUtils - ( ParseError - ) where - -#if MIN_VERSION_megaparsec(6,0,0) -import Data.Void -#endif -import qualified Text.Megaparsec as MP - -#if MIN_VERSION_megaparsec(7,0,0) -type ParseError s = MP.ParseErrorBundle s Void -#elif MIN_VERSION_megaparsec(6,0,0) -type ParseError s = MP.ParseError (MP.Token s) Void -#elif MIN_VERSION_megaparsec(5,0,0) -type ParseError s = MP.ParseError (MP.Token s) MP.Dec -#else -type ParseError s = MP.ParseError -#endif diff --git a/src/ToySolver/Data/MIP/LPFile.hs b/src/ToySolver/Data/MIP/LPFile.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/LPFile.hs +++ /dev/null @@ -1,751 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.MIP.LPFile --- Copyright : (c) Masahiro Sakai 2011-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable --- --- A CPLEX .lp format parser library. --- --- References: --- --- * --- --- * --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.Data.MIP.LPFile - ( parseString - , parseFile - , ParseError - , parser - , render - ) where - -import Control.Applicative hiding (many) -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.Writer -import Control.Monad.ST -import Data.Char -import Data.Default.Class -import Data.Interned -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Scientific (Scientific) -#if !MIN_VERSION_megaparsec(5,0,0) -import Data.Scientific (fromFloatDigits) -#endif -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.STRef -import Data.String -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Scientific as B -import qualified Data.Text.Lazy.IO as TLIO -import Data.OptDir -import System.IO -#if MIN_VERSION_megaparsec(6,0,0) -import Text.Megaparsec hiding (label, skipManyTill, ParseError) -import Text.Megaparsec.Char hiding (string', char') -import qualified Text.Megaparsec.Char.Lexer as P -#else -import Text.Megaparsec hiding (label, string', char', ParseError) -import qualified Text.Megaparsec.Lexer as P -import Text.Megaparsec.Prim (MonadParsec ()) -#endif - -import qualified ToySolver.Data.MIP.Base as MIP -import ToySolver.Data.MIP.FileUtils (ParseError) -import ToySolver.Internal.Util (combineMaybe) - --- --------------------------------------------------------------------------- - -#if MIN_VERSION_megaparsec(6,0,0) -type C e s m = (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) -#elif MIN_VERSION_megaparsec(5,0,0) -type C e s m = (MonadParsec e s m, Token s ~ Char) -#else -type C e s m = (MonadParsec s m Char) -#endif - --- | Parse a string containing LP file data. --- The source name is only | used in error messages and may be the empty string. -#if MIN_VERSION_megaparsec(6,0,0) -parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#elif MIN_VERSION_megaparsec(5,0,0) -parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#else -parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#endif -parseString _ = parse (parser <* eof) - --- | Parse a file containing LP file data. -parseFile :: MIP.FileOptions -> FilePath -> IO (MIP.Problem Scientific) -parseFile opt fname = do - h <- openFile fname ReadMode - case MIP.optFileEncoding opt of - Nothing -> return () - Just enc -> hSetEncoding h enc - ret <- parse (parser <* eof) fname <$> TLIO.hGetContents h - case ret of - Left e -> throwIO (e :: ParseError TL.Text) - Right a -> return a - --- --------------------------------------------------------------------------- - -#if MIN_VERSION_megaparsec(7,0,0) -anyChar :: C e s m => m Char -anyChar = anySingle -#endif - -char' :: C e s m => Char -> m Char -char' c = (char c <|> char (toUpper c)) show c - -string' :: C e s m => String -> m () -string' s = mapM_ char' s show s - -sep :: C e s m => m () -sep = skipMany ((comment >> return ()) <|> (spaceChar >> return ())) - -comment :: C e s m => m () -comment = do - char '\\' - skipManyTill anyChar (try newline) - -tok :: C e s m => m a -> m a -tok p = do - x <- p - sep - return x - -ident :: C e s m => m String -ident = tok $ do - x <- letterChar <|> oneOf syms1 - xs <- many (alphaNumChar <|> oneOf syms2) - let s = x:xs - guard $ map toLower s `Set.notMember` reserved - return s - where - syms1 = "!\"#$%&()/,;?@_`'{}|~" - syms2 = '.' : syms1 - -variable :: C e s m => m MIP.Var -variable = liftM MIP.toVar ident - -label :: C e s m => m MIP.Label -label = do - name <- ident - tok $ char ':' - return $! T.pack name - -reserved :: Set String -reserved = Set.fromList - [ "bound", "bounds" - , "gen", "general", "generals" - , "bin", "binary", "binaries" - , "semi", "semi-continuous", "semis" - , "sos" - , "end" - , "subject" - ] - --- --------------------------------------------------------------------------- - --- | LP file parser -#if MIN_VERSION_megaparsec(6,0,0) -parser :: (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (MIP.Problem Scientific) -#elif MIN_VERSION_megaparsec(5,0,0) -parser :: (MonadParsec e s m, Token s ~ Char) => m (MIP.Problem Scientific) -#else -parser :: MonadParsec s m Char => m (MIP.Problem Scientific) -#endif -parser = do - name <- optional $ try $ do - space - string' "\\* Problem: " - liftM fromString $ manyTill anyChar (try (string " *\\\n")) - sep - obj <- problem - - cs <- liftM concat $ many $ msum $ - [ liftM (map Left) constraintSection - , liftM (map Left) lazyConstraintsSection - , liftM (map Right) userCutsSection - ] - - bnds <- option Map.empty (try boundsSection) - exvs <- many (liftM Left generalSection <|> liftM Right binarySection) - let ints = Set.fromList $ concat [x | Left x <- exvs] - bins = Set.fromList $ concat [x | Right x <- exvs] - bnds2 <- return $ Map.unionWith MIP.intersectBounds - bnds (Map.fromAscList [(v, (MIP.Finite 0, MIP.Finite 1)) | v <- Set.toAscList bins]) - scs <- liftM Set.fromList $ option [] (try semiSection) - - ss <- option [] (try sosSection) - end - let vs = Set.unions $ map MIP.vars cs ++ - [ Map.keysSet bnds2 - , ints - , bins - , scs - , MIP.vars obj - , MIP.vars ss - ] - isInt v = v `Set.member` ints || v `Set.member` bins - isSemi v = v `Set.member` scs - return $ - MIP.Problem - { MIP.name = name - , MIP.objectiveFunction = obj - , MIP.constraints = [c | Left c <- cs] - , MIP.userCuts = [c | Right c <- cs] - , MIP.sosConstraints = ss - , MIP.varType = Map.fromAscList - [ ( v - , if isInt v then - if isSemi v then MIP.SemiIntegerVariable - else MIP.IntegerVariable - else - if isSemi v then MIP.SemiContinuousVariable - else MIP.ContinuousVariable - ) - | v <- Set.toAscList vs ] - , MIP.varBounds = Map.fromAscList [ (v, Map.findWithDefault MIP.defaultBounds v bnds2) | v <- Set.toAscList vs] - } - -problem :: C e s m => m (MIP.ObjectiveFunction Scientific) -problem = do - flag <- (try minimize >> return OptMin) - <|> (try maximize >> return OptMax) - name <- optional (try label) - obj <- expr - return def{ MIP.objLabel = name, MIP.objDir = flag, MIP.objExpr = obj } - -minimize, maximize :: C e s m => m () -minimize = tok $ string' "min" >> optional (string' "imize") >> return () -maximize = tok $ string' "max" >> optional (string' "imize") >> return () - -end :: C e s m => m () -end = tok $ string' "end" - --- --------------------------------------------------------------------------- - -constraintSection :: C e s m => m [MIP.Constraint Scientific] -constraintSection = subjectTo >> many (try (constraint False)) - -subjectTo :: C e s m => m () -subjectTo = msum - [ try $ tok (string' "subject") >> tok (string' "to") - , try $ tok (string' "such") >> tok (string' "that") - , try $ tok (string' "st") - , try $ tok (string' "s") >> optional (tok (char '.')) >> tok (string' "t") - >> tok (char '.') >> return () - ] - -constraint :: C e s m => Bool -> m (MIP.Constraint Scientific) -constraint isLazy = do - name <- optional (try label) - g <- optional $ try indicator - - -- It seems that CPLEX allows empty lhs, but GLPK rejects it. - e <- expr - op <- relOp - s <- option 1 sign - rhs <- liftM (s*) number - - let (lb,ub) = - case op of - MIP.Le -> (MIP.NegInf, MIP.Finite rhs) - MIP.Ge -> (MIP.Finite rhs, MIP.PosInf) - MIP.Eql -> (MIP.Finite rhs, MIP.Finite rhs) - - return $ MIP.Constraint - { MIP.constrLabel = name - , MIP.constrIndicator = g - , MIP.constrExpr = e - , MIP.constrLB = lb - , MIP.constrUB = ub - , MIP.constrIsLazy = isLazy - } - -relOp :: C e s m => m MIP.RelOp -relOp = tok $ msum - [ char '<' >> optional (char '=') >> return MIP.Le - , char '>' >> optional (char '=') >> return MIP.Ge - , char '=' >> msum [ char '<' >> return MIP.Le - , char '>' >> return MIP.Ge - , return MIP.Eql - ] - ] - -indicator :: C e s m => m (MIP.Var, Scientific) -indicator = do - var <- variable - tok (char '=') - val <- tok ((char '0' >> return 0) <|> (char '1' >> return 1)) - tok $ string "->" - return (var, val) - -lazyConstraintsSection :: C e s m => m [MIP.Constraint Scientific] -lazyConstraintsSection = do - tok $ string' "lazy" - tok $ string' "constraints" - many $ try $ constraint True - -userCutsSection :: C e s m => m [MIP.Constraint Scientific] -userCutsSection = do - tok $ string' "user" - tok $ string' "cuts" - many $ try $ constraint False - -type Bounds2 c = (Maybe (MIP.BoundExpr c), Maybe (MIP.BoundExpr c)) - -boundsSection :: C e s m => m (Map MIP.Var (MIP.Bounds Scientific)) -boundsSection = do - tok $ string' "bound" >> optional (char' 's') - liftM (Map.map g . Map.fromListWith f) $ many (try bound) - where - f (lb1,ub1) (lb2,ub2) = (combineMaybe max lb1 lb2, combineMaybe min ub1 ub2) - g (lb, ub) = ( fromMaybe MIP.defaultLB lb - , fromMaybe MIP.defaultUB ub - ) - -bound :: C e s m => m (MIP.Var, Bounds2 Scientific) -bound = msum - [ try $ do - v <- try variable - msum - [ do - op <- relOp - b <- boundExpr - return - ( v - , case op of - MIP.Le -> (Nothing, Just b) - MIP.Ge -> (Just b, Nothing) - MIP.Eql -> (Just b, Just b) - ) - , do - tok $ string' "free" - return (v, (Just MIP.NegInf, Just MIP.PosInf)) - ] - , do - b1 <- liftM Just boundExpr - op1 <- relOp - guard $ op1 == MIP.Le - v <- variable - b2 <- option Nothing $ do - op2 <- relOp - guard $ op2 == MIP.Le - liftM Just boundExpr - return (v, (b1, b2)) - ] - -boundExpr :: C e s m => m (MIP.BoundExpr Scientific) -boundExpr = msum - [ try (tok (char '+') >> inf >> return MIP.PosInf) - , try (tok (char '-') >> inf >> return MIP.NegInf) - , do - s <- option 1 sign - x <- number - return $ MIP.Finite (s*x) - ] - -inf :: C e s m => m () -inf = tok (string "inf" >> optional (string "inity")) >> return () - --- --------------------------------------------------------------------------- - -generalSection :: C e s m => m [MIP.Var] -generalSection = do - tok $ string' "gen" >> optional (string' "eral" >> optional (string' "s")) - many (try variable) - -binarySection :: C e s m => m [MIP.Var] -binarySection = do - tok $ string' "bin" >> optional (string' "ar" >> (string' "y" <|> string' "ies")) - many (try variable) - -semiSection :: C e s m => m [MIP.Var] -semiSection = do - tok $ string' "semi" >> optional (string' "-continuous" <|> string' "s") - many (try variable) - -sosSection :: C e s m => m [MIP.SOSConstraint Scientific] -sosSection = do - tok $ string' "sos" - many $ try $ do - (l,t) <- try (do{ l <- label; t <- typ; return (Just l, t) }) - <|> (do{ t <- typ; return (Nothing, t) }) - xs <- many $ try $ do - v <- variable - tok $ char ':' - w <- number - return (v,w) - return $ MIP.SOSConstraint l t xs - where - typ = do - t <- tok $ (char' 's' >> ((char '1' >> return MIP.S1) <|> (char '2' >> return MIP.S2))) - tok (string "::") - return t - --- --------------------------------------------------------------------------- - -expr :: forall e s m. C e s m => m (MIP.Expr Scientific) -expr = try expr1 <|> return 0 - where - expr1 :: m (MIP.Expr Scientific) - expr1 = do - t <- term True - ts <- many (term False) - return $ foldr (+) 0 (t : ts) - -sign :: (C e s m, Num a) => m a -sign = tok ((char '+' >> return 1) <|> (char '-' >> return (-1))) - -term :: C e s m => Bool -> m (MIP.Expr Scientific) -term flag = do - s <- if flag then optional sign else liftM Just sign - c <- optional number - e <- liftM MIP.varExpr variable <|> qexpr - return $ case combineMaybe (*) s c of - Nothing -> e - Just d -> MIP.constExpr d * e - -qexpr :: C e s m => m (MIP.Expr Scientific) -qexpr = do - tok (char '[') - t <- qterm True - ts <- many (qterm False) - let e = MIP.Expr (t:ts) - tok (char ']') - -- Gurobi allows ommiting "/2" - (do mapM_ (tok . char) ("/2" :: String) -- Explicit type signature is necessary because the type of mapM_ in GHC-7.10 is generalized for arbitrary Foldable - return $ MIP.constExpr (1/2) * e) - <|> return e - -qterm :: C e s m => Bool -> m (MIP.Term Scientific) -qterm flag = do - s <- if flag then optional sign else liftM Just sign - c <- optional number - es <- do - e <- qfactor - es <- many (tok (char '*') >> qfactor) - return $ e ++ concat es - return $ case combineMaybe (*) s c of - Nothing -> MIP.Term 1 es - Just d -> MIP.Term d es - -qfactor :: C e s m => m [MIP.Var] -qfactor = do - v <- variable - msum [ tok (char '^') >> tok (char '2') >> return [v,v] - , return [v] - ] - -number :: forall e s m. C e s m => m Scientific -#if MIN_VERSION_megaparsec(6,0,0) -number = tok $ P.signed sep P.scientific -#elif MIN_VERSION_megaparsec(5,0,0) -number = tok $ P.signed sep P.number -#else -number = tok $ liftM (either fromInteger fromFloatDigits) $ P.signed sep P.number -#endif - -skipManyTill :: Alternative m => m a -> m end -> m () -skipManyTill p end' = scan - where - scan = (end' *> pure ()) <|> (p *> scan) - --- --------------------------------------------------------------------------- - -type M a = Writer Builder a - -execM :: M a -> TL.Text -execM m = B.toLazyText $ execWriter m - -writeString :: T.Text -> M () -writeString s = tell $ B.fromText s - -writeChar :: Char -> M () -writeChar c = tell $ B.singleton c - --- --------------------------------------------------------------------------- - --- | Render a problem into a string. -render :: MIP.FileOptions -> MIP.Problem Scientific -> Either String TL.Text -render _ mip = Right $ execM $ render' $ normalize mip - -writeVar :: MIP.Var -> M () -writeVar v = writeString $ unintern v - -render' :: MIP.Problem Scientific -> M () -render' mip = do - case MIP.name mip of - Just name -> writeString $ "\\* Problem: " <> name <> " *\\\n" - Nothing -> return () - - let obj = MIP.objectiveFunction mip - - writeString $ - case MIP.objDir obj of - OptMin -> "MINIMIZE" - OptMax -> "MAXIMIZE" - writeChar '\n' - - renderLabel (MIP.objLabel obj) - renderExpr True (MIP.objExpr obj) - writeChar '\n' - - writeString "SUBJECT TO\n" - forM_ (MIP.constraints mip) $ \c -> do - unless (MIP.constrIsLazy c) $ do - renderConstraint c - writeChar '\n' - - let lcs = [c | c <- MIP.constraints mip, MIP.constrIsLazy c] - unless (null lcs) $ do - writeString "LAZY CONSTRAINTS\n" - forM_ lcs $ \c -> do - renderConstraint c - writeChar '\n' - - let cuts = [c | c <- MIP.userCuts mip] - unless (null cuts) $ do - writeString "USER CUTS\n" - forM_ cuts $ \c -> do - renderConstraint c - writeChar '\n' - - let ivs = MIP.integerVariables mip `Set.union` MIP.semiIntegerVariables mip - (bins,gens) = Set.partition (\v -> MIP.getBounds mip v == (MIP.Finite 0, MIP.Finite 1)) ivs - scs = MIP.semiContinuousVariables mip `Set.union` MIP.semiIntegerVariables mip - - writeString "BOUNDS\n" - forM_ (Map.toAscList (MIP.varBounds mip)) $ \(v, (lb,ub)) -> do - unless (v `Set.member` bins) $ do - renderBoundExpr lb - writeString " <= " - writeVar v - writeString " <= " - renderBoundExpr ub - writeChar '\n' - - unless (Set.null gens) $ do - writeString "GENERALS\n" - renderVariableList $ Set.toList gens - - unless (Set.null bins) $ do - writeString "BINARIES\n" - renderVariableList $ Set.toList bins - - unless (Set.null scs) $ do - writeString "SEMI-CONTINUOUS\n" - renderVariableList $ Set.toList scs - - unless (null (MIP.sosConstraints mip)) $ do - writeString "SOS\n" - forM_ (MIP.sosConstraints mip) $ \(MIP.SOSConstraint l typ xs) -> do - renderLabel l - writeString $ fromString $ show typ - writeString " ::" - forM_ xs $ \(v, r) -> do - writeString " " - writeVar v - writeString " : " - tell $ B.scientificBuilder r - writeChar '\n' - - writeString "END\n" - --- FIXME: Gurobi は quadratic term が最後に一つある形式でないとダメっぽい -renderExpr :: Bool -> MIP.Expr Scientific -> M () -renderExpr isObj e = fill 80 (ts1 ++ ts2) - where - (ts,qts) = partition isLin (MIP.terms e) - isLin (MIP.Term _ []) = True - isLin (MIP.Term _ [_]) = True - isLin _ = False - - ts1 = map f ts - ts2 - | null qts = [] - | otherwise = - -- マイナスで始めるとSCIP 2.1.1 は「cannot have '-' in front of quadratic part ('[')」というエラーを出す - -- SCIP-3.1.0 does not allow spaces between '/' and '2'. - ["+ ["] ++ map g qts ++ [if isObj then "] /2" else "]"] - - f :: MIP.Term Scientific -> T.Text - f (MIP.Term c []) = showConstTerm c - f (MIP.Term c [v]) = showCoeff c <> fromString (MIP.fromVar v) - f _ = error "should not happen" - - g :: MIP.Term Scientific -> T.Text - g (MIP.Term c vs) = - (if isObj then showCoeff (2*c) else showCoeff c) <> - mconcat (intersperse " * " (map (fromString . MIP.fromVar) vs)) - -showValue :: Scientific -> T.Text -showValue = fromString . show - -showCoeff :: Scientific -> T.Text -showCoeff c = - if c' == 1 - then s - else s <> showValue c' <> " " - where - c' = abs c - s = if c >= 0 then "+ " else "- " - -showConstTerm :: Scientific -> T.Text -showConstTerm c = s <> showValue (abs c) - where - s = if c >= 0 then "+ " else "- " - -renderLabel :: Maybe MIP.Label -> M () -renderLabel l = - case l of - Nothing -> return () - Just s -> writeString s >> writeString ": " - -renderOp :: MIP.RelOp -> M () -renderOp MIP.Le = writeString "<=" -renderOp MIP.Ge = writeString ">=" -renderOp MIP.Eql = writeString "=" - -renderConstraint :: MIP.Constraint Scientific -> M () -renderConstraint c@MIP.Constraint{ MIP.constrExpr = e, MIP.constrLB = lb, MIP.constrUB = ub } = do - renderLabel (MIP.constrLabel c) - case MIP.constrIndicator c of - Nothing -> return () - Just (v,vval) -> do - writeVar v - writeString " = " - tell $ B.scientificBuilder vval - writeString " -> " - - renderExpr False e - writeChar ' ' - let (op, val) = - case (lb, ub) of - (MIP.NegInf, MIP.Finite x) -> (MIP.Le, x) - (MIP.Finite x, MIP.PosInf) -> (MIP.Ge, x) - (MIP.Finite x1, MIP.Finite x2) | x1==x2 -> (MIP.Eql, x1) - _ -> error "ToySolver.Data.MIP.LPFile.renderConstraint: should not happen" - renderOp op - writeChar ' ' - tell $ B.scientificBuilder val - -renderBoundExpr :: MIP.BoundExpr Scientific -> M () -renderBoundExpr (MIP.Finite r) = tell $ B.scientificBuilder r -renderBoundExpr MIP.NegInf = writeString "-inf" -renderBoundExpr MIP.PosInf = writeString "+inf" - -renderVariableList :: [MIP.Var] -> M () -renderVariableList vs = fill 80 (map unintern vs) >> writeChar '\n' - -fill :: Int -> [T.Text] -> M () -fill width str = go str 0 - where - go [] _ = return () - go (x:xs) 0 = writeString x >> go xs (T.length x) - go (x:xs) w = - if w + 1 + T.length x <= width - then writeChar ' ' >> writeString x >> go xs (w + 1 + T.length x) - else writeChar '\n' >> go (x:xs) 0 - --- --------------------------------------------------------------------------- - -{- -compileExpr :: Expr -> Maybe (Map Var Scientific) -compileExpr e = do - xs <- forM e $ \(Term c vs) -> - case vs of - [v] -> return (v, c) - _ -> mzero - return (Map.fromList xs) --} - --- --------------------------------------------------------------------------- - -normalize :: (Eq r, Num r) => MIP.Problem r -> MIP.Problem r -normalize = removeEmptyExpr . removeRangeConstraints - -removeRangeConstraints :: (Eq r, Num r) => MIP.Problem r -> MIP.Problem r -removeRangeConstraints prob = runST $ do - vsRef <- newSTRef $ MIP.variables prob - cntRef <- newSTRef (0::Int) - newvsRef <- newSTRef [] - - let gensym = do - vs <- readSTRef vsRef - let loop !c = do - let v = MIP.toVar ("~r_" ++ show c) - if v `Set.member` vs then - loop (c+1) - else do - writeSTRef cntRef $! c+1 - modifySTRef vsRef (Set.insert v) - return v - loop =<< readSTRef cntRef - - cs2 <- forM (MIP.constraints prob) $ \c -> do - case (MIP.constrLB c, MIP.constrUB c) of - (MIP.NegInf, MIP.Finite _) -> return c - (MIP.Finite _, MIP.PosInf) -> return c - (MIP.Finite x1, MIP.Finite x2) | x1 == x2 -> return c - (lb, ub) -> do - v <- gensym - modifySTRef newvsRef ((v, (lb,ub)) :) - return $ - c - { MIP.constrExpr = MIP.constrExpr c - MIP.varExpr v - , MIP.constrLB = MIP.Finite 0 - , MIP.constrUB = MIP.Finite 0 - } - - newvs <- liftM reverse $ readSTRef newvsRef - return $ - prob - { MIP.constraints = cs2 - , MIP.varType = MIP.varType prob `Map.union` Map.fromList [(v, MIP.ContinuousVariable) | (v,_) <- newvs] - , MIP.varBounds = MIP.varBounds prob `Map.union` (Map.fromList newvs) - } - -removeEmptyExpr :: Num r => MIP.Problem r -> MIP.Problem r -removeEmptyExpr prob = - prob - { MIP.objectiveFunction = obj{ MIP.objExpr = convertExpr (MIP.objExpr obj) } - , MIP.constraints = map convertConstr $ MIP.constraints prob - , MIP.userCuts = map convertConstr $ MIP.userCuts prob - } - where - obj = MIP.objectiveFunction prob - - convertExpr (MIP.Expr []) = MIP.Expr [MIP.Term 0 [MIP.toVar "x0"]] - convertExpr e = e - - convertConstr constr = - constr - { MIP.constrExpr = convertExpr $ MIP.constrExpr constr - } diff --git a/src/ToySolver/Data/MIP/MPSFile.hs b/src/ToySolver/Data/MIP/MPSFile.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/MPSFile.hs +++ /dev/null @@ -1,925 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.Data.MIP.MPSFile --- Copyright : (c) Masahiro Sakai 2012-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable --- --- A .mps format parser library. --- --- References: --- --- * --- --- * --- --- * --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.Data.MIP.MPSFile - ( parseString - , parseFile - , ParseError - , parser - , render - ) where - -import Control.Applicative ((<$>), (<*)) -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.Writer -import Data.Default.Class -import Data.Maybe -import Data.Monoid -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Scientific -import Data.Interned -import Data.Interned.Text -import Data.String -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import Data.Text.Lazy.Builder (Builder) -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.IO as TLIO -import System.IO -#if MIN_VERSION_megaparsec(6,0,0) -import Text.Megaparsec hiding (ParseError) -import Text.Megaparsec.Char hiding (string', newline) -import qualified Text.Megaparsec.Char as P -import qualified Text.Megaparsec.Char.Lexer as Lexer -#else -import qualified Text.Megaparsec as P -import Text.Megaparsec hiding (string', newline, ParseError) -import qualified Text.Megaparsec.Lexer as Lexer -import Text.Megaparsec.Prim (MonadParsec ()) -#endif - -import Data.OptDir -import qualified ToySolver.Data.MIP.Base as MIP -import ToySolver.Data.MIP.FileUtils (ParseError) - -type Column = MIP.Var -type Row = InternedText - -data BoundType - = LO -- lower bound - | UP -- upper bound - | FX -- variable is fixed at the specified value - | FR -- free variable (no lower or upper bound) - | MI -- infinite lower bound - | PL -- infinite upper bound - | BV -- variable is binary (equal 0 or 1) - | LI -- lower bound for integer variable - | UI -- upper bound for integer variable - | SC -- upper bound for semi-continuous variable - | SI -- upper bound for semi-integer variable - deriving (Eq, Ord, Show, Read, Enum, Bounded) - --- --------------------------------------------------------------------------- - -#if MIN_VERSION_megaparsec(6,0,0) -type C e s m = (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) -#elif MIN_VERSION_megaparsec(5,0,0) -type C e s m = (MonadParsec e s m, Token s ~ Char) -#else -type C e s m = (MonadParsec s m Char) -#endif - --- | Parse a string containing MPS file data. --- The source name is only | used in error messages and may be the empty string. -#if MIN_VERSION_megaparsec(6,0,0) -parseString :: (Stream s, Token s ~ Char, IsString (Tokens s)) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#elif MIN_VERSION_megaparsec(5,0,0) -parseString :: (Stream s, Token s ~ Char) => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#else -parseString :: Stream s Char => MIP.FileOptions -> String -> s -> Either (ParseError s) (MIP.Problem Scientific) -#endif -parseString _ = parse (parser <* eof) - --- | Parse a file containing MPS file data. -parseFile :: MIP.FileOptions -> FilePath -> IO (MIP.Problem Scientific) -parseFile opt fname = do - h <- openFile fname ReadMode - case MIP.optFileEncoding opt of - Nothing -> return () - Just enc -> hSetEncoding h enc - ret <- parse (parser <* eof) fname <$> TLIO.hGetContents h - case ret of - Left e -> throwIO (e :: ParseError TL.Text) - Right a -> return a - --- --------------------------------------------------------------------------- - - -#if MIN_VERSION_megaparsec(7,0,0) -anyChar :: C e s m => m Char -anyChar = anySingle -#endif - -space' :: C e s m => m Char -space' = oneOf [' ', '\t'] - -spaces' :: C e s m => m () -spaces' = skipMany space' - -spaces1' :: C e s m => m () -spaces1' = skipSome space' - -commentline :: C e s m => m () -commentline = do - _ <- char '*' - _ <- manyTill anyChar P.newline - return () - -newline' :: C e s m => m () -newline' = do - spaces' - _ <- P.newline - skipMany commentline - return () - -tok :: C e s m => m a -> m a -tok p = do - x <- p - msum [eof, lookAhead (char '\n' >> return ()), spaces1'] - return x - -row :: C e s m => m Row -row = liftM intern ident - -column :: C e s m => m Column -column = liftM intern $ ident - -ident :: C e s m => m T.Text -ident = liftM fromString $ tok $ some $ noneOf [' ', '\t', '\n'] - -stringLn :: C e s m => String -> m () -stringLn s = string (fromString s) >> newline' - -number :: forall e s m. C e s m => m Scientific -#if MIN_VERSION_megaparsec(6,0,0) -number = tok $ Lexer.signed (return ()) Lexer.scientific -#elif MIN_VERSION_megaparsec(5,0,0) -number = tok $ Lexer.signed (return ()) Lexer.number -#else -number = tok $ liftM (either fromInteger fromFloatDigits) $ Lexer.signed (return ()) Lexer.number -#endif - --- --------------------------------------------------------------------------- - --- | MPS file parser -#if MIN_VERSION_megaparsec(6,0,0) -parser :: (MonadParsec e s m, Token s ~ Char, IsString (Tokens s)) => m (MIP.Problem Scientific) -#elif MIN_VERSION_megaparsec(5,0,0) -parser :: (MonadParsec e s m, Token s ~ Char) => m (MIP.Problem Scientific) -#else -parser :: MonadParsec s m Char => m (MIP.Problem Scientific) -#endif -parser = do - many commentline - - name <- nameSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_objsen.html - -- CPLEX extends the MPS standard by allowing two additional sections: OBJSEN and OBJNAME. - -- If these options are used, they must appear in order and as the first and second sections after the NAME section. - objsense <- optional $ objSenseSection - objname <- optional $ objNameSection - - rows <- rowsSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_usercuts.html - -- The order of sections must be ROWS USERCUTS. - usercuts <- option [] userCutsSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_lazycons.html - -- The order of sections must be ROWS USERCUTS LAZYCONS. - lazycons <- option [] lazyConsSection - - (cols, intvs1) <- colsSection - rhss <- rhsSection - rngs <- option Map.empty rangesSection - bnds <- option [] boundsSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_quadobj.html - -- Following the BOUNDS section, a QMATRIX section may be specified. - qobj <- msum [quadObjSection, qMatrixSection, return []] - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_sos.html - -- Note that in an MPS file, the SOS section must follow the BOUNDS section. - sos <- option [] sosSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_qcmatrix.html - -- QCMATRIX sections appear after the optional SOS section. - qterms <- liftM Map.fromList $ many qcMatrixSection - - -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_indicators.html - -- The INDICATORS section follows any quadratic constraint section and any quadratic objective section. - inds <- option Map.empty indicatorsSection - - string "ENDATA" - P.space - - let objrow = - case objname of - Nothing -> head [r | (Nothing, r) <- rows] -- XXX - Just r -> intern r - objdir = - case objsense of - Nothing -> OptMin - Just d -> d - vs = Map.keysSet cols `Set.union` Set.fromList [col | (_,col,_) <- bnds] - intvs2 = Set.fromList [col | (t,col,_) <- bnds, t `elem` [BV,LI,UI]] - scvs = Set.fromList [col | (SC,col,_) <- bnds] - sivs = Set.fromList [col | (SI,col,_) <- bnds] - - let explicitBounds = Map.fromListWith f - [ case typ of - LO -> (col, (Just (MIP.Finite val), Nothing)) - UP -> (col, (Nothing, Just (MIP.Finite val))) - FX -> (col, (Just (MIP.Finite val), Just (MIP.Finite val))) - FR -> (col, (Just MIP.NegInf, Just MIP.PosInf)) - MI -> (col, (Just MIP.NegInf, Nothing)) - PL -> (col, (Nothing, Just MIP.PosInf)) - BV -> (col, (Just (MIP.Finite 0), Just (MIP.Finite 1))) - LI -> (col, (Just (MIP.Finite val), Nothing)) - UI -> (col, (Nothing, Just (MIP.Finite val))) - SC -> (col, (Nothing, Just (MIP.Finite val))) - SI -> (col, (Nothing, Just (MIP.Finite val))) - | (typ,col,val) <- bnds ] - where - f (a1,b1) (a2,b2) = (g a1 a2, g b1 b2) - g _ (Just x) = Just x - g x Nothing = x - - let bounds = Map.fromList - [ case Map.lookup v explicitBounds of - Nothing -> - if v `Set.member` intvs1 - then - -- http://eaton.math.rpi.edu/cplex90html/reffileformatscplex/reffileformatscplex9.html - -- If no bounds are specified for the variables within markers, bounds of 0 (zero) and 1 (one) are assumed. - (v, (MIP.Finite 0, MIP.Finite 1)) - else - (v, (MIP.Finite 0, MIP.PosInf)) - Just (Nothing, Just (MIP.Finite ub)) | ub < 0 -> - {- - http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_records.html - If no bounds are specified, CPLEX assumes a lower - bound of 0 (zero) and an upper bound of +∞. If only a - single bound is specified, the unspecified bound - remains at 0 or +∞, whichever applies, with one - exception. If an upper bound of less than 0 is - specified and no other bound is specified, the lower - bound is automatically set to -∞. CPLEX deviates - slightly from a convention used by some MPS readers - when it encounters an upper bound of 0 (zero). Rather - than automatically set this variable’s lower bound to - -∞, CPLEX accepts both a lower and upper bound of 0, - effectively fixing that variable at 0. CPLEX resets - the lower bound to -∞ only if the upper bound is less - than 0. A warning message is issued when this - exception is encountered. - -} - (v, (MIP.NegInf, MIP.Finite ub)) - {- - lp_solve uses 1 as default lower bound for semi-continuous variable. - - But Gurobi Optimizer uses 0 as default lower bound for semi-continuous variable. - Here we adopt Gurobi's way. - -} -{- - Just (Nothing, ub) | v `Set.member` scvs -> - (v, (MIP.Finite 1, fromMaybe MIP.PosInf ub)) --} - Just (lb,ub) -> - (v, (fromMaybe (MIP.Finite 0) lb, fromMaybe MIP.PosInf ub)) - | v <- Set.toList vs ] - - let rowCoeffs :: Map Row (Map Column Scientific) - rowCoeffs = Map.fromListWith Map.union [(r, Map.singleton col coeff) | (col,m) <- Map.toList cols, (r,coeff) <- Map.toList m] - - let f :: Bool -> (Maybe MIP.RelOp, Row) -> [MIP.Constraint Scientific] - f _isLazy (Nothing, _row) = [] - f isLazy (Just op, r) = do - let lhs = [MIP.Term c [col] | (col,c) <- Map.toList (Map.findWithDefault Map.empty r rowCoeffs)] - ++ Map.findWithDefault [] r qterms - let rhs = Map.findWithDefault 0 r rhss - (lb,ub) = - case Map.lookup r rngs of - Nothing -> - case op of - MIP.Ge -> (MIP.Finite rhs, MIP.PosInf) - MIP.Le -> (MIP.NegInf, MIP.Finite rhs) - MIP.Eql -> (MIP.Finite rhs, MIP.Finite rhs) - Just rng -> - case op of - MIP.Ge -> (MIP.Finite rhs, MIP.Finite (rhs + abs rng)) - MIP.Le -> (MIP.Finite (rhs - abs rng), MIP.Finite rhs) - MIP.Eql -> - if rng < 0 - then (MIP.Finite (rhs + rng), MIP.Finite rhs) - else (MIP.Finite rhs, MIP.Finite (rhs + rng)) - return $ - MIP.Constraint - { MIP.constrLabel = Just $ unintern r - , MIP.constrIndicator = Map.lookup r inds - , MIP.constrIsLazy = isLazy - , MIP.constrExpr = MIP.Expr lhs - , MIP.constrLB = lb - , MIP.constrUB = ub - } - - let mip = - MIP.Problem - { MIP.name = name - , MIP.objectiveFunction = def - { MIP.objDir = objdir - , MIP.objLabel = Just (unintern objrow) - , MIP.objExpr = MIP.Expr $ [MIP.Term c [col] | (col,m) <- Map.toList cols, c <- maybeToList (Map.lookup objrow m)] ++ qobj - } - , MIP.constraints = concatMap (f False) rows ++ concatMap (f True) lazycons - , MIP.sosConstraints = sos - , MIP.userCuts = concatMap (f False) usercuts - , MIP.varType = Map.fromAscList - [ ( v - , if v `Set.member` sivs then - MIP.SemiIntegerVariable - else if v `Set.member` intvs1 && v `Set.member` scvs then - MIP.SemiIntegerVariable - else if v `Set.member` intvs1 || v `Set.member` intvs2 then - MIP.IntegerVariable - else if v `Set.member` scvs then - MIP.SemiContinuousVariable - else - MIP.ContinuousVariable - ) - | v <- Set.toAscList vs ] - , MIP.varBounds = Map.fromAscList [(v, Map.findWithDefault MIP.defaultBounds v bounds) | v <- Set.toAscList vs] - } - - return mip - -nameSection :: C e s m => m (Maybe T.Text) -nameSection = do - string "NAME" - n <- optional $ try $ do - spaces1' - ident - newline' - return n - -objSenseSection :: C e s m => m OptDir -objSenseSection = do - try $ stringLn "OBJSENSE" - spaces1' - d <- (try (stringLn "MAX") >> return OptMax) - <|> (stringLn "MIN" >> return OptMin) - return d - -objNameSection :: C e s m => m T.Text -objNameSection = do - try $ stringLn "OBJNAME" - spaces1' - name <- ident - newline' - return name - -rowsSection :: C e s m => m [(Maybe MIP.RelOp, Row)] -rowsSection = do - try $ stringLn "ROWS" - rowsBody - -userCutsSection :: C e s m => m [(Maybe MIP.RelOp, Row)] -userCutsSection = do - try $ stringLn "USERCUTS" - rowsBody - -lazyConsSection :: C e s m => m [(Maybe MIP.RelOp, Row)] -lazyConsSection = do - try $ stringLn "LAZYCONS" - rowsBody - -rowsBody :: C e s m => m [(Maybe MIP.RelOp, Row)] -rowsBody = many $ do - spaces1' - op <- msum - [ char 'N' >> return Nothing - , char 'G' >> return (Just MIP.Ge) - , char 'L' >> return (Just MIP.Le) - , char 'E' >> return (Just MIP.Eql) - ] - spaces1' - name <- row - newline' - return (op, name) - -colsSection :: forall e s m. C e s m => m (Map Column (Map Row Scientific), Set Column) -colsSection = do - try $ stringLn "COLUMNS" - body False Map.empty Set.empty - where - body :: Bool -> Map Column (Map Row Scientific) -> Set Column -> m (Map Column (Map Row Scientific), Set Column) - body isInt rs ivs = msum - [ do _ <- spaces1' - x <- ident - msum - [ do isInt' <- try intMarker - body isInt' rs ivs - , do (k,v) <- entry x - let rs' = Map.insertWith Map.union k v rs - ivs' = if isInt then Set.insert k ivs else ivs - seq rs' $ seq ivs' $ body isInt rs' ivs' - ] - , return (rs, ivs) - ] - - intMarker :: m Bool - intMarker = do - string "'MARKER'" - spaces1' - b <- (try (string "'INTORG'") >> return True) - <|> (string "'INTEND'" >> return False) - newline' - return b - - entry :: T.Text -> m (Column, Map Row Scientific) - entry x = do - let col = intern x - rv1 <- rowAndVal - opt <- optional rowAndVal - newline' - case opt of - Nothing -> return (col, rv1) - Just rv2 -> return (col, Map.union rv1 rv2) - -rowAndVal :: C e s m => m (Map Row Scientific) -rowAndVal = do - r <- row - val <- number - return $ Map.singleton r val - -rhsSection :: C e s m => m (Map Row Scientific) -rhsSection = do - try $ stringLn "RHS" - liftM Map.unions $ many entry - where - entry = do - spaces1' - _name <- ident - rv1 <- rowAndVal - opt <- optional rowAndVal - newline' - case opt of - Nothing -> return rv1 - Just rv2 -> return $ Map.union rv1 rv2 - -rangesSection :: C e s m => m (Map Row Scientific) -rangesSection = do - try $ stringLn "RANGES" - liftM Map.unions $ many entry - where - entry = do - spaces1' - _name <- ident - rv1 <- rowAndVal - opt <- optional rowAndVal - newline' - case opt of - Nothing -> return rv1 - Just rv2 -> return $ Map.union rv1 rv2 - -boundsSection :: C e s m => m [(BoundType, Column, Scientific)] -boundsSection = do - try $ stringLn "BOUNDS" - many entry - where - entry = do - spaces1' - typ <- boundType - _name <- ident - col <- column - val <- if typ `elem` [FR, BV, MI, PL] - then return 0 - else number - newline' - return (typ, col, val) - -boundType :: C e s m => m BoundType -boundType = tok $ do - msum [try (string (fromString (show k))) >> return k | k <- [minBound..maxBound]] - -sosSection :: forall e s m. C e s m => m [MIP.SOSConstraint Scientific] -sosSection = do - try $ stringLn "SOS" - many entry - where - entry = do - spaces1' - typ <- (try (string "S1") >> return MIP.S1) - <|> (string "S2" >> return MIP.S2) - spaces1' - name <- ident - newline' - xs <- many (try identAndVal) - return $ MIP.SOSConstraint{ MIP.sosLabel = Just name, MIP.sosType = typ, MIP.sosBody = xs } - - identAndVal :: m (Column, Scientific) - identAndVal = do - spaces1' - col <- column - val <- number - newline' - return (col, val) - -quadObjSection :: C e s m => m [MIP.Term Scientific] -quadObjSection = do - try $ stringLn "QUADOBJ" - many entry - where - entry = do - spaces1' - col1 <- column - col2 <- column - val <- number - newline' - return $ MIP.Term (if col1 /= col2 then val else val / 2) [col1, col2] - -qMatrixSection :: C e s m => m [MIP.Term Scientific] -qMatrixSection = do - try $ stringLn "QMATRIX" - many entry - where - entry = do - spaces1' - col1 <- column - col2 <- column - val <- number - newline' - return $ MIP.Term (val / 2) [col1, col2] - -qcMatrixSection :: C e s m => m (Row, [MIP.Term Scientific]) -qcMatrixSection = do - try $ string "QCMATRIX" - spaces1' - r <- row - newline' - xs <- many entry - return (r, xs) - where - entry = do - spaces1' - col1 <- column - col2 <- column - val <- number - newline' - return $ MIP.Term val [col1, col2] - -indicatorsSection :: C e s m => m (Map Row (Column, Scientific)) -indicatorsSection = do - try $ stringLn "INDICATORS" - liftM Map.fromList $ many entry - where - entry = do - spaces1' - string "IF" - spaces1' - r <- row - var <- column - val <- number - newline' - return (r, (var, val)) - --- --------------------------------------------------------------------------- - -type M a = Writer Builder a - -execM :: M a -> TL.Text -execM m = B.toLazyText $ execWriter m - -writeText :: T.Text -> M () -writeText s = tell $ B.fromText s - -writeChar :: Char -> M () -writeChar c = tell $ B.singleton c - --- --------------------------------------------------------------------------- - -render :: MIP.FileOptions -> MIP.Problem Scientific -> Either String TL.Text -render _ mip | not (checkAtMostQuadratic mip) = Left "Expression must be atmost quadratic" -render _ mip = Right $ execM $ render' $ nameRows mip - -render' :: MIP.Problem Scientific -> M () -render' mip = do - let probName = fromMaybe "" (MIP.name mip) - - -- NAME section - -- The name starts in column 15 in fixed formats. - writeSectionHeader $ "NAME" <> T.replicate 10 " " <> probName - - let MIP.ObjectiveFunction - { MIP.objLabel = Just objName - , MIP.objDir = dir - , MIP.objExpr = obj - } = MIP.objectiveFunction mip - - -- OBJSENSE section - -- Note: GLPK-4.48 does not support this section. - writeSectionHeader "OBJSENSE" - case dir of - OptMin -> writeFields ["MIN"] - OptMax -> writeFields ["MAX"] - -{- - -- OBJNAME section - -- Note: GLPK-4.48 does not support this section. - writeSectionHeader "OBJNAME" - writeFields [objName] --} - - let splitRange c = - case (MIP.constrLB c, MIP.constrUB c) of - (MIP.Finite x, MIP.PosInf) -> ((MIP.Ge, x), Nothing) - (MIP.NegInf, MIP.Finite x) -> ((MIP.Le, x), Nothing) - (MIP.Finite x1, MIP.Finite x2) - | x1 == x2 -> ((MIP.Eql, x1), Nothing) - | x1 < x2 -> ((MIP.Eql, x1), Just (x2 - x1)) - _ -> error "invalid constraint bound" - - let renderRows cs = do - forM_ cs $ \c -> do - let ((op,_), _) = splitRange c - let s = case op of - MIP.Le -> "L" - MIP.Ge -> "G" - MIP.Eql -> "E" - writeFields [s, fromJust $ MIP.constrLabel c] - - -- ROWS section - writeSectionHeader "ROWS" - writeFields ["N", objName] - renderRows [c | c <- MIP.constraints mip, not (MIP.constrIsLazy c)] - - -- USERCUTS section - unless (null (MIP.userCuts mip)) $ do - writeSectionHeader "USERCUTS" - renderRows (MIP.userCuts mip) - - -- LAZYCONS section - let lcs = [c | c <- MIP.constraints mip, MIP.constrIsLazy c] - unless (null lcs) $ do - writeSectionHeader "LAZYCONS" - renderRows lcs - - -- COLUMNS section - writeSectionHeader "COLUMNS" - let cols :: Map Column (Map T.Text Scientific) - cols = Map.fromListWith Map.union - [ (v, Map.singleton l d) - | (Just l, xs) <- - (Just objName, obj) : - [(MIP.constrLabel c, lhs) | c <- MIP.constraints mip ++ MIP.userCuts mip, let lhs = MIP.constrExpr c] - , MIP.Term d [v] <- MIP.terms xs - ] - f col xs = - forM_ (Map.toList xs) $ \(r, d) -> do - writeFields ["", unintern col, r, showValue d] - ivs = MIP.integerVariables mip `Set.union` MIP.semiIntegerVariables mip - forM_ (Map.toList (Map.filterWithKey (\col _ -> col `Set.notMember` ivs) cols)) $ \(col, xs) -> f col xs - unless (Set.null ivs) $ do - writeFields ["", "MARK0000", "'MARKER'", "", "'INTORG'"] - forM_ (Map.toList (Map.filterWithKey (\col _ -> col `Set.member` ivs) cols)) $ \(col, xs) -> f col xs - writeFields ["", "MARK0001", "'MARKER'", "", "'INTEND'"] - - -- RHS section - let rs = [(fromJust $ MIP.constrLabel c, rhs) | c <- MIP.constraints mip ++ MIP.userCuts mip, let ((_,rhs),_) = splitRange c, rhs /= 0] - writeSectionHeader "RHS" - forM_ rs $ \(name, val) -> do - writeFields ["", "rhs", name, showValue val] - - -- RANGES section - let rngs = [(fromJust $ MIP.constrLabel c, fromJust rng) | c <- MIP.constraints mip ++ MIP.userCuts mip, let ((_,_), rng) = splitRange c, isJust rng] - unless (null rngs) $ do - writeSectionHeader "RANGES" - forM_ rngs $ \(name, val) -> do - writeFields ["", "rhs", name, showValue val] - - -- BOUNDS section - writeSectionHeader "BOUNDS" - forM_ (Map.toList (MIP.varType mip)) $ \(col, vt) -> do - let (lb,ub) = MIP.getBounds mip col - case (lb,ub) of - (MIP.NegInf, MIP.PosInf) -> do - -- free variable (no lower or upper bound) - writeFields ["FR", "bound", unintern col] - - (MIP.Finite 0, MIP.Finite 1) | vt == MIP.IntegerVariable -> do - -- variable is binary (equal 0 or 1) - writeFields ["BV", "bound", unintern col] - - (MIP.Finite a, MIP.Finite b) | a == b -> do - -- variable is fixed at the specified value - writeFields ["FX", "bound", unintern col, showValue a] - - _ -> do - case lb of - MIP.PosInf -> error "should not happen" - MIP.NegInf -> do - -- Minus infinity - writeFields ["MI", "bound", unintern col] - MIP.Finite 0 | vt == MIP.ContinuousVariable -> return () - MIP.Finite a -> do - let t = case vt of - MIP.IntegerVariable -> "LI" -- lower bound for integer variable - _ -> "LO" -- Lower bound - writeFields [t, "bound", unintern col, showValue a] - - case ub of - MIP.NegInf -> error "should not happen" - MIP.PosInf | vt == MIP.ContinuousVariable -> return () - MIP.PosInf -> do - when (vt == MIP.SemiContinuousVariable || vt == MIP.SemiIntegerVariable) $ - error "cannot express +inf upper bound of semi-continuous or semi-integer variable" - writeFields ["PL", "bound", unintern col] -- Plus infinity - MIP.Finite a -> do - let t = case vt of - MIP.SemiContinuousVariable -> "SC" -- Upper bound for semi-continuous variable - MIP.SemiIntegerVariable -> - -- Gurobi uses "SC" while lpsolve uses "SI" for upper bound of semi-integer variable - "SC" - MIP.IntegerVariable -> "UI" -- Upper bound for integer variable - _ -> "UP" -- Upper bound - writeFields [t, "bound", unintern col, showValue a] - - -- QMATRIX section - -- Gurobiは対称行列になっていないと "qmatrix isn't symmetric" というエラーを発生させる - do let qm = Map.map (2*) $ quadMatrix obj - unless (Map.null qm) $ do - writeSectionHeader "QMATRIX" - forM_ (Map.toList qm) $ \(((v1,v2), val)) -> do - writeFields ["", unintern v1, unintern v2, showValue val] - - -- SOS section - unless (null (MIP.sosConstraints mip)) $ do - writeSectionHeader "SOS" - forM_ (MIP.sosConstraints mip) $ \sos -> do - let t = case MIP.sosType sos of - MIP.S1 -> "S1" - MIP.S2 -> "S2" - writeFields $ t : maybeToList (MIP.sosLabel sos) - forM_ (MIP.sosBody sos) $ \(var,val) -> do - writeFields ["", unintern var, showValue val] - - -- QCMATRIX section - let xs = [ (fromJust $ MIP.constrLabel c, qm) - | c <- MIP.constraints mip ++ MIP.userCuts mip - , let lhs = MIP.constrExpr c - , let qm = quadMatrix lhs - , not (Map.null qm) ] - unless (null xs) $ do - forM_ xs $ \(r, qm) -> do - -- The name starts in column 12 in fixed formats. - writeSectionHeader $ "QCMATRIX" <> T.replicate 3 " " <> r - forM_ (Map.toList qm) $ \((v1,v2), val) -> do - writeFields ["", unintern v1, unintern v2, showValue val] - - -- INDICATORS section - -- Note: Gurobi-5.6.3 does not support this section. - let ics = [c | c <- MIP.constraints mip, isJust $ MIP.constrIndicator c] - unless (null ics) $ do - writeSectionHeader "INDICATORS" - forM_ ics $ \c -> do - let Just (var,val) = MIP.constrIndicator c - writeFields ["IF", fromJust (MIP.constrLabel c), unintern var, showValue val] - - -- ENDATA section - writeSectionHeader "ENDATA" - -writeSectionHeader :: T.Text -> M () -writeSectionHeader s = writeText s >> writeChar '\n' - --- Fields start in column 2, 5, 15, 25, 40 and 50 -writeFields :: [T.Text] -> M () -writeFields xs0 = f1 xs0 >> writeChar '\n' - where - -- columns 1-4 - f1 [] = return () - f1 [x] = writeChar ' ' >> writeText x - f1 (x:xs) = do - writeChar ' ' - writeText x - let len = T.length x - when (len < 2) $ writeText $ T.replicate (2 - len) " " - writeChar ' ' - f2 xs - - -- columns 5-14 - f2 [] = return () - f2 [x] = writeText x - f2 (x:xs) = do - writeText x - let len = T.length x - when (len < 9) $ writeText $ T.replicate (9 - len) " " - writeChar ' ' - f3 xs - - -- columns 15-24 - f3 [] = return () - f3 [x] = writeText x - f3 (x:xs) = do - writeText x - let len = T.length x - when (len < 9) $ writeText $ T.replicate (9 - len) " " - writeChar ' ' - f4 xs - - -- columns 25-39 - f4 [] = return () - f4 [x] = writeText x - f4 (x:xs) = do - writeText x - let len = T.length x - when (len < 14) $ writeText $ T.replicate (14 - len) " " - writeChar ' ' - f5 xs - - -- columns 40-49 - f5 [] = return () - f5 [x] = writeText x - f5 (x:xs) = do - writeText x - let len = T.length x - when (len < 19) $ writeText $ T.replicate (19 - len) " " - writeChar ' ' - f6 xs - - -- columns 50- - f6 [] = return () - f6 [x] = writeText x - f6 _ = error "MPSFile: >6 fields (this should not happen)" - -showValue :: Scientific -> T.Text -showValue = fromString . show - -nameRows :: MIP.Problem r -> MIP.Problem r -nameRows mip - = mip - { MIP.objectiveFunction = (MIP.objectiveFunction mip){ MIP.objLabel = Just objName' } - , MIP.constraints = f (MIP.constraints mip) [T.pack $ "row" ++ show n | n <- [(1::Int)..]] - , MIP.userCuts = f (MIP.userCuts mip) [T.pack $ "usercut" ++ show n | n <- [(1::Int)..]] - , MIP.sosConstraints = g (MIP.sosConstraints mip) [T.pack $ "sos" ++ show n | n <- [(1::Int)..]] - } - where - objName = MIP.objLabel $ MIP.objectiveFunction mip - used = Set.fromList $ catMaybes $ objName : [MIP.constrLabel c | c <- MIP.constraints mip ++ MIP.userCuts mip] ++ [MIP.sosLabel c | c <- MIP.sosConstraints mip] - objName' = fromMaybe (head [name | n <- [(1::Int)..], let name = T.pack ("obj" ++ show n), name `Set.notMember` used]) objName - - f [] _ = [] - f (c:cs) (name:names) - | isJust (MIP.constrLabel c) = c : f cs (name:names) - | name `Set.notMember` used = c{ MIP.constrLabel = Just name } : f cs names - | otherwise = f (c:cs) names - f _ [] = error "should not happen" - - g [] _ = [] - g (c:cs) (name:names) - | isJust (MIP.sosLabel c) = c : g cs (name:names) - | name `Set.notMember` used = c{ MIP.sosLabel = Just name } : g cs names - | otherwise = g (c:cs) names - g _ [] = error "should not happen" - -quadMatrix :: Fractional r => MIP.Expr r -> Map (MIP.Var, MIP.Var) r -quadMatrix e = Map.fromList $ do - let m = Map.fromListWith (+) [(if v1<=v2 then (v1,v2) else (v2,v1), c) | MIP.Term c [v1,v2] <- MIP.terms e] - ((v1,v2),c) <- Map.toList m - if v1==v2 then - [((v1,v2), c)] - else - [((v1,v2), c/2), ((v2,v1), c/2)] - -checkAtMostQuadratic :: forall r. MIP.Problem r -> Bool -checkAtMostQuadratic mip = all (all f . MIP.terms) es - where - es = MIP.objExpr (MIP.objectiveFunction mip) : - [lhs | c <- MIP.constraints mip ++ MIP.userCuts mip, let lhs = MIP.constrExpr c] - f :: MIP.Term r -> Bool - f (MIP.Term _ [_]) = True - f (MIP.Term _ [_,_]) = True - f _ = False - --- --------------------------------------------------------------------------- diff --git a/src/ToySolver/Data/MIP/Solution/CBC.hs b/src/ToySolver/Data/MIP/Solution/CBC.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solution/CBC.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module ToySolver.Data.MIP.Solution.CBC - ( Solution (..) - , parse - , readFile - ) where - -import Prelude hiding (readFile, writeFile) -import Control.Applicative -import Control.Monad.Except -import Data.Interned (intern) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Scientific (Scientific) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO -import ToySolver.Data.MIP (Solution) -import qualified ToySolver.Data.MIP as MIP - -parse :: TL.Text -> MIP.Solution Scientific -parse t = - case parse' $ TL.lines t of - Left e -> error e - Right x -> x - -parse' :: [TL.Text] -> Either String (MIP.Solution Scientific) -parse' (l1:ls) = do - (status, obj) <- - case TL.break ('-'==) l1 of - (s1,s2) -> - case TL.stripPrefix "- objective value " s2 of - Nothing -> throwError "fail to parse header" - Just s3 -> do - let s1' = TL.toStrict (TL.strip s1) - return - ( case Map.lookup s1' statusTable of - Just st -> st - Nothing -> - if T.isPrefixOf "Stopped on " s1' - then MIP.StatusUnknown - else MIP.StatusUnknown - , read (TL.unpack s3) - ) - let f :: [(MIP.Var, Scientific)] -> TL.Text -> Either String [(MIP.Var, Scientific)] - f vs t = - case TL.words t of - ("**":_no:var:val:_) -> return $ (intern (TL.toStrict var), read (TL.unpack val)) : vs - (_no:var:val:_) -> return $ (intern (TL.toStrict var), read (TL.unpack val)) : vs - [] -> return $ vs - _ -> throwError ("ToySolver.Data.MIP.Solution.CBC: invalid line " ++ show t) - vs <- foldM f [] ls - return $ - MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = Just obj - , MIP.solVariables = Map.fromList vs - } -parse' _ = throwError "must have >=1 lines" - -statusTable :: Map T.Text MIP.Status -statusTable = Map.fromList - [ ("Optimal", MIP.StatusOptimal) - , ("Unbounded", MIP.StatusInfeasibleOrUnbounded) - , ("Integer infeasible", MIP.StatusInfeasible) - , ("Infeasible", MIP.StatusInfeasible) - ] - -readFile :: FilePath -> IO (MIP.Solution Scientific) -readFile fname = parse <$> TLIO.readFile fname diff --git a/src/ToySolver/Data/MIP/Solution/CPLEX.hs b/src/ToySolver/Data/MIP/Solution/CPLEX.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solution/CPLEX.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -module ToySolver.Data.MIP.Solution.CPLEX - ( Solution (..) - , parse - , readFile - ) where - -import Prelude hiding (readFile) -import Control.Applicative -import Data.Default.Class -import Data.Interned -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Maybe -import Data.Scientific (Scientific) -import Data.String -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Text.XML as XML -import Text.XML.Cursor -import ToySolver.Data.MIP (Solution) -import qualified ToySolver.Data.MIP.Base as MIP - -parseDoc :: XML.Document -> MIP.Solution Scientific -parseDoc doc = - MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = obj - , MIP.solVariables = Map.fromList vs - } - where - obj :: Maybe Scientific - obj = listToMaybe - $ fromDocument doc - $| element "CPLEXSolution" - &/ element "header" - >=> attribute "objectiveValue" - &| (read . T.unpack) - - status :: MIP.Status - status = head - $ fromDocument doc - $| element "CPLEXSolution" - &/ element "header" - >=> attribute "solutionStatusValue" - &| (flip (IntMap.findWithDefault MIP.StatusUnknown) table . read . T.unpack) - - f :: Cursor -> [(MIP.Var, Scientific)] - f x - | XML.NodeElement e <- node x = maybeToList $ do - let m = XML.elementAttributes e - name <- Map.lookup "name" m - value <- read . T.unpack <$> Map.lookup "value" m - return (intern name, value) - | otherwise = [] - vs = fromDocument doc - $| element "CPLEXSolution" - &/ element "variables" - &/ element "variable" - >=> f - --- https://www.ibm.com/support/knowledgecenter/en/SSSA5P_12.7.0/ilog.odms.cplex.help/refcallablelibrary/macros/Solution_status_codes.html -table :: IntMap MIP.Status -table = IntMap.fromList - [ (1, MIP.StatusOptimal) -- CPX_STAT_OPTIMAL - , (2, MIP.StatusUnbounded) -- CPX_STAT_UNBOUNDED - , (3, MIP.StatusInfeasible) -- CPX_STAT_INFEASIBLE - , (4, MIP.StatusInfeasibleOrUnbounded) -- CPX_STAT_INForUNBD - , (5, MIP.StatusOptimal) -- CPX_STAT_OPTIMAL_INFEAS -{- - , (6, ) -- CPX_STAT_NUM_BEST - , (10, ) -- CPX_STAT_ABORT_IT_LIM - , (11, ) -- CPX_STAT_ABORT_TIME_LIM - , (12, ) -- CPX_STAT_ABORT_OBJ_LIM - , (13, ) -- CPX_STAT_ABORT_USER - , (14, ) -- CPX_STAT_FEASIBLE_RELAXED_SUM - , (15, ) -- CPX_STAT_OPTIMAL_RELAXED_SUM - , (16, ) -- CPX_STAT_FEASIBLE_RELAXED_INF - , (17, ) -- CPX_STAT_OPTIMAL_RELAXED_INF - , (18, ) -- CPX_STAT_FEASIBLE_RELAXED_QUAD - , (19, ) -- CPX_STAT_OPTIMAL_RELAXED_QUAD - , (20, ) -- CPX_STAT_OPTIMAL_FACE_UNBOUNDED - , (21, ) -- CPX_STAT_ABORT_PRIM_OBJ_LIM - , (22, ) -- CPX_STAT_ABORT_DUAL_OBJ_LIM - , (23, ) -- CPX_STAT_FEASIBLE --} - , (24, MIP.StatusFeasible) -- CPX_STAT_FIRSTORDER -{- - , (25, ) -- CPX_STAT_ABORT_DETTIME_LIM - , (30, ) -- CPX_STAT_CONFLICT_FEASIBLE - , (31, ) -- CPX_STAT_CONFLICT_MINIMAL - , (32, ) -- CPX_STAT_CONFLICT_ABORT_CONTRADICTION - , (33, ) -- CPX_STAT_CONFLICT_ABORT_TIME_LIM - , (34, ) -- CPX_STAT_CONFLICT_ABORT_IT_LIM - , (35, ) -- CPX_STAT_CONFLICT_ABORT_NODE_LIM - , (36, ) -- CPX_STAT_CONFLICT_ABORT_OBJ_LIM - , (37, ) -- CPX_STAT_CONFLICT_ABORT_MEM_LIM - , (38, ) -- CPX_STAT_CONFLICT_ABORT_USER - , (39, ) -- CPX_STAT_CONFLICT_ABORT_DETTIME_LIM --} - , (40, MIP.StatusInfeasibleOrUnbounded) -- CPX_STAT_BENDERS_MASTER_UNBOUNDED --- , (41, ) -- CPX_STAT_BENDERS_NUM_BEST - , (101, MIP.StatusOptimal) -- CPXMIP_OPTIMAL - , (102, MIP.StatusOptimal) -- CPXMIP_OPTIMAL_TOL - , (103, MIP.StatusInfeasible) -- CPXMIP_INFEASIBLE --- , (104, ) -- CPXMIP_SOL_LIM - , (105, MIP.StatusFeasible) -- CPXMIP_NODE_LIM_FEAS --- , (106, ) -- CPXMIP_NODE_LIM_INFEAS - , (107, MIP.StatusFeasible) -- CPXMIP_TIME_LIM_FEAS --- , (108, ) -- CPXMIP_TIME_LIM_INFEAS - , (109, MIP.StatusFeasible) -- CPXMIP_FAIL_FEAS --- , (110, ) -- CPXMIP_FAIL_INFEAS - , (111, MIP.StatusFeasible) -- CPXMIP_MEM_LIM_FEAS --- , (112, ) -- CPXMIP_MEM_LIM_INFEAS - , (113, MIP.StatusFeasible) -- CPXMIP_ABORT_FEAS --- , (114, ) -- CPXMIP_ABORT_INFEAS - , (115, MIP.StatusOptimal) -- CPXMIP_OPTIMAL_INFEAS - , (116, MIP.StatusFeasible) -- CPXMIP_FAIL_FEAS_NO_TREE --- , (117, ) -- CPXMIP_FAIL_INFEAS_NO_TREE - , (118, MIP.StatusUnbounded) -- CPXMIP_UNBOUNDED - , (119, MIP.StatusInfeasibleOrUnbounded) -- CPXMIP_INForUNBD -{- - , (120, ) -- CPXMIP_FEASIBLE_RELAXED_SUM - , (121, ) -- CPXMIP_OPTIMAL_RELAXED_SUM - , (122, ) -- CPXMIP_FEASIBLE_RELAXED_INF - , (123, ) -- CPXMIP_OPTIMAL_RELAXED_INF - , (124, ) -- CPXMIP_FEASIBLE_RELAXED_QUAD - , (125, ) -- CPXMIP_OPTIMAL_RELAXED_QUAD - , (126, ) -- CPXMIP_ABORT_RELAXED --} - , (127, MIP.StatusFeasible) -- CPXMIP_FEASIBLE --- , (128, ) -- CPXMIP_POPULATESOL_LIM - , (129, MIP.StatusOptimal) -- CPXMIP_OPTIMAL_POPULATED - , (130, MIP.StatusOptimal) -- CPXMIP_OPTIMAL_POPULATED_TOL - , (131, MIP.StatusFeasible) -- CPXMIP_DETTIME_LIM_FEAS --- , (132, ) -- CPXMIP_DETTIME_LIM_INFEAS - , (133, MIP.StatusInfeasibleOrUnbounded) -- CPXMIP_ABORT_RELAXATION_UNBOUNDED - ] - -parse :: TL.Text -> MIP.Solution Scientific -parse t = parseDoc $ XML.parseText_ def t - -readFile :: FilePath -> IO (MIP.Solution Scientific) -readFile fname = parseDoc <$> XML.readFile def (fromString fname) - diff --git a/src/ToySolver/Data/MIP/Solution/GLPK.hs b/src/ToySolver/Data/MIP/Solution/GLPK.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solution/GLPK.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module ToySolver.Data.MIP.Solution.GLPK - ( Solution (..) - , parse - , readFile - ) where - -import Prelude hiding (readFile, writeFile) -import Control.Applicative -import Data.Interned (intern) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Scientific (Scientific) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO -import ToySolver.Data.MIP (Solution) -import qualified ToySolver.Data.MIP as MIP - -parse :: TL.Text -> MIP.Solution Scientific -parse t = parse' $ TL.lines t - -parse' :: [TL.Text] -> MIP.Solution Scientific -parse' ls = - case parseHeaders ls of - (headers, ls2) -> - case parseColumns (skipRows ls2) of - (vs, _) -> - let status = Map.findWithDefault MIP.StatusUnknown (headers Map.! "Status") statusTable - objstr = headers Map.! "Objective" - objstr2 = - case T.findIndex ('='==) objstr of - Nothing -> objstr - Just idx -> T.drop (idx+1) objstr - obj = case reads (T.unpack objstr2) of - [] -> error "parse error" - (r,_):_ -> r - in MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = Just obj - , MIP.solVariables = vs - } - -parseHeaders :: [TL.Text] -> (Map T.Text T.Text, [TL.Text]) -parseHeaders = f Map.empty - where - f _ [] = error "parse error" - f ret ("":ls) = (ret, ls) - f ret (l:ls) = - case TL.break (':'==) l of - (_, "") -> error "parse error" - (name, val) -> f (Map.insert (TL.toStrict name) (TL.toStrict (TL.strip (TL.tail val))) ret) ls - -skipRows :: [TL.Text] -> [TL.Text] -skipRows [] = error "parse error" -skipRows ("":ls) = ls -skipRows (_:ls) = skipRows ls - -parseColumns :: [TL.Text] -> (Map MIP.Var Scientific, [TL.Text]) -parseColumns (l1:l2:ls) - | l1 == " No. Column name Activity Lower bound Upper bound" - , l2 == "------ ------------ ------------- ------------- -------------" - = f [] ls - where - f :: [(MIP.Var, Scientific)] -> [TL.Text] -> (Map MIP.Var Scientific, [TL.Text]) - f _ [] = error "parse error" - f ret ("":ls2) = (Map.fromList ret, ls2) - f ret (l:ls2) = - case ws of - (_no : col : "*" : activity : _) -> f ((intern (TL.toStrict col), read (TL.unpack activity)) : ret) ls3 - (_no : col : activity : _) -> f ((intern (TL.toStrict col), read (TL.unpack activity)) : ret) ls3 - _ -> error "parse error" - where - (ws,ls3) = - case TL.words l of - ws1@(_:_:_:_) -> (ws1, ls2) - ws1@[_,_] -> (ws1 ++ TL.words (head ls2), tail ls2) - _ -> error "parse error" -parseColumns _ = error "parse error" - -statusTable :: Map T.Text MIP.Status -statusTable = Map.fromList - [ ("INTEGER OPTIMAL", MIP.StatusOptimal) - , ("INTEGER NON-OPTIMAL", MIP.StatusUnknown) - , ("INTEGER EMPTY", MIP.StatusInfeasible) - ] - -readFile :: FilePath -> IO (MIP.Solution Scientific) -readFile fname = parse <$> TLIO.readFile fname diff --git a/src/ToySolver/Data/MIP/Solution/Gurobi.hs b/src/ToySolver/Data/MIP/Solution/Gurobi.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solution/Gurobi.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module ToySolver.Data.MIP.Solution.Gurobi - ( Solution (..) - , render - , writeFile - , parse - , readFile - ) where - -import Prelude hiding (readFile, writeFile) -import Control.Applicative -import Data.Default.Class -import Data.Interned (intern, unintern) -import Data.List (foldl') -import qualified Data.Map as Map -import Data.Monoid -import Data.Scientific (Scientific) -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.Builder.Scientific as B -import qualified Data.Text.Lazy.IO as TLIO -import ToySolver.Data.MIP (Solution) -import qualified ToySolver.Data.MIP as MIP - -render :: MIP.Solution Scientific -> TL.Text -render sol = B.toLazyText $ ls1 <> mconcat ls2 - where - ls1 = case MIP.solObjectiveValue sol of - Nothing -> mempty - Just val -> "# Objective value = " <> B.scientificBuilder val <> B.singleton '\n' - ls2 = [ B.fromText (unintern name) <> B.singleton ' ' <> B.scientificBuilder val <> B.singleton '\n' - | (name,val) <- Map.toList (MIP.solVariables sol) - ] - -writeFile :: FilePath -> MIP.Solution Scientific -> IO () -writeFile fname sol = do - TLIO.writeFile fname (render sol) - -parse :: TL.Text -> MIP.Solution Scientific -parse t = - case foldl' f (Nothing,[]) $ TL.lines t of - (obj, vs) -> - def{ MIP.solStatus = MIP.StatusFeasible - , MIP.solObjectiveValue = obj - , MIP.solVariables = Map.fromList vs - } - where - f :: (Maybe Scientific, [(MIP.Var, Scientific)]) -> TL.Text -> (Maybe Scientific, [(MIP.Var, Scientific)]) - f (obj,vs) l - | Just l2 <- TL.stripPrefix "# " l - , Just l3 <- TL.stripPrefix "objective value = " (TL.toLower l2) - , (r:_) <- [r | (r,[]) <- reads (TL.unpack l3)] = - (Just r, vs) - | otherwise = - case TL.words (TL.takeWhile (/= '#') l) of - [w1, w2] -> (obj, (intern (TL.toStrict w1), read (TL.unpack w2)) : vs) - [] -> (obj, vs) - _ -> error ("ToySolver.Data.MIP.Solution.Gurobi: invalid line " ++ show l) - -readFile :: FilePath -> IO (MIP.Solution Scientific) -readFile fname = parse <$> TLIO.readFile fname diff --git a/src/ToySolver/Data/MIP/Solution/SCIP.hs b/src/ToySolver/Data/MIP/Solution/SCIP.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solution/SCIP.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings #-} -module ToySolver.Data.MIP.Solution.SCIP - ( Solution (..) - , parse - , readFile - ) where - -import Prelude hiding (readFile, writeFile) -import Control.Applicative -import Control.Monad.Except -import Data.Interned (intern) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Scientific (Scientific) -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.IO as TLIO -import ToySolver.Data.MIP (Solution) -import qualified ToySolver.Data.MIP as MIP - -parse :: TL.Text -> MIP.Solution Scientific -parse t = - case parse' $ TL.lines t of - Left e -> error e - Right x -> x - -parse' :: [TL.Text] -> Either String (MIP.Solution Scientific) -parse' (t1:t2:ts) = do - status <- - case TL.stripPrefix "solution status:" t1 of - Nothing -> throwError "first line must start with \"solution status:\"" - Just s -> return $ Map.findWithDefault MIP.StatusUnknown (TL.toStrict $ TL.strip s) statusTable - if t2 == "no solution available" then do - return $ - MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = Nothing - , MIP.solVariables = Map.empty - } - else do - obj <- - case TL.stripPrefix "objective value:" t2 of - Nothing -> throwError "second line must start with \"objective value:\"" - Just s -> return $ read $ TL.unpack $ TL.strip s - let f :: [(MIP.Var, Scientific)] -> TL.Text -> Either String [(MIP.Var, Scientific)] - f vs t = - case TL.words t of - (w1:w2:_) -> return $ (intern (TL.toStrict w1), read (TL.unpack w2)) : vs - [] -> return $ vs - _ -> throwError ("ToySolver.Data.MIP.Solution.SCIP: invalid line " ++ show t) - vs <- foldM f [] ts - return $ - MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = Just obj - , MIP.solVariables = Map.fromList vs - } -parse' _ = throwError "must have >=2 lines" - -statusTable :: Map T.Text MIP.Status -statusTable = Map.fromList - [ ("user interrupt", MIP.StatusUnknown) - , ("node limit reached", MIP.StatusUnknown) - , ("total node limit reached", MIP.StatusUnknown) - , ("stall node limit reached", MIP.StatusUnknown) - , ("time limit reached", MIP.StatusUnknown) - , ("memory limit reached", MIP.StatusUnknown) - , ("gap limit reached", MIP.StatusUnknown) - , ("solution limit reached", MIP.StatusUnknown) - , ("solution improvement limit reached", MIP.StatusUnknown) - , ("optimal solution found", MIP.StatusOptimal) - , ("infeasible", MIP.StatusInfeasible) - , ("unbounded", MIP.StatusUnbounded) - , ("infeasible or unbounded", MIP.StatusInfeasibleOrUnbounded) - -- , ("unknown", ) - ] - -readFile :: FilePath -> IO (MIP.Solution Scientific) -readFile fname = parse <$> TLIO.readFile fname diff --git a/src/ToySolver/Data/MIP/Solver.hs b/src/ToySolver/Data/MIP/Solver.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -module ToySolver.Data.MIP.Solver - ( module ToySolver.Data.MIP.Solver.Base - , module ToySolver.Data.MIP.Solver.CBC - , module ToySolver.Data.MIP.Solver.CPLEX - , module ToySolver.Data.MIP.Solver.Glpsol - , module ToySolver.Data.MIP.Solver.GurobiCl - , module ToySolver.Data.MIP.Solver.LPSolve - , module ToySolver.Data.MIP.Solver.SCIP - ) where - -import ToySolver.Data.MIP.Solver.Base -import ToySolver.Data.MIP.Solver.CBC -import ToySolver.Data.MIP.Solver.CPLEX -import ToySolver.Data.MIP.Solver.Glpsol -import ToySolver.Data.MIP.Solver.GurobiCl -import ToySolver.Data.MIP.Solver.LPSolve -import ToySolver.Data.MIP.Solver.SCIP diff --git a/src/ToySolver/Data/MIP/Solver/Base.hs b/src/ToySolver/Data/MIP/Solver/Base.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/Base.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FunctionalDependencies #-} -module ToySolver.Data.MIP.Solver.Base - ( SolveOptions (..) - , Default (..) - , IsSolver (..) - ) where - -import Data.Default.Class -import Data.Scientific (Scientific) -import ToySolver.Data.MIP.Base as MIP - -data SolveOptions - = SolveOptions - { solveTimeLimit :: Maybe Double - -- ^ time limit in seconds - , solveLogger :: String -> IO () - -- ^ invoked when a solver output a line - , solveErrorLogger :: String -> IO () - -- ^ invoked when a solver output a line to stderr - } - -instance Default SolveOptions where - def = - SolveOptions - { solveTimeLimit = Nothing - , solveLogger = const $ return () - , solveErrorLogger = const $ return () - } - -class Monad m => IsSolver s m | s -> m where - solve :: s -> SolveOptions -> MIP.Problem Scientific -> m (MIP.Solution Scientific) diff --git a/src/ToySolver/Data/MIP/Solver/CBC.hs b/src/ToySolver/Data/MIP/Solver/CBC.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/CBC.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.CBC - ( CBC (..) - , cbc - ) where - -import Data.Default.Class -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.Base as MIP -import qualified ToySolver.Data.MIP.LPFile as LPFile -import ToySolver.Data.MIP.Solver.Base -import qualified ToySolver.Data.MIP.Solution.CBC as CBCSol -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data CBC - = CBC - { cbcPath :: String - } - -instance Default CBC where - def = cbc - -cbc :: CBC -cbc = CBC "cbc" - -instance IsSolver CBC IO where - solve solver opt prob = do - case LPFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "cbc.lp" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - withSystemTempFile "cbc.sol" $ \fname2 h2 -> do - hClose h2 - let args = [fname1] - ++ (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["sec", show sec]) - ++ ["solve", "solu", fname2] - onGetLine = solveLogger opt - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (cbcPath solver) args "" onGetLine onGetErrorLine - case exitcode of - ExitFailure n -> ioError $ userError $ "exit with " ++ show n - ExitSuccess -> do - sol <- CBCSol.readFile fname2 - if MIP.objDir (MIP.objectiveFunction prob) == MIP.OptMax then - return $ sol{ MIP.solObjectiveValue = fmap negate (MIP.solObjectiveValue sol) } - else - return sol diff --git a/src/ToySolver/Data/MIP/Solver/CPLEX.hs b/src/ToySolver/Data/MIP/Solver/CPLEX.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/CPLEX.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.CPLEX - ( CPLEX (..) - , cplex - ) where - -import Control.Monad -import Data.Default.Class -import Data.IORef -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.Base as MIP -import qualified ToySolver.Data.MIP.LPFile as LPFile -import ToySolver.Data.MIP.Solver.Base -import qualified ToySolver.Data.MIP.Solution.CPLEX as CPLEXSol -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data CPLEX - = CPLEX - { cplexPath :: String - } - -instance Default CPLEX where - def = cplex - -cplex :: CPLEX -cplex = CPLEX "cplex" - -instance IsSolver CPLEX IO where - solve solver opt prob = do - case LPFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "cplex.lp" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - withSystemTempFile "cplex.sol" $ \fname2 h2 -> do - hClose h2 - isInfeasibleRef <- newIORef False - let args = [] - input = unlines $ - (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["set timelimit ", show sec]) ++ - [ "read " ++ show fname1 - , "optimize" - , "write " ++ show fname2 - , "y" - , "quit" - ] - onGetLine s = do - when (s == "MIP - Integer infeasible.") $ do - writeIORef isInfeasibleRef True - solveLogger opt s - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (cplexPath solver) args input onGetLine onGetErrorLine - case exitcode of - ExitFailure n -> ioError $ userError $ "exit with " ++ show n - ExitSuccess -> do - size <- withFile fname2 ReadMode $ hFileSize - if size == 0 then do - isInfeasible <- readIORef isInfeasibleRef - if isInfeasible then - return def{ MIP.solStatus = MIP.StatusInfeasible } - else - return def - else - CPLEXSol.readFile fname2 diff --git a/src/ToySolver/Data/MIP/Solver/Glpsol.hs b/src/ToySolver/Data/MIP/Solver/Glpsol.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/Glpsol.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.Glpsol - ( Glpsol (..) - , glpsol - ) where - -import Algebra.PartialOrd -import Data.Default.Class -import Data.IORef -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.Base as MIP -import qualified ToySolver.Data.MIP.LPFile as LPFile -import ToySolver.Data.MIP.Solver.Base -import qualified ToySolver.Data.MIP.Solution.GLPK as GLPKSol -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data Glpsol - = Glpsol - { glpsolPath :: String - } - -instance Default Glpsol where - def = glpsol - -glpsol :: Glpsol -glpsol = Glpsol "glpsol" - -instance IsSolver Glpsol IO where - solve solver opt prob = do - case LPFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "glpsol.lp" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - withSystemTempFile "glpsol.sol" $ \fname2 h2 -> do - hClose h2 - isUnboundedRef <- newIORef False - isInfeasibleRef <- newIORef False - let args = ["--lp", fname1, "-o", fname2] ++ - (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["--tmlim", show (max 1 (floor sec) :: Int)]) - onGetLine s = do - case s of - "LP HAS UNBOUNDED PRIMAL SOLUTION" -> - writeIORef isUnboundedRef True - "PROBLEM HAS UNBOUNDED SOLUTION" -> - writeIORef isUnboundedRef True - "PROBLEM HAS NO PRIMAL FEASIBLE SOLUTION" -> - writeIORef isInfeasibleRef True - _ -> return () - solveLogger opt s - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (glpsolPath solver) args "" onGetLine onGetErrorLine - case exitcode of - ExitFailure n -> ioError $ userError $ "exit with " ++ show n - ExitSuccess -> do - sol <- GLPKSol.readFile fname2 - isUnbounded <- readIORef isUnboundedRef - isInfeasible <- readIORef isInfeasibleRef - if isUnbounded && MIP.solStatus sol `leq` MIP.StatusInfeasibleOrUnbounded then - return $ sol{ MIP.solStatus = MIP.StatusInfeasibleOrUnbounded } - else if isInfeasible && MIP.solStatus sol `leq` MIP.StatusInfeasible then - return $ sol{ MIP.solStatus = MIP.StatusInfeasible } - else - return sol diff --git a/src/ToySolver/Data/MIP/Solver/GurobiCl.hs b/src/ToySolver/Data/MIP/Solver/GurobiCl.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/GurobiCl.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.GurobiCl - ( GurobiCl (..) - , gurobiCl - ) where - -import Data.Default.Class -import Data.IORef -import Data.List (isPrefixOf) -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.Base as MIP -import qualified ToySolver.Data.MIP.LPFile as LPFile -import ToySolver.Data.MIP.Solver.Base -import qualified ToySolver.Data.MIP.Solution.Gurobi as GurobiSol -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data GurobiCl - = GurobiCl - { gurobiClPath :: String - } - -instance Default GurobiCl where - def = gurobiCl - -gurobiCl :: GurobiCl -gurobiCl = GurobiCl "gurobi_cl" - -instance IsSolver GurobiCl IO where - solve solver opt prob = do - case LPFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "gurobi.lp" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - withSystemTempFile "gurobi.sol" $ \fname2 h2 -> do - hClose h2 - statusRef <- newIORef MIP.StatusUnknown - let args = ["ResultFile=" ++ fname2] - ++ (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["TimeLimit=" ++ show sec]) - ++ [fname1] - onGetLine s = do - case s of - -- "Time limit reached" -> writeIORef statusRef MIP.StatusUnknown - "Model is unbounded" -> writeIORef statusRef MIP.StatusUnbounded - "Model is infeasible" -> writeIORef statusRef MIP.StatusInfeasible - "Model is infeasible or unbounded" -> writeIORef statusRef MIP.StatusInfeasibleOrUnbounded - _ | isPrefixOf "Optimal solution found" s -> writeIORef statusRef MIP.StatusOptimal - _ -> return () - solveLogger opt s - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (gurobiClPath solver) args "" onGetLine onGetErrorLine - case exitcode of - ExitFailure n -> ioError $ userError $ "exit with " ++ show n - ExitSuccess -> do - status <- readIORef statusRef - sol <- GurobiSol.readFile fname2 - return $ sol{ MIP.solStatus = status } diff --git a/src/ToySolver/Data/MIP/Solver/LPSolve.hs b/src/ToySolver/Data/MIP/Solver/LPSolve.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/LPSolve.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.LPSolve - ( LPSolve (..) - , lpSolve - ) where - -import Control.Monad -import Data.Default.Class -import Data.IORef -import Data.List (stripPrefix) -import qualified Data.Map as Map -import Data.String -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.Base as MIP -import qualified ToySolver.Data.MIP.MPSFile as MPSFile -import ToySolver.Data.MIP.Solver.Base -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data LPSolve - = LPSolve - { lpSolvePath :: String - } - -instance Default LPSolve where - def = lpSolve - -lpSolve :: LPSolve -lpSolve = LPSolve "lp_solve" - -instance IsSolver LPSolve IO where - solve solver opt prob = do - case MPSFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "lp_solve.mps" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - objRef <- newIORef Nothing - solRef <- newIORef [] - flagRef <- newIORef False - let args = (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["-timeout", show sec]) - ++ ["-fmps", fname1] - onGetLine s = do - case s of - "Actual values of the variables:" -> writeIORef flagRef True - _ | Just v <- stripPrefix "Value of objective function: " s -> do - writeIORef objRef (Just (read v)) - _ -> do - flag <- readIORef flagRef - when flag $ do - case words s of - [var,val] -> modifyIORef solRef ((fromString var, read val) :) - _ -> return () - return () - solveLogger opt s - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (lpSolvePath solver) args "" onGetLine onGetErrorLine - status <- - case exitcode of - ExitSuccess -> return MIP.StatusOptimal - ExitFailure (-2) -> return MIP.StatusUnknown -- NOMEMORY - ExitFailure 1 -> return MIP.StatusFeasible -- SUBOPTIMAL - ExitFailure 2 -> return MIP.StatusInfeasible -- INFEASIBLE - ExitFailure 3 -> return MIP.StatusInfeasibleOrUnbounded -- UNBOUNDED - ExitFailure 4 -> return MIP.StatusUnknown -- DEGENERATE - ExitFailure 5 -> return MIP.StatusUnknown -- NUMFAILURE - ExitFailure 6 -> return MIP.StatusUnknown -- USERABORT - ExitFailure 7 -> return MIP.StatusUnknown -- TIMEOUT - ExitFailure 9 -> return MIP.StatusOptimal -- PRESOLVED - ExitFailure 25 -> return MIP.StatusUnknown -- NUMFAILURE - ExitFailure n -> ioError $ userError $ "unknown exit code: " ++ show n - obj <- readIORef objRef - sol <- readIORef solRef - return $ - MIP.Solution - { MIP.solStatus = status - , MIP.solObjectiveValue = obj - , MIP.solVariables = Map.fromList sol - } diff --git a/src/ToySolver/Data/MIP/Solver/SCIP.hs b/src/ToySolver/Data/MIP/Solver/SCIP.hs deleted file mode 100644 --- a/src/ToySolver/Data/MIP/Solver/SCIP.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module ToySolver.Data.MIP.Solver.SCIP - ( SCIP (..) - , scip - ) where - -import Data.Default.Class -import qualified Data.Text.Lazy.IO as TLIO -import System.Exit -import System.IO -import System.IO.Temp -import qualified ToySolver.Data.MIP.LPFile as LPFile -import ToySolver.Data.MIP.Solver.Base -import qualified ToySolver.Data.MIP.Solution.SCIP as ScipSol -import ToySolver.Internal.ProcessUtil (runProcessWithOutputCallback) - -data SCIP - = SCIP - { scipPath :: String - } - -instance Default SCIP where - def = scip - -scip :: SCIP -scip = SCIP "scip" - -instance IsSolver SCIP IO where - solve solver opt prob = do - case LPFile.render def prob of - Left err -> ioError $ userError err - Right lp -> do - withSystemTempFile "scip.lp" $ \fname1 h1 -> do - TLIO.hPutStr h1 lp - hClose h1 - withSystemTempFile "scip.sol" $ \fname2 h2 -> do - hClose h2 - let args = [ "-c", "read " ++ show fname1 ] - ++ (case solveTimeLimit opt of - Nothing -> [] - Just sec -> ["-c", "set limits time " ++ show sec]) - ++ [ "-c", "optimize" - , "-c", "write solution " ++ show fname2 - , "-c", "quit" - ] - onGetLine = solveLogger opt - onGetErrorLine = solveErrorLogger opt - exitcode <- runProcessWithOutputCallback (scipPath solver) args "" onGetLine onGetErrorLine - case exitcode of - ExitFailure n -> ioError $ userError $ "exit with " ++ show n - ExitSuccess -> ScipSol.readFile fname2 diff --git a/src/ToySolver/Data/OrdRel.hs b/src/ToySolver/Data/OrdRel.hs --- a/src/ToySolver/Data/OrdRel.hs +++ b/src/ToySolver/Data/OrdRel.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.OrdRel -- Copyright : (c) Masahiro Sakai 2011 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances) +-- Portability : non-portable -- -- Ordering relations --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.OrdRel ( @@ -47,7 +51,7 @@ -- | flipping relational operator -- -- @rel (flipOp op) a b@ is equivalent to @rel op b a@ -flipOp :: RelOp -> RelOp +flipOp :: RelOp -> RelOp flipOp Le = Ge flipOp Ge = Le flipOp Lt = Gt diff --git a/src/ToySolver/Data/Polyhedron.hs b/src/ToySolver/Data/Polyhedron.hs --- a/src/ToySolver/Data/Polyhedron.hs +++ b/src/ToySolver/Data/Polyhedron.hs @@ -3,13 +3,13 @@ -- Module : ToySolver.Data.Polyhedron -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Affine subspaces that are characterized by a set of linear (in)equalities. --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.Polyhedron ( Polyhedron @@ -83,7 +83,7 @@ empty :: Polyhedron empty = Empty --- | intersection of +-- | intersection of intersection :: Polyhedron -> Polyhedron -> Polyhedron intersection (Polyhedron m1) (Polyhedron m2) = normalize $ Polyhedron (Map.unionWith Interval.intersection m1 m2) @@ -92,7 +92,7 @@ -- | Create a set of 'Polyhedron's that are characterized by a given -- set of linear (in)equalities. fromConstraints :: [AtomR] -> [Polyhedron] -fromConstraints cs = +fromConstraints cs = map (foldl' intersection univ) $ transpose $ map fromAtom cs fromAtom :: AtomR -> [Polyhedron] diff --git a/src/ToySolver/Data/Polynomial.hs b/src/ToySolver/Data/Polynomial.hs --- a/src/ToySolver/Data/Polynomial.hs +++ b/src/ToySolver/Data/Polynomial.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Data.Polynomial -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -18,7 +18,7 @@ -- * Polynomial class for Ruby -- -- * constructive-algebra package --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.Polynomial ( diff --git a/src/ToySolver/Data/Polynomial/Base.hs b/src/ToySolver/Data/Polynomial/Base.hs --- a/src/ToySolver/Data/Polynomial/Base.hs +++ b/src/ToySolver/Data/Polynomial/Base.hs @@ -1,14 +1,22 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, BangPatterns, DeriveDataTypeable, CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Base -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies, BangPatterns, DeriveDataTypeable, CPP) +-- Portability : non-portable -- -- Polynomials -- @@ -19,7 +27,7 @@ -- * Polynomial class for Ruby -- -- * constructive-algebra package --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.Polynomial.Base ( @@ -132,7 +140,9 @@ import Data.Function import Data.Hashable import Data.List +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Numbers.Primes (primeFactors) import Data.Ratio import Data.String (IsString (..)) @@ -312,7 +322,7 @@ class ContPP k where type PPCoeff k - -- | Content of a polynomial + -- | Content of a polynomial cont :: (Ord v) => Polynomial k v -> k -- constructive-algebra-0.3.0 では cont 0 は error になる @@ -569,7 +579,7 @@ instance (PrettyCoeff a, Integral a) => PrettyCoeff (Ratio a) where pPrintCoeff lv p r | denominator r == 1 = pPrintCoeff lv p (numerator r) - | otherwise = + | otherwise = maybeParens (p > ratPrec) $ pPrintCoeff lv (ratPrec+1) (numerator r) <> PP.char '/' <> @@ -881,7 +891,7 @@ EQ -> compare n1 n2 `mappend` go xs1 xs2 -- | Reverse lexicographic order. --- +-- -- Note that revlex is /NOT/ a monomial order. revlex :: Ord v => Monomial v -> Monomial v -> Ordering revlex = go `on` (Map.toDescList . mindicesMap) @@ -903,34 +913,3 @@ -- | Graded reverse lexicographic order grevlex :: Ord v => MonomialOrder v grevlex = (compare `on` deg) `mappend` revlex - -{-------------------------------------------------------------------- - Helper ---------------------------------------------------------------------} - -#if !MIN_VERSION_hashable(1,2,0) --- Copied from hashable-1.2.0.7: --- Copyright : (c) Milan Straka 2010 --- (c) Johan Tibell 2011 --- (c) Bryan O'Sullivan 2011, 2012 - --- | Transform a value into a 'Hashable' value, then hash the --- transformed value using the given salt. --- --- This is a useful shorthand in cases where a type can easily be --- mapped to another type that is already an instance of 'Hashable'. --- Example: --- --- > data Foo = Foo | Bar --- > deriving (Enum) --- > --- > instance Hashable Foo where --- > hashWithSalt = hashUsing fromEnum -hashUsing :: (Hashable b) => - (a -> b) -- ^ Transformation function. - -> Int -- ^ Salt. - -> a -- ^ Value to transform. - -> Int -hashUsing f salt x = hashWithSalt salt (f x) -{-# INLINE hashUsing #-} -#endif diff --git a/src/ToySolver/Data/Polynomial/Factorization/FiniteField.hs b/src/ToySolver/Data/Polynomial/Factorization/FiniteField.hs --- a/src/ToySolver/Data/Polynomial/Factorization/FiniteField.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/FiniteField.hs @@ -1,21 +1,25 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.FiniteField -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns, TypeSynonymInstances, FlexibleInstances) +-- Portability : non-portable -- -- Factoriation of polynomial over a finite field. -- -- References: -- -- * --- +-- -- * -- -- * Martin Kreuzer and Lorenzo Robbiano. Computational Commutative Algebra 1. Springer Verlag, 2000. @@ -30,8 +34,8 @@ import Control.Exception (assert) import Data.FiniteField -import Data.Function (on) import Data.List +import Data.Ord import Data.Set (Set) import qualified Data.Set as Set import GHC.TypeLits @@ -82,7 +86,7 @@ | otherwise = go (i+1) c' w' result' where y = P.gcd w c - z = w `P.div` y + z = w `P.div` y c' = c `P.div` y w' = y result' = [(z,i) | z /= 1] ++ result @@ -117,7 +121,7 @@ basisOfBerlekampSubalgebra :: forall k. (Ord k, FiniteField k) => UPolynomial k -> [UPolynomial k] basisOfBerlekampSubalgebra f = - sortBy (flip compare `on` P.deg) $ + sortOn (Down . P.deg) $ map (P.toMonic P.nat) $ basis where diff --git a/src/ToySolver/Data/Polynomial/Factorization/Hensel.hs b/src/ToySolver/Data/Polynomial/Factorization/Hensel.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Hensel.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Hensel.hs @@ -3,7 +3,7 @@ -- Module : ToySolver.Data.Polynomial.Factorization.Hensel -- Copyright : (c) Masahiro Sakai 2013-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -11,7 +11,7 @@ -- References: -- -- * --- +-- -- * -- ----------------------------------------------------------------------------- diff --git a/src/ToySolver/Data/Polynomial/Factorization/Hensel/Internal.hs b/src/ToySolver/Data/Polynomial/Factorization/Hensel/Internal.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Hensel/Internal.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Hensel/Internal.hs @@ -1,19 +1,21 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.Hensel.Internal -- Copyright : (c) Masahiro Sakai 2013-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns) +-- Portability : non-portable -- -- References: -- -- * --- +-- -- * -- ----------------------------------------------------------------------------- @@ -39,7 +41,7 @@ | otherwise = assert precondition $ go 1 (map (P.mapCoeff Data.FiniteField.toInteger) fs1) where precondition = - P.mapCoeff fromInteger f == product fs1 && + P.mapCoeff fromInteger f == product fs1 && P.deg f == P.deg (product fs1) p :: Integer @@ -52,7 +54,7 @@ check :: Integer -> [UPolynomial Integer] -> Bool check k' fs = - and + and [ P.mapCoeff (`mod` pk) f == P.mapCoeff (`mod` pk) (product fs) , fs1 == map (P.mapCoeff fromInteger) fs , and [P.deg fi1 == P.deg fik | (fi1, fik) <- zip fs1 fs] diff --git a/src/ToySolver/Data/Polynomial/Factorization/Integer.hs b/src/ToySolver/Data/Polynomial/Factorization/Integer.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Integer.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Integer.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.Integer -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Data.Polynomial.Factorization.Integer () where diff --git a/src/ToySolver/Data/Polynomial/Factorization/Kronecker.hs b/src/ToySolver/Data/Polynomial/Factorization/Kronecker.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Kronecker.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Kronecker.hs @@ -1,13 +1,14 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.Kronecker -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns) +-- Portability : non-portable -- -- Factoriation of integer-coefficient polynomial using Kronecker's method. -- diff --git a/src/ToySolver/Data/Polynomial/Factorization/Rational.hs b/src/ToySolver/Data/Polynomial/Factorization/Rational.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Rational.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Rational.hs @@ -1,4 +1,17 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.Polynomial.Factorization.Rational +-- Copyright : (c) Masahiro Sakai 2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.Data.Polynomial.Factorization.Rational () where import Data.List (foldl') diff --git a/src/ToySolver/Data/Polynomial/Factorization/SquareFree.hs b/src/ToySolver/Data/Polynomial/Factorization/SquareFree.hs --- a/src/ToySolver/Data/Polynomial/Factorization/SquareFree.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/SquareFree.hs @@ -1,13 +1,16 @@ -{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.SquareFree -- Copyright : (c) Masahiro Sakai 2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns, TypeSynonymInstances, FlexibleInstances) +-- Portability : non-portable -- -- References: -- diff --git a/src/ToySolver/Data/Polynomial/Factorization/Zassenhaus.hs b/src/ToySolver/Data/Polynomial/Factorization/Zassenhaus.hs --- a/src/ToySolver/Data/Polynomial/Factorization/Zassenhaus.hs +++ b/src/ToySolver/Data/Polynomial/Factorization/Zassenhaus.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, Rank2Types #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.Factorization.Zassenhaus -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns, ScopedTypeVariables, Rank2Types) +-- Portability : non-portable -- -- Factoriation of integer-coefficient polynomial using Zassenhaus algorithm. -- diff --git a/src/ToySolver/Data/Polynomial/GroebnerBasis.hs b/src/ToySolver/Data/Polynomial/GroebnerBasis.hs --- a/src/ToySolver/Data/Polynomial/GroebnerBasis.hs +++ b/src/ToySolver/Data/Polynomial/GroebnerBasis.hs @@ -1,20 +1,21 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Data.Polynomial.GroebnerBasis -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables) --- +-- Portability : non-portable +-- -- Gröbner basis -- -- References: -- -- * Monomial order --- +-- -- * Gröbner basis -- -- * グレブナー基底 @@ -22,7 +23,7 @@ -- * Gröbner Bases and Buchberger’s Algorithm -- -- * Docon --- +-- ----------------------------------------------------------------------------- module ToySolver.Data.Polynomial.GroebnerBasis diff --git a/src/ToySolver/Data/Polynomial/Interpolation/Hermite.hs b/src/ToySolver/Data/Polynomial/Interpolation/Hermite.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Data/Polynomial/Interpolation/Hermite.hs @@ -0,0 +1,78 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.Polynomial.Interpolation.Hermite +-- Copyright : (c) Masahiro Sakai 2020 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- References: +-- +-- * Lagrange polynomial +-- +----------------------------------------------------------------------------- +module ToySolver.Data.Polynomial.Interpolation.Hermite + ( interpolate + ) where + +import Data.List (unfoldr) + +import ToySolver.Data.Polynomial (UPolynomial, X (..)) +import qualified ToySolver.Data.Polynomial as P + + +-- | Compute a hermite Hermite interpolation from a list +-- \([(x_0, [y_0, y'_0, \ldots y^{(m)}_0]), (x_1, [y_1, y'_1, \ldots y^{(m)}_1]), \ldots]\). +interpolate :: (Eq k, Fractional k) => [(k,[k])] -> UPolynomial k +interpolate xyss = sum $ zipWith (\c p -> P.constant c * p) cs ps + where + x = P.var X + ps = scanl (*) (P.constant 1) [(x - P.constant x') | (x', ys') <- xyss, _ <- ys'] + cs = map head $ dividedDifferenceTable xyss + + +type D a = Either (a, Int, [a]) ((a, a), a) + + +dividedDifferenceTable :: forall a. Fractional a => [(a, [a])] -> [[a]] +dividedDifferenceTable xyss = unfoldr f xyss' + where + xyss' :: [D a] + xyss' = + [ Left (x, len, zipWith (\num den -> num / fromInteger den) ys (scanl (*) 1 [1..])) + | (x, ys) <- xyss + , let len = length ys + ] + + d :: D a -> [a] + d (Left (_x, n, ys)) = replicate n (head ys) + d (Right (_, y)) = [y] + + gx1, gx2, gy :: D a -> a + gx1 (Left (x, _n, _ys)) = x + gx1 (Right ((x1, _x2), _y)) = x1 + gx2 (Left (x, _n, _ys)) = x + gx2 (Right ((_x1, x2), _y)) = x2 + gy (Left (_x, _n, ys)) = head ys + gy (Right (_, y)) = y + + f :: [D a] -> Maybe ([a], [D a]) + f [] = Nothing + f xs = Just (concatMap d xs, h xs) + where + h :: [D a] -> [D a] + h (z1 : zzs) = + (case z1 of + Left (x, n, _ : ys@(_ : _)) -> [Left (x, n-1, ys)] + _ -> []) + ++ + (case zzs of + z2 : _ -> [Right ((gx1 z1, gx2 z2), (gy z2 - gy z1) / (gx2 z2 - gx1 z1))] + [] -> []) + ++ + h zzs + h [] = [] diff --git a/src/ToySolver/Data/Polynomial/Interpolation/Lagrange.hs b/src/ToySolver/Data/Polynomial/Interpolation/Lagrange.hs --- a/src/ToySolver/Data/Polynomial/Interpolation/Lagrange.hs +++ b/src/ToySolver/Data/Polynomial/Interpolation/Lagrange.hs @@ -1,4 +1,18 @@ --- http://en.wikipedia.org/wiki/Lagrange_polynomial +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Data.Polynomial.Interpolation.Lagrange +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- References: +-- +-- * Lagrange polynomial +-- +----------------------------------------------------------------------------- module ToySolver.Data.Polynomial.Interpolation.Lagrange ( interpolate ) where diff --git a/src/ToySolver/EUF/CongruenceClosure.hs b/src/ToySolver/EUF/CongruenceClosure.hs --- a/src/ToySolver/EUF/CongruenceClosure.hs +++ b/src/ToySolver/EUF/CongruenceClosure.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.EUF.CongruenceClosure -- Copyright : (c) Masahiro Sakai 2012, 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns, ScopedTypeVariables, FlexibleInstances) +-- Portability : non-portable -- -- References: -- @@ -33,7 +37,7 @@ , newFun , newConst , merge - , merge' + , merge' , mergeFlatTerm , mergeFlatTerm' @@ -78,12 +82,14 @@ import qualified Data.IntSet as IntSet import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +#if !MIN_VERSION_base(4,11,0) import Data.Semigroup +#endif import Data.Set (Set) import qualified Data.Set as Set import qualified ToySolver.Internal.Data.Vec as Vec - + type FSym = Int data Term = TApp FSym [Term] @@ -105,11 +111,11 @@ deriving (Eq, Ord, Show) -- | An equation @a = b@ represented as either --- +-- -- * @a = b@ or -- -- * @f(a1,a2) = a, f(b1,b2) = b@ where @a1 = b1@ and @a2 = b2@ has already been derived. --- +-- type Eqn = Either Eqn0 (Eqn1, Eqn1) data Class @@ -182,7 +188,7 @@ gen <- Vec.new Vec.push gen 0 isAfterBT <- newIORef False - + return $ Solver { svDefs = defs @@ -274,7 +280,7 @@ addToPending solver $ Right (eq1, eq2) propagate solver checkInvariant solver - Nothing -> do + Nothing -> do setLookup solver a1' a2' eq1 lv <- getCurrentLevel solver gen <- getLevelGen solver lv @@ -380,7 +386,7 @@ representatives <- liftM IntSet.fromList $ Vec.getElems (svRepresentativeTable solver) - ref <- newIORef IntSet.empty + ref <- newIORef IntSet.empty forM_ (IntSet.toList representatives) $ \a' -> do bs <- Vec.read (svClassList solver) a' forM_ (classToList bs) $ \b -> do @@ -447,13 +453,13 @@ explainConst solver c1 c2 = do initAfterBacktracking solver n <- getNFSyms solver - + -- Additional union-find data structure forLoop 0 ( do Vec.unsafeWrite (svERepresentativeTable solver) a a Vec.unsafeWrite (svEClassList solver) a (ClassSingleton a) Vec.unsafeWrite (svEHighestNodeTable solver) a a - + let union :: FSym -> FSym -> IO () union a b = do a' <- getERepresentative solver a @@ -461,15 +467,15 @@ classA <- Vec.unsafeRead (svEClassList solver) a' classB <- Vec.unsafeRead (svEClassList solver) b' h <- getHighestNode solver b' - (a', b', classA, classB) <- + (b'', classA, classB) <- if classSize classA < classSize classB then do - return (a', b', classA, classB) + return (b', classA, classB) else - return (b', a', classB, classA) + return (a', classB, classA) classForM_ classA $ \c -> do - Vec.unsafeWrite (svERepresentativeTable solver) c b' - Vec.unsafeWrite (svEClassList solver) b' (classA <> classB) - Vec.unsafeWrite (svEHighestNodeTable solver) b' h + Vec.unsafeWrite (svERepresentativeTable solver) c b'' + Vec.unsafeWrite (svEClassList solver) b'' (classA <> classB) + Vec.unsafeWrite (svEHighestNodeTable solver) b'' h Vec.clear (svEPendingProofs solver) Vec.push (svEPendingProofs solver) (c1,c2) @@ -529,7 +535,7 @@ deriving (Show) getModel :: Solver -> IO Model -getModel solver = do +getModel solver = do n <- Vec.getSize (svRepresentativeTable solver) univRef <- newIORef IntSet.empty reprRef <- newIORef IntMap.empty @@ -595,7 +601,7 @@ funcs2 :: IntMap (Map EntityTuple Entity) funcs2 = fmap (\m -> Map.fromList [(map to_univ2 xs, to_univ2 y) | (xs,y) <- Map.toList m]) funcs - + classes2 :: [(Set Term, Entity)] classes2 = [(classA, to_univ2 a) | (classA,a) <- classes] @@ -664,7 +670,7 @@ modifyIORef' (svLookupTable solver) (IntMap.adjust (IntMap.delete b') a') TrailMerge a' b' a origRootA -> do -- Revert changes to Union-Find data strucutres - ClassUnion _ origClassA origClassB <- Vec.unsafeRead (svClassList solver) b' + ClassUnion _ origClassA origClassB <- Vec.unsafeRead (svClassList solver) b' classForM_ origClassA $ \c -> do Vec.unsafeWrite (svRepresentativeTable solver) c a' Vec.unsafeWrite (svClassList solver) b' origClassB @@ -701,7 +707,7 @@ setLookup :: Solver -> FSym -> FSym -> Eqn1 -> IO () setLookup solver a1 a2 eqn = do modifyIORef' (svLookupTable solver) $ - IntMap.insertWith IntMap.union a1 (IntMap.singleton a2 eqn) + IntMap.insertWith IntMap.union a1 (IntMap.singleton a2 eqn) addToTrail solver (TrailSetLookup a1 a2) addToPending :: Solver -> Eqn -> IO () diff --git a/src/ToySolver/EUF/EUFSolver.hs b/src/ToySolver/EUF/EUFSolver.hs --- a/src/ToySolver/EUF/EUFSolver.hs +++ b/src/ToySolver/EUF/EUFSolver.hs @@ -1,13 +1,14 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.EUF.EUFSolver -- Copyright : (c) Masahiro Sakai 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : unstable --- Portability : non-portable (CPP) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.EUF.EUFSolver @@ -87,7 +88,7 @@ expl <- newIORef undefined bp <- Vec.new - let solver = + let solver = Solver { svCCSolver = cc , svDisequalities = deqs diff --git a/src/ToySolver/EUF/FiniteModelFinder.hs b/src/ToySolver/EUF/FiniteModelFinder.hs --- a/src/ToySolver/EUF/FiniteModelFinder.hs +++ b/src/ToySolver/EUF/FiniteModelFinder.hs @@ -1,13 +1,18 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, OverloadedStrings #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.EUF.FiniteModelFinder -- Copyright : (c) Masahiro Sakai 2012, 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables, MultiParamTypeClasses, OverloadedStrings) +-- Portability : non-portable -- -- A simple model finder. -- @@ -175,7 +180,7 @@ toNNF :: Formula -> Formula toNNF = f - where + where f (And phi psi) = f phi .&&. f psi f (Or phi psi) = f phi .||. f psi f (Not phi) = g phi @@ -198,9 +203,9 @@ g (Atom a) = notB (Atom a) -- | normalize a formula into a skolem normal form. --- +-- -- TODO: --- +-- -- * Tseitin encoding toSkolemNF :: forall m. Monad m => (Var -> Int -> m FSym) -> Formula -> m [Clause] toSkolemNF skolem phi = f [] Map.empty (toNNF phi) @@ -315,7 +320,7 @@ flattenLit :: Lit -> M SLit flattenLit (Pos a) = liftM Pos $ flattenAtom a flattenLit (Neg a) = liftM Neg $ flattenAtom a - + flattenAtom :: Atom -> M SAtom flattenAtom (PApp "=" [TmVar x, TmVar y]) = return $ SEq (STmVar x) y flattenAtom (PApp "=" [TmVar x, TmApp f ts]) = do @@ -331,7 +336,7 @@ flattenAtom (PApp p ts) = do xs <- mapM flattenTerm ts return $ SPApp p xs - + flattenTerm :: Term -> M Var flattenTerm (TmVar x) = return x flattenTerm (TmApp f ts) = do @@ -353,7 +358,7 @@ go r (l : ls) = go (l : r) ls substLit :: Var -> Var -> SLit -> SLit - substLit x y (Pos a) = Pos $ substAtom x y a + substLit x y (Pos a) = Pos $ substAtom x y a substLit x y (Neg a) = Neg $ substAtom x y a substAtom :: Var -> Var -> SAtom -> SAtom @@ -478,7 +483,7 @@ } showModel :: Model -> [String] -showModel m = +showModel m = printf "DOMAIN = {%s}" (intercalate ", " (map showEntity (mUniverse m))) : [ printf "%s = { %s }" (Text.unpack (unintern p)) s | (p, xss) <- Map.toList (mRelations m) diff --git a/src/ToySolver/FileFormat.hs b/src/ToySolver/FileFormat.hs --- a/src/ToySolver/FileFormat.hs +++ b/src/ToySolver/FileFormat.hs @@ -4,10 +4,10 @@ -- Module : ToySolver.FileFormat -- Copyright : (c) Masahiro Sakai 2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable +-- Portability : portable -- ----------------------------------------------------------------------------- module ToySolver.FileFormat diff --git a/src/ToySolver/FileFormat/Base.hs b/src/ToySolver/FileFormat/Base.hs --- a/src/ToySolver/FileFormat/Base.hs +++ b/src/ToySolver/FileFormat/Base.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/src/ToySolver/FileFormat/CNF.hs b/src/ToySolver/FileFormat/CNF.hs --- a/src/ToySolver/FileFormat/CNF.hs +++ b/src/ToySolver/FileFormat/CNF.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,7 +8,7 @@ -- Module : ToySolver.FileFormat.CNF -- Copyright : (c) Masahiro Sakai 2016-2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable @@ -132,7 +133,7 @@ , wcnfNumClauses :: !Int -- ^ Number of (weighted) clauses , wcnfTopCost :: !Weight - -- ^ Hard clauses have weight equal or greater than "top". + -- ^ Hard clauses have weight equal or greater than "top". -- We assure that "top" is a weight always greater than the sum of the weights of violated soft clauses in the solution. , wcnfClauses :: [WeightedClause] -- ^ Weighted clauses diff --git a/src/ToySolver/Graph/Base.hs b/src/ToySolver/Graph/Base.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Graph/Base.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Graph.Base +-- Copyright : (c) Masahiro Sakai 2020 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module ToySolver.Graph.Base + ( EdgeLabeledGraph + , Graph + , graphToUnorderedEdges + , graphFromUnorderedEdges + , graphFromUnorderedEdgesWith + , isIndependentSet + ) where + +import Control.Monad +import Data.Array.IArray +import Data.Array.ST +import qualified Data.IntMap.Lazy as IntMap +import Data.IntMap.Lazy (IntMap) +import qualified Data.IntSet as IntSet +import Data.IntSet (IntSet) + +type EdgeLabeledGraph a = Array Int (IntMap a) + +type Graph = EdgeLabeledGraph () + +graphToUnorderedEdges :: EdgeLabeledGraph a -> [(Int, Int, a)] +graphToUnorderedEdges g = do + (node1, nodes) <- assocs g + (node2, a) <- IntMap.toList $ snd $ IntMap.split node1 nodes + return (node1, node2, a) + +graphFromUnorderedEdges :: Int -> [(Int, Int, a)] -> EdgeLabeledGraph a +graphFromUnorderedEdges = graphFromUnorderedEdgesWith const + +graphFromUnorderedEdgesWith :: (a -> a -> a) -> Int -> [(Int, Int, a)] -> EdgeLabeledGraph a +graphFromUnorderedEdgesWith f n es = runSTArray $ do + a <- newArray (0, n-1) IntMap.empty + let ins i x l = do + m <- readArray a i + writeArray a i $! IntMap.insertWith f x l m + forM_ es $ \(node1, node2, a) -> do + ins node1 node2 a + ins node2 node1 a + return a + +isIndependentSet :: EdgeLabeledGraph a -> IntSet -> Bool +isIndependentSet g s = null $ do + (node1, node2, _) <- graphToUnorderedEdges g + guard $ node1 `IntSet.member` s + guard $ node2 `IntSet.member` s + return () diff --git a/src/ToySolver/Graph/MaxCut.hs b/src/ToySolver/Graph/MaxCut.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/Graph/MaxCut.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Graph.MaxCut +-- Copyright : (c) Masahiro Sakai 2018 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module ToySolver.Graph.MaxCut + ( Problem (..) + , buildDSDPMaxCutGraph + , buildDSDPMaxCutGraph' + , Solution + , eval + , evalEdge + ) where + +import Data.Array.IArray +import Data.Array.Unboxed +import Data.ByteString.Builder +import Data.ByteString.Builder.Scientific +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.Foldable as F +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.Monoid +import Data.Scientific (Scientific) + +import ToySolver.Graph.Base + +type Problem a = EdgeLabeledGraph a + +buildDSDPMaxCutGraph :: EdgeLabeledGraph Scientific -> Builder +buildDSDPMaxCutGraph = buildDSDPMaxCutGraph' scientificBuilder + +buildDSDPMaxCutGraph' :: (a -> Builder) -> EdgeLabeledGraph a -> Builder +buildDSDPMaxCutGraph' weightBuilder prob = header <> body + where + (lb,ub) = bounds prob + m = sum [IntMap.size m | m <- elems prob] + header = intDec (ub-lb+1) <> char7 ' ' <> intDec m <> char7 '\n' + body = mconcat $ do + (a,b,w) <- graphToUnorderedEdges prob + return $ intDec (a-lb+1) <> char7 ' ' <> intDec (b-lb+1) <> char7 ' ' <> weightBuilder w <> char7 '\n' + +type Solution = UArray Int Bool + +eval :: Num a => Solution -> Problem a -> a +eval sol prob = sum [w | (a,b,w) <- graphToUnorderedEdges prob, sol ! a /= sol ! b] + +evalEdge :: Num a => Solution -> (Int,Int,a) -> a +evalEdge sol (a,b,w) + | sol ! a /= sol ! b = w + | otherwise = 0 diff --git a/src/ToySolver/Graph/ShortestPath.hs b/src/ToySolver/Graph/ShortestPath.hs --- a/src/ToySolver/Graph/ShortestPath.hs +++ b/src/ToySolver/Graph/ShortestPath.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ScopedTypeVariables #-} -------------------------------------------------------------------------- @@ -70,9 +71,9 @@ import Data.Hashable import qualified Data.HashTable.Class as H import qualified Data.HashTable.ST.Cuckoo as C -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet import qualified Data.Heap as Heap -- http://hackage.haskell.org/package/heaps import Data.List (foldl') import Data.Monoid @@ -84,52 +85,55 @@ -- ------------------------------------------------------------------------ -- | Graph represented as a map from vertexes to their outgoing edges -type Graph vertex cost label = HashMap vertex [OutEdge vertex cost label] +type Graph cost label = IntMap [OutEdge cost label] +-- | Vertex data type +type Vertex = Int + -- | Edge data type -type Edge vertex cost label = (vertex, vertex, cost, label) +type Edge cost label = (Vertex, Vertex, cost, label) -- | Outgoing edge data type (source vertex is implicit) -type OutEdge vertex cost label = (vertex, cost, label) +type OutEdge cost label = (Vertex, cost, label) -- | Incoming edge data type (target vertex is implicit) -type InEdge vertex cost label = (vertex, cost, label) +type InEdge cost label = (Vertex, cost, label) -- | path data type. -data Path vertex cost label - = Empty vertex +data Path cost label + = Empty Vertex -- ^ empty path - | Singleton (Edge vertex cost label) + | Singleton (Edge cost label) -- ^ path with single edge - | Append (Path vertex cost label) (Path vertex cost label) !cost + | Append (Path cost label) (Path cost label) !cost -- ^ concatenation of two paths deriving (Eq, Show) -- | Source vertex -pathFrom :: Path vertex cost label -> vertex +pathFrom :: Path cost label -> Vertex pathFrom (Empty v) = v pathFrom (Singleton (from,_,_,_)) = from pathFrom (Append p1 _ _) = pathFrom p1 -- | Target vertex -pathTo :: Path vertex cost label -> vertex +pathTo :: Path cost label -> Vertex pathTo (Empty v) = v pathTo (Singleton (_,to,_,_)) = to pathTo (Append _ p2 _) = pathTo p2 -- | Cost of a path -pathCost :: Num cost => Path vertex cost label -> cost +pathCost :: Num cost => Path cost label -> cost pathCost (Empty _) = 0 pathCost (Singleton (_,_,c,_)) = c pathCost (Append _ _ c) = c -- | Empty path -pathEmpty :: vertex -> Path vertex cost label +pathEmpty :: Vertex -> Path cost label pathEmpty = Empty -- | Concatenation of two paths -pathAppend :: (Eq vertex, Num cost) => Path vertex cost label -> Path vertex cost label -> Path vertex cost label -pathAppend p1 p2 +pathAppend :: (Num cost) => Path cost label -> Path cost label -> Path cost label +pathAppend p1 p2 | pathTo p1 /= pathFrom p2 = error "ToySolver.Graph.ShortestPath.pathAppend: pathTo/pathFrom mismatch" | otherwise = case (p1, p2) of @@ -138,7 +142,7 @@ _ -> Append p1 p2 (pathCost p1 + pathCost p2) -- | Edges of a path -pathEdges :: Path vertex cost label -> [Edge vertex cost label] +pathEdges :: Path cost label -> [Edge cost label] pathEdges p = f p [] where f (Empty _) xs = xs @@ -146,7 +150,7 @@ f (Append p1 p2 _) xs = f p1 (f p2 xs) -- | Edges of a path, but in the reverse order -pathEdgesBackward :: Path vertex cost label -> [Edge vertex cost label] +pathEdgesBackward :: Path cost label -> [Edge cost label] pathEdgesBackward p = f p [] where f (Empty _) xs = xs @@ -154,13 +158,13 @@ f (Append p1 p2 _) xs = f p2 (f p1 xs) -- | Edges of a path, but as `Seq` -pathEdgesSeq :: Path vertex cost label -> Seq (Edge vertex cost label) +pathEdgesSeq :: Path cost label -> Seq (Edge cost label) pathEdgesSeq (Empty _) = Seq.empty pathEdgesSeq (Singleton e) = Seq.singleton e pathEdgesSeq (Append p1 p2 _) = pathEdgesSeq p1 <> pathEdgesSeq p2 -- | Vertexes of a path -pathVertexes :: Path vertex cost label -> [vertex] +pathVertexes :: Path cost label -> [Vertex] pathVertexes p = pathFrom p : f p [] where f (Empty _) xs = xs @@ -168,7 +172,7 @@ f (Append p1 p2 _) xs = f p1 (f p2 xs) -- | Vertexes of a path, but in the reverse order -pathVertexesBackward :: Path vertex cost label -> [vertex] +pathVertexesBackward :: Path cost label -> [Vertex] pathVertexesBackward p = pathTo p : f p [] where f (Empty _) xs = xs @@ -176,7 +180,7 @@ f (Append p1 p2 _) xs = f p2 (f p1 xs) -- | Vertex of a path, but as `Seq` -pathVertexesSeq :: Path vertex cost label -> Seq vertex +pathVertexesSeq :: Path cost label -> Seq Vertex pathVertexesSeq p = f True p where f True (Empty v) = Seq.singleton v @@ -185,13 +189,13 @@ f False (Singleton (v1,_,_,_)) = Seq.singleton v1 f b (Append p1 p2 _) = f False p1 <> f b p2 -pathMin :: (Num cost, Ord cost) => Path vertex cost label -> Path vertex cost label -> Path vertex cost label +pathMin :: (Num cost, Ord cost) => Path cost label -> Path cost label -> Path cost label pathMin p1 p2 | pathCost p1 <= pathCost p2 = p1 | otherwise = p2 -- | Fold a path using a given 'Fold` operation. -pathFold :: Fold vertex cost label a -> Path vertex cost label -> a +pathFold :: Fold cost label a -> Path cost label -> a pathFold (Fold fV fE fC fD) p = fD (h p) where h (Empty v) = fV v @@ -207,23 +211,23 @@ -- | Operations for folding edge information along with a path into a @r@ value. -- --- @Fold vertex cost label r@ consists of three operations +-- @Fold cost label r@ consists of three operations -- --- * @vertex -> a@ corresponds to an empty path, +-- * @Vertex -> a@ corresponds to an empty path, -- --- * @Edge vertex cost label -> a@ corresponds to a single edge, +-- * @Edge cost label -> a@ corresponds to a single edge, -- -- * @a -> a -> a@ corresponds to path concatenation, -- -- and @a -> r@ to finish the computation. -data Fold vertex cost label r - = forall a. Fold (vertex -> a) (Edge vertex cost label -> a) (a -> a -> a) (a -> r) +data Fold cost label r + = forall a. Fold (Vertex -> a) (Edge cost label -> a) (a -> a -> a) (a -> r) -instance Functor (Fold vertex cost label) where +instance Functor (Fold cost label) where {-# INLINE fmap #-} fmap f (Fold fV fE fC fD) = Fold fV fE fC (f . fD) -instance Applicative (Fold vertex cost label) where +instance Applicative (Fold cost label) where {-# INLINE pure #-} pure a = Fold (\_ -> ()) (\_ -> ()) (\_ _ -> ()) (const a) @@ -235,19 +239,19 @@ (\(Pair a b) -> fD1 a (fD2 b)) -- | Project `Edge` into a monoid value and fold using monoidal operation. -monoid' :: Monoid m => (Edge vertex cost label -> m) -> Fold vertex cost label m +monoid' :: Monoid m => (Edge cost label -> m) -> Fold cost label m monoid' f = Fold (\_ -> mempty) f mappend id -- | Similar to 'monoid'' but a /label/ is directly used as a monoid value. -monoid :: Monoid m => Fold vertex cost m m +monoid :: Monoid m => Fold cost m m monoid = monoid' (\(_,_,_,m) -> m) -- | Ignore contents and return a unit value. -unit :: Fold vertex cost label () +unit :: Fold cost label () unit = monoid' (\_ -> ()) -- | Pairs two `Fold` into one that produce a tuple. -pair :: Fold vertex cost label a -> Fold vertex cost label b -> Fold vertex cost label (a,b) +pair :: Fold cost label a -> Fold cost label b -> Fold cost label (a,b) pair (Fold fV1 fE1 fC1 fD1) (Fold fV2 fE2 fC2 fD2) = Fold (\v -> Pair (fV1 v) (fV2 v)) (\e -> Pair (fE1 e) (fE2 e)) @@ -255,20 +259,20 @@ (\(Pair a b) -> (fD1 a, fD2 b)) -- | Construct a `Path` value. -path :: (Eq vertex, Num cost) => Fold vertex cost label (Path vertex cost label) +path :: (Num cost) => Fold cost label (Path cost label) path = Fold pathEmpty Singleton pathAppend id -- | Compute cost of a path. -cost :: Num cost => Fold vertex cost label cost +cost :: Num cost => Fold cost label cost cost = Fold (\_ -> 0) (\(_,_,c,_) -> c) (+) id -- | Get the first `OutEdge` of a path. -firstOutEdge :: Fold vertex cost label (First (OutEdge vertex cost label)) +firstOutEdge :: Fold cost label (First (OutEdge cost label)) firstOutEdge = monoid' (\(_,v,c,l) -> First (Just (v,c,l))) -- | Get the last `InEdge` of a path. -- This is useful for constructing a /parent/ map of a spanning tree. -lastInEdge :: Fold vertex cost label (Last (InEdge vertex cost label)) +lastInEdge :: Fold cost label (Last (InEdge cost label)) lastInEdge = monoid' (\(v,_,c,l) -> Last (Just (v,c,l))) -- ------------------------------------------------------------------------ @@ -280,58 +284,58 @@ -- It compute shortest-paths from given source vertexes, and folds edge -- information along shortest paths using a given 'Fold' operation. bellmanFord - :: (Eq vertex, Hashable vertex, Real cost) - => Fold vertex cost label a + :: Real cost + => Fold cost label a -- ^ Operation used to fold shotest paths - -> Graph vertex cost label - -> [vertex] + -> Graph cost label + -> [Vertex] -- ^ List of source vertexes @vs@ - -> HashMap vertex (cost, a) + -> IntMap (cost, a) bellmanFord (Fold fV fE fC fD) g ss = runST $ do - let n = HashMap.size g + let n = IntMap.size g d <- C.newSized n forM_ ss $ \s -> H.insert d s (Pair 0 (fV s)) - updatedRef <- newSTRef (HashSet.fromList ss) + updatedRef <- newSTRef (IntSet.fromList ss) _ <- runExceptT $ replicateM_ n $ do us <- lift $ readSTRef updatedRef - when (HashSet.null us) $ throwE () + when (IntSet.null us) $ throwE () lift $ do - writeSTRef updatedRef HashSet.empty - forM_ (HashSet.toList us) $ \u -> do - -- modifySTRef' updatedRef (HashSet.delete u) -- possible optimization + writeSTRef updatedRef IntSet.empty + forM_ (IntSet.toList us) $ \u -> do + -- modifySTRef' updatedRef (IntSet.delete u) -- possible optimization Just (Pair du a) <- H.lookup d u - forM_ (HashMap.lookupDefault [] u g) $ \(v, c, l) -> do + forM_ (IntMap.findWithDefault [] u g) $ \(v, c, l) -> do m <- H.lookup d v case m of Just (Pair c0 _) | c0 <= du + c -> return () _ -> do H.insert d v (Pair (du + c) (a `fC` fE (u,v,c,l))) - modifySTRef' updatedRef (HashSet.insert v) + modifySTRef' updatedRef (IntSet.insert v) liftM (fmap (\(Pair c x) -> (c, fD x))) $ freezeHashTable d -freezeHashTable :: (H.HashTable h, Hashable k, Eq k) => h s k v -> ST s (HashMap k v) -freezeHashTable h = H.foldM (\m (k,v) -> return $! HashMap.insert k v m) HashMap.empty h +freezeHashTable :: H.HashTable h => h s Int v -> ST s (IntMap v) +freezeHashTable h = H.foldM (\m (k,v) -> return $! IntMap.insert k v m) IntMap.empty h -- | Utility function for detecting a negative cycle. bellmanFordDetectNegativeCycle - :: forall vertex cost label a. (Eq vertex, Hashable vertex, Real cost) - => Fold vertex cost label a + :: forall cost label a. Real cost + => Fold cost label a -- ^ Operation used to fold a cycle - -> Graph vertex cost label - -> HashMap vertex (cost, Last (InEdge vertex cost label)) + -> Graph cost label + -> IntMap (cost, Last (InEdge cost label)) -- ^ Result of @'bellmanFord' 'lastInEdge' vs@ -> Maybe a bellmanFordDetectNegativeCycle (Fold fV fE fC fD) g d = either (Just . fD) (const Nothing) $ do - forM_ (HashMap.toList d) $ \(u,(du,_)) -> - forM_ (HashMap.lookupDefault [] u g) $ \(v, c, l) -> do - let (dv,_) = d HashMap.! v + forM_ (IntMap.toList d) $ \(u,(du,_)) -> + forM_ (IntMap.findWithDefault [] u g) $ \(v, c, l) -> do + let (dv,_) = d IntMap.! v when (du + c < dv) $ do -- a negative cycle is detected - let d' = HashMap.insert v (du + c, Last (Just (u, c, l))) d + let d' = IntMap.insert v (du + c, Last (Just (u, c, l))) d parent u = do - case HashMap.lookup u d' of + case IntMap.lookup u d' of Just (_, Last (Just (v,_,_))) -> v _ -> undefined u0 = go (parent (parent v)) (parent v) @@ -340,7 +344,7 @@ | hare == tortoise = hare | otherwise = go (parent (parent hare)) (parent tortoise) let go u result = do - let Just (_, Last (Just (v,c,l))) = HashMap.lookup u d' + let Just (_, Last (Just (v,c,l))) = IntMap.lookup u d' if v == u0 then fC (fE (v,u,c,l)) result else @@ -356,33 +360,33 @@ -- It compute shortest-paths from given source vertexes, and folds edge -- information along shortest paths using a given 'Fold' operation. dijkstra - :: forall vertex cost label a. (Eq vertex, Hashable vertex, Real cost) - => Fold vertex cost label a + :: forall cost label a. Real cost + => Fold cost label a -- ^ Operation used to fold shotest paths - -> Graph vertex cost label - -> [vertex] + -> Graph cost label + -> [Vertex] -- ^ List of source vertexes - -> HashMap vertex (cost, a) + -> IntMap (cost, a) dijkstra (Fold fV fE fC (fD :: x -> a)) g ss = fmap (\(Pair c x) -> (c, fD x)) $ - loop (Heap.fromList [Heap.Entry 0 (Pair s (fV s)) | s <- ss]) HashMap.empty + loop (Heap.fromList [Heap.Entry 0 (Pair s (fV s)) | s <- ss]) IntMap.empty where loop - :: Heap.Heap (Heap.Entry cost (Pair vertex x)) - -> HashMap vertex (Pair cost x) - -> HashMap vertex (Pair cost x) + :: Heap.Heap (Heap.Entry cost (Pair Vertex x)) + -> IntMap (Pair cost x) + -> IntMap (Pair cost x) loop q visited = case Heap.viewMin q of Nothing -> visited Just (Heap.Entry c (Pair v a), q') - | v `HashMap.member` visited -> loop q' visited + | v `IntMap.member` visited -> loop q' visited | otherwise -> let q2 = Heap.fromList [ Heap.Entry (c+c') (Pair ch (a `fC` fE (v,ch,c',l))) - | (ch,c',l) <- HashMap.lookupDefault [] v g - , not (ch `HashMap.member` visited) + | (ch,c',l) <- IntMap.findWithDefault [] v g + , not (ch `IntMap.member` visited) ] - in loop (Heap.union q' q2) (HashMap.insert v (Pair c a) visited) + in loop (Heap.union q' q2) (IntMap.insert v (Pair c a) visited) -- ------------------------------------------------------------------------ @@ -392,39 +396,39 @@ -- It compute shortest-paths between each pair of vertexes, and folds edge -- information along shortest paths using a given 'Fold' operation. floydWarshall - :: forall vertex cost label a. (Eq vertex, Hashable vertex, Real cost) - => Fold vertex cost label a + :: forall cost label a. Real cost + => Fold cost label a -- ^ Operation used to fold shotest paths - -> Graph vertex cost label - -> HashMap vertex (HashMap vertex (cost, a)) + -> Graph cost label + -> IntMap (IntMap (cost, a)) floydWarshall (Fold fV fE fC (fD :: x -> a)) g = fmap (fmap (\(Pair c x) -> (c, fD x))) $ - HashMap.unionWith (HashMap.unionWith minP) (foldl' f tbl0 vs) paths0 + IntMap.unionWith (IntMap.unionWith minP) (foldl' f tbl0 vs) paths0 where - vs = HashMap.keys g + vs = IntMap.keys g - paths0 :: HashMap vertex (HashMap vertex (Pair cost x)) - paths0 = HashMap.mapWithKey (\v _ -> HashMap.singleton v (Pair 0 (fV v))) g + paths0 :: IntMap (IntMap (Pair cost x)) + paths0 = IntMap.mapWithKey (\v _ -> IntMap.singleton v (Pair 0 (fV v))) g - tbl0 :: HashMap vertex (HashMap vertex (Pair cost x)) - tbl0 = HashMap.mapWithKey (\v es -> HashMap.fromListWith minP [(u, (Pair c (fE (v,u,c,l)))) | (u,c,l) <- es]) g + tbl0 :: IntMap (IntMap (Pair cost x)) + tbl0 = IntMap.mapWithKey (\v es -> IntMap.fromListWith minP [(u, (Pair c (fE (v,u,c,l)))) | (u,c,l) <- es]) g minP :: Pair cost x -> Pair cost x -> Pair cost x minP = minBy (comparing (\(Pair c _) -> c)) - f :: HashMap vertex (HashMap vertex (Pair cost x)) - -> vertex - -> HashMap vertex (HashMap vertex (Pair cost x)) + f :: IntMap (IntMap (Pair cost x)) + -> Vertex + -> IntMap (IntMap (Pair cost x)) f tbl vk = - case HashMap.lookup vk tbl of + case IntMap.lookup vk tbl of Nothing -> tbl - Just hk -> HashMap.map h tbl + Just hk -> IntMap.map h tbl where - h :: HashMap vertex (Pair cost x) -> HashMap vertex (Pair cost x) + h :: IntMap (Pair cost x) -> IntMap (Pair cost x) h m = - case HashMap.lookup vk m of + case IntMap.lookup vk m of Nothing -> m - Just (Pair c1 x1) -> HashMap.unionWith minP m (HashMap.map (\(Pair c2 x2) -> (Pair (c1+c2) (fC x1 x2))) hk) + Just (Pair c1 x1) -> IntMap.unionWith minP m (IntMap.map (\(Pair c2 x2) -> (Pair (c1+c2) (fC x1 x2))) hk) minBy :: (a -> a -> Ordering) -> a -> a -> a minBy f a b = diff --git a/src/ToySolver/Internal/Data/IOURef.hs b/src/ToySolver/Internal/Data/IOURef.hs --- a/src/ToySolver/Internal/Data/IOURef.hs +++ b/src/ToySolver/Internal/Data/IOURef.hs @@ -1,14 +1,15 @@ {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.Data.IOURef -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (FlexibleContexts) +-- Portability : non-portable -- -- Simple unboxed IORef-like type based on IOUArray -- diff --git a/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs b/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs --- a/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs +++ b/src/ToySolver/Internal/Data/IndexedPriorityQueue.hs @@ -1,4 +1,8 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeSynonymInstances, CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} #ifdef __GLASGOW_HASKELL__ #define UNBOXED_COMPARISON_ARGUMENTS #endif @@ -6,15 +10,16 @@ {-# LANGUAGE MagicHash #-} #endif {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.Data.IndexedPriorityQueue -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances, BangPatterns, TypeSynonymInstances) +-- Portability : non-portable -- -- Priority queue implemented as array-based binary heap. -- @@ -135,7 +140,7 @@ n <- Vec.getSize (heap q) Vec.push (heap q) val Vec.growTo (table q) (val+1) - Vec.unsafeWrite (table q) val n + Vec.unsafeWrite (table q) val n up q n instance Dequeue PriorityQueue IO Value where @@ -278,7 +283,7 @@ {- checkHeapProperty :: String -> PriorityQueue -> IO () -checkHeapProperty str q = do +checkHeapProperty str q = do (n,arr) <- readIORef (heap q) let go i = do val <- A.readArray arr i diff --git a/src/ToySolver/Internal/Data/PriorityQueue.hs b/src/ToySolver/Internal/Data/PriorityQueue.hs --- a/src/ToySolver/Internal/Data/PriorityQueue.hs +++ b/src/ToySolver/Internal/Data/PriorityQueue.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, BangPatterns, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.Data.PriorityQueue -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances, BangPatterns, ScopedTypeVariables) +-- Portability : non-portable -- -- Priority queue implemented as array-based binary heap. -- @@ -200,7 +204,7 @@ {- checkHeapProperty :: String -> PriorityQueue a -> IO () -checkHeapProperty str q = do +checkHeapProperty str q = do (n,arr) <- readIORef (heap q) let go i = do val <- A.readArray arr i diff --git a/src/ToySolver/Internal/Data/SeqQueue.hs b/src/ToySolver/Internal/Data/SeqQueue.hs --- a/src/ToySolver/Internal/Data/SeqQueue.hs +++ b/src/ToySolver/Internal/Data/SeqQueue.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.Data.SeqQueue -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- Queue implemented using IORef and Sequence. --- +-- ----------------------------------------------------------------------------- module ToySolver.Internal.Data.SeqQueue ( @@ -20,7 +22,7 @@ -- * Constructors , NewFifo (..) - -- * Operators + -- * Operators , Enqueue (..) , Dequeue (..) , QueueSize (..) diff --git a/src/ToySolver/Internal/Data/Vec.hs b/src/ToySolver/Internal/Data/Vec.hs --- a/src/ToySolver/Internal/Data/Vec.hs +++ b/src/ToySolver/Internal/Data/Vec.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.Data.Vec -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns, FlexibleContexts, ScopedTypeVariables) +-- Portability : non-portable -- -- Simple 1-dimentional resizable array -- @@ -30,7 +34,7 @@ , read , write , modify - , modify' + , modify' , unsafeRead , unsafeWrite , unsafeModify @@ -70,6 +74,22 @@ type Index = Int +{- INLINE readArray #-} +readArray :: A.MArray a e m => a Index e -> Index -> m e +#ifdef EXTRA_BOUNDS_CHECKING +readArray = A.readArray +#else +readArray = A.unsafeRead +#endif + +{- INLINE writeArray #-} +writeArray :: A.MArray a e m => a Index e -> Index -> e -> m () +#ifdef EXTRA_BOUNDS_CHECKING +writeArray = A.writeArray +#else +writeArray = A.unsafeWrite +#endif + new :: A.MArray a e IO => IO (GenericVec a e) new = do sizeRef <- newIOURef 0 @@ -90,7 +110,7 @@ a <- getArray v s <- getSize v if 0 <= i && i < s then - A.unsafeRead a i + readArray a i else error $ "ToySolver.Internal.Data.Vec.read: index " ++ show i ++ " out of bounds" @@ -103,7 +123,7 @@ a <- getArray v s <- getSize v if 0 <= i && i < s then - A.unsafeWrite a i e + writeArray a i e else error $ "ToySolver.Internal.Data.Vec.write: index " ++ show i ++ " out of bounds" @@ -113,8 +133,8 @@ a <- getArray v s <- getSize v if 0 <= i && i < s then do - x <- A.unsafeRead a i - A.unsafeWrite a i (f x) + x <- readArray a i + writeArray a i (f x) else error $ "ToySolver.Internal.Data.Vec.modify: index " ++ show i ++ " out of bounds" @@ -124,8 +144,8 @@ a <- getArray v s <- getSize v if 0 <= i && i < s then do - x <- A.unsafeRead a i - A.unsafeWrite a i $! f x + x <- readArray a i + writeArray a i $! f x else error $ "ToySolver.Internal.Data.Vec.modify': index " ++ show i ++ " out of bounds" @@ -133,27 +153,27 @@ unsafeModify :: A.MArray a e IO => GenericVec a e -> Int -> (e -> e) -> IO () unsafeModify !v !i f = do a <- getArray v - x <- A.unsafeRead a i - A.unsafeWrite a i (f x) + x <- readArray a i + writeArray a i (f x) {-# INLINE unsafeModify' #-} unsafeModify' :: A.MArray a e IO => GenericVec a e -> Int -> (e -> e) -> IO () unsafeModify' !v !i f = do a <- getArray v - x <- A.unsafeRead a i - A.unsafeWrite a i $! f x + x <- readArray a i + writeArray a i $! f x {-# INLINE unsafeRead #-} unsafeRead :: A.MArray a e IO => GenericVec a e -> Int -> IO e unsafeRead !v !i = do a <- getArray v - A.unsafeRead a i + readArray a i {-# INLINE unsafeWrite #-} unsafeWrite :: A.MArray a e IO => GenericVec a e -> Int -> e -> IO () unsafeWrite !v !i e = do a <- getArray v - A.unsafeWrite a i e + writeArray a i e {-# SPECIALIZE resize :: Vec e -> Int -> IO () #-} {-# SPECIALIZE resize :: UVec Int -> Int -> IO () #-} @@ -304,5 +324,5 @@ copyTo :: (A.MArray a e m) => a Index e -> a Index e -> (Index,Index) -> m () copyTo fromArr toArr (!lb,!ub) = do forLoop lb (<=ub) (+1) $ \i -> do - val_i <- A.unsafeRead fromArr i - A.unsafeWrite toArr i val_i + val_i <- readArray fromArr i + writeArray toArr i val_i diff --git a/src/ToySolver/Internal/ProcessUtil.hs b/src/ToySolver/Internal/ProcessUtil.hs --- a/src/ToySolver/Internal/ProcessUtil.hs +++ b/src/ToySolver/Internal/ProcessUtil.hs @@ -1,14 +1,15 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.ProcessUtil -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (CPP) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Internal.ProcessUtil diff --git a/src/ToySolver/Internal/TextUtil.hs b/src/ToySolver/Internal/TextUtil.hs --- a/src/ToySolver/Internal/TextUtil.hs +++ b/src/ToySolver/Internal/TextUtil.hs @@ -1,13 +1,15 @@ -{-# LANGUAGE BangPatterns, CPP #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Internal.TextUtil -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.Internal.TextUtil @@ -49,7 +51,7 @@ -- Many intermediate values in this implementation will be optimized -- away by worker-wrapper transformation and unboxing. {-# INLINABLE readUnsignedInteger #-} -readUnsignedInteger :: String -> Integer +readUnsignedInteger :: String -> Integer readUnsignedInteger str = assert (result == read str) $ result where result :: Integer @@ -57,8 +59,8 @@ lim :: Word lim = maxBound `div` 10 - - go :: Integer -> [Char] -> Integer + + go :: Integer -> [Char] -> Integer go !r [] = r go !r ds = case go2 0 1 ds of diff --git a/src/ToySolver/Internal/Util.hs b/src/ToySolver/Internal/Util.hs --- a/src/ToySolver/Internal/Util.hs +++ b/src/ToySolver/Internal/Util.hs @@ -4,13 +4,13 @@ -- Module : ToySolver.Internal.Util -- Copyright : (c) Masahiro Sakai 2011-2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable -- -- Some utility functions. --- +-- ----------------------------------------------------------------------------- module ToySolver.Internal.Util where @@ -37,7 +37,7 @@ isInteger x = fromInteger (round x) == x -- | fractional part --- +-- -- @ -- fracPart x = x - fromInteger (floor x) -- @ @@ -55,7 +55,7 @@ let a :: Integer (a,b) = properFraction (abs x) s1 = if x < 0 then "-" else "" - s2 = show a + s2 = show a s3 <- if b == 0 then return ".0" else liftM ("." ++ ) $ loop Set.empty b diff --git a/src/ToySolver/MaxCut.hs b/src/ToySolver/MaxCut.hs deleted file mode 100644 --- a/src/ToySolver/MaxCut.hs +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : ToySolver.MaxCut --- Copyright : (c) Masahiro Sakai 2018 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : portable --- ------------------------------------------------------------------------------ -module ToySolver.MaxCut - ( Problem (..) - , fromEdges - , edges - , buildDSDPMaxCutGraph - , buildDSDPMaxCutGraph' - , Solution - , eval - , evalEdge - ) where - -import Data.Array.Unboxed -import Data.ByteString.Builder -import Data.ByteString.Builder.Scientific -import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.Foldable as F -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as IntMap -import Data.Monoid -import Data.Scientific (Scientific) - -data Problem a - = Problem - { numNodes :: !Int - -- ^ Number of nodes N. Nodes are numbered from 0 to N-1. - , numEdges :: !Int - -- ^ Number of edges. - , matrix :: IntMap (IntMap a) - -- ^ Non-zero entries of symmetric weight matrix - } deriving (Eq, Ord, Show) - -instance Functor Problem where - fmap f Problem{ numNodes = n, numEdges = m, matrix = mat } = - Problem{ numNodes = n, numEdges = m, matrix = fmap (fmap f) mat } - -fromEdges :: Num a => Int -> [(Int,Int,a)] -> Problem a -fromEdges n es = Problem n (length es) $ IntMap.unionsWith (IntMap.unionWith (+)) $ - [IntMap.fromList [(v1, IntMap.singleton v2 w), (v2, IntMap.singleton v1 w)] | (v1,v2,w) <- es] - -edges :: Problem a -> [(Int,Int,a)] -edges prob = do - (a,m) <- IntMap.toList $ matrix prob - (b,w) <- IntMap.toList $ snd $ IntMap.split a m - return (a,b,w) - -buildDSDPMaxCutGraph :: Problem Scientific -> Builder -buildDSDPMaxCutGraph = buildDSDPMaxCutGraph' scientificBuilder - -buildDSDPMaxCutGraph' :: (a -> Builder) -> Problem a -> Builder -buildDSDPMaxCutGraph' weightBuilder prob = header <> body - where - header = intDec (numNodes prob) <> char7 ' ' <> intDec (numEdges prob) <> char7 '\n' - body = mconcat $ do - (a,b,w) <- edges prob - return $ intDec (a+1) <> char7 ' ' <> intDec (b+1) <> char7 ' ' <> weightBuilder w <> char7 '\n' - -type Solution = UArray Int Bool - -eval :: Num a => Solution -> Problem a -> a -eval sol prob = sum [w | (a,b,w) <- edges prob, sol ! a /= sol ! b] - -evalEdge :: Num a => Solution -> (Int,Int,a) -> a -evalEdge sol (a,b,w) - | sol ! a /= sol ! b = w - | otherwise = 0 diff --git a/src/ToySolver/QBF.hs b/src/ToySolver/QBF.hs --- a/src/ToySolver/QBF.hs +++ b/src/ToySolver/QBF.hs @@ -1,14 +1,15 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.QBF -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns) +-- Portability : non-portable -- -- Reference: -- @@ -23,7 +24,7 @@ ( Quantifier (..) , Prefix , normalizePrefix - , quantifyFreeVariables + , quantifyFreeVariables , Matrix , solve , solveNaive @@ -140,7 +141,7 @@ subst2' = fmap BoolExpr.Atom s `IntMap.union` subst2 f (prefix ++ [(q, xs')]) (bvs `IntSet.union` xs') subst1 subst2' prefix1 prefix2' --- XXX +-- XXX prenexOr :: (Int, Prefix, Matrix) -> (Int, Prefix, Matrix) -> (Int, Prefix, Matrix) prenexOr (nv1, prefix1, matrix1) (nv2, prefix2, matrix2) = evalState (f [] IntSet.empty IntMap.empty IntMap.empty prefix1 prefix2) (nv1 `max` nv2) @@ -249,7 +250,7 @@ -- ---------------------------------------------------------------------------- --- | Abstraction-Based Algorithm for a Winning Move +-- | Abstraction-Based Algorithm for a Winning Move solveCEGAR :: Int -> Prefix -> Matrix -> IO (Bool, Maybe LitSet) solveCEGAR nv prefix matrix = case prefix' of @@ -355,7 +356,7 @@ solver <- SAT.newSolver SAT.newVars_ solver nv enc <- Tseitin.newEncoder solver - xs <- + _xs <- case last prefix of (E, xs) -> do Tseitin.addFormula enc matrix @@ -365,13 +366,13 @@ return xs let g :: Int -> LitSet -> Prefix -> Matrix -> IO (Maybe LitSet) g _nv _assumptions [] _matrix = error "should not happen" - g nv assumptions [(_q,xs)] matrix = do + g _nv assumptions [(_q,xs)] _matrix = do ret <- SAT.solveWith solver (IntSet.toList assumptions) if ret then do m <- SAT.getModel solver return $ Just $ IntSet.fromList [if SAT.evalLit m x then x else -x | x <- IntSet.toList xs] else - return Nothing + return Nothing g nv assumptions ((q,xs) : prefix'@((_q2,_) : prefix'')) matrix = do let loop counterMoves = do let ys = [(nv, prefix'', reduct matrix nu) | nu <- counterMoves] @@ -473,16 +474,20 @@ -- ---------------------------------------------------------------------------- -- ∀y ∃x. x ∧ (y ∨ ¬x) +_test :: IO (Bool, Maybe LitSet) _test = solveNaive 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x)) where x = BoolExpr.Atom 1 y = BoolExpr.Atom 2 +_test' :: IO (Bool, Maybe LitSet) _test' = solveCEGAR 2 [(A, IntSet.singleton 2), (E, IntSet.singleton 1)] (x .&&. (y .||. notB x)) where x = BoolExpr.Atom 1 y = BoolExpr.Atom 2 +_test1 :: (Int, Prefix, Matrix) _test1 = prenexAnd (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], notB (BoolExpr.Atom 1)) +_test2 :: (Int, Prefix, Matrix) _test2 = prenexOr (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) (1, [(A, IntSet.singleton 1)], BoolExpr.Atom 1) diff --git a/src/ToySolver/QUBO.hs b/src/ToySolver/QUBO.hs --- a/src/ToySolver/QUBO.hs +++ b/src/ToySolver/QUBO.hs @@ -1,4 +1,6 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -6,11 +8,11 @@ -- Module : ToySolver.QUBO -- Copyright : (c) Masahiro Sakai 2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable --- +-- ----------------------------------------------------------------------------- module ToySolver.QUBO ( -- * QUBO (quadratic unconstrained boolean optimization) @@ -30,7 +32,9 @@ import qualified Data.ByteString.Lazy.Char8 as BS import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap +#if !MIN_VERSION_base(4,11,0) import Data.Monoid +#endif import Data.Scientific import ToySolver.FileFormat.Base @@ -56,7 +60,7 @@ } parseProblem :: (BS.ByteString -> a) -> BS.ByteString -> Either String (Problem a) -parseProblem f s = +parseProblem f s = case BS.words l of ["p", filetype, topology, maxNodes, _nNodes, _nCouplers] -> if filetype /= "qubo" then diff --git a/src/ToySolver/SAT.hs b/src/ToySolver/SAT.hs --- a/src/ToySolver/SAT.hs +++ b/src/ToySolver/SAT.hs @@ -1,3621 +1,5 @@ -{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} -{-# LANGUAGE BangPatterns, ScopedTypeVariables, CPP, DeriveDataTypeable, RecursiveDo, MultiParamTypeClasses, InstanceSigs #-} -#ifdef __GLASGOW_HASKELL__ -{-# LANGUAGE UnboxedTuples, MagicHash #-} -#endif ------------------------------------------------------------------------------ --- | --- Module : ToySolver.SAT --- Copyright : (c) Masahiro Sakai 2012-2014 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (BangPatterns, ScopedTypeVariables, CPP, DeriveDataTypeable, RecursiveDo) --- --- A CDCL SAT solver. --- --- It follows the design of MiniSat and SAT4J. --- --- See also: --- --- * --- --- * --- ------------------------------------------------------------------------------ -module ToySolver.SAT - ( - -- * The @Solver@ type - Solver - , newSolver - , newSolverWithConfig - - -- * Basic data structures - , Var - , Lit - , literal - , litNot - , litVar - , litPolarity - , evalLit - - -- * Problem specification - , newVar - , newVars - , newVars_ - , resizeVarCapacity - -- ** Clauses - , AddClause (..) - , Clause - , evalClause - , PackedClause - , packClause - , unpackClause - -- ** Cardinality constraints - , AddCardinality (..) - , AtLeast - , Exactly - , evalAtLeast - , evalExactly - - -- ** (Linear) pseudo-boolean constraints - , AddPBLin (..) - , PBLinTerm - , PBLinSum - , PBLinAtLeast - , PBLinExactly - , evalPBLinSum - , evalPBLinAtLeast - , evalPBLinExactly - -- ** XOR clauses - , AddXORClause (..) - , XORClause - , evalXORClause - -- ** Theory - , setTheory - - -- * Solving - , solve - , solveWith - , BudgetExceeded (..) - , cancel - , Canceled (..) - - -- * Extract results - , IModel (..) - , Model - , getModel - , getFailedAssumptions - , getAssumptionsImplications - - -- * Solver configulation - , module ToySolver.SAT.Config - , getConfig - , setConfig - , modifyConfig - , setVarPolarity - , setLogger - , setRandomGen - , getRandomGen - , setConfBudget - - -- * Read state - , getNVars - , getNConstraints - , getNLearntConstraints - , getVarFixed - , getLitFixed - , getFixedLiterals - - -- * Internal API - , varBumpActivity - , varDecayActivity - ) where - -import Prelude hiding (log) -import Control.Loop -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans -import Control.Monad.Trans.Except -import Control.Exception -#if MIN_VERSION_array(0,5,0) -import Data.Array.IO -#else -import Data.Array.IO hiding (unsafeFreeze) -#endif -import Data.Array.Unsafe (unsafeFreeze) -import Data.Array.Base (unsafeRead, unsafeWrite) -#if MIN_VERSION_hashable(1,2,0) -import Data.Bits (xor) -- for defining 'combine' function -#endif -import Data.Default.Class -import Data.Either -import Data.Function (on) -import Data.Hashable -import Data.HashSet (HashSet) -import qualified Data.HashSet as HashSet -import Data.IORef -import Data.List -import Data.Maybe -import Data.Ord -import qualified Data.IntMap.Strict as IM -import qualified Data.IntSet as IS -import qualified Data.Set as Set -import ToySolver.Internal.Data.IOURef -import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ -import qualified ToySolver.Internal.Data.Vec as Vec -import Data.Typeable -import System.Clock -import qualified System.Random.MWC as Rand -import Text.Printf - -#ifdef __GLASGOW_HASKELL__ -import GHC.Types (IO (..)) -import GHC.Exts hiding (Constraint) -#endif - -import ToySolver.Data.LBool -import ToySolver.SAT.Config -import ToySolver.SAT.Types -import ToySolver.SAT.TheorySolver -import ToySolver.Internal.Util (revMapM) - -{-------------------------------------------------------------------- - internal data structures ---------------------------------------------------------------------} - -type Level = Int - -levelRoot :: Level -levelRoot = 0 - -data VarData - = VarData - { vdPolarity :: !(IORef Bool) - , vdPosLitData :: !LitData - , vdNegLitData :: !LitData - -- | will be invoked once when the variable is assigned - , vdWatches :: !(IORef [SomeConstraintHandler]) - , vdActivity :: !(IOURef VarActivity) - , vdValue :: !(IORef LBool) - , vdTrailIndex :: !(IOURef Int) - , vdLevel :: !(IOURef Level) - , vdReason :: !(IORef (Maybe SomeConstraintHandler)) - , vdOnUnassigned :: !(IORef [SomeConstraintHandler]) - -- | exponential moving average estimate - , vdEMAScaled :: !(IOURef Double) - -- | When v was last assigned - , vdWhenAssigned :: !(IOURef Int) - -- | The number of learnt clauses v participated in generating since Assigned. - , vdParticipated :: !(IOURef Int) - -- | The number of learnt clauses v reasoned in generating since Assigned. - , vdReasoned :: !(IOURef Int) - } - -data LitData - = LitData - { -- | will be invoked when this literal is falsified - ldWatches :: !(IORef [SomeConstraintHandler]) - , ldOccurList :: !(IORef (HashSet SomeConstraintHandler)) - } - -newVarData :: IO VarData -newVarData = do - polarity <- newIORef True - pos <- newLitData - neg <- newLitData - watches <- newIORef [] - activity <- newIOURef 0 - - val <- newIORef lUndef - idx <- newIOURef maxBound - lv <- newIOURef maxBound - reason <- newIORef Nothing - onUnassigned <- newIORef [] - - ema <- newIOURef 0 - whenAssigned <- newIOURef (-1) - participated <- newIOURef 0 - reasoned <- newIOURef 0 - - return $ - VarData - { vdPolarity = polarity - , vdPosLitData = pos - , vdNegLitData = neg - , vdWatches = watches - , vdActivity = activity - , vdValue = val - , vdTrailIndex = idx - , vdLevel = lv - , vdReason = reason - , vdOnUnassigned = onUnassigned - , vdEMAScaled = ema - , vdWhenAssigned = whenAssigned - , vdParticipated = participated - , vdReasoned = reasoned - } - -newLitData :: IO LitData -newLitData = do - ws <- newIORef [] - occ <- newIORef HashSet.empty - return $ LitData ws occ - -varData :: Solver -> Var -> IO VarData -varData solver !v = Vec.unsafeRead (svVarData solver) (v-1) - -litData :: Solver -> Lit -> IO LitData -litData solver !l = - -- litVar による heap allocation を避けるために、 - -- litPolarityによる分岐後にvarDataを呼ぶ。 - if litPolarity l then do - vd <- varData solver l - return $ vdPosLitData vd - else do - vd <- varData solver (negate l) - return $ vdNegLitData vd - -{-# INLINE varValue #-} -varValue :: Solver -> Var -> IO LBool -varValue solver !v = do - vd <- varData solver v - readIORef (vdValue vd) - -{-# INLINE litValue #-} -litValue :: Solver -> Lit -> IO LBool -litValue solver !l = do - -- litVar による heap allocation を避けるために、 - -- litPolarityによる分岐後にvarDataを呼ぶ。 - if litPolarity l then - varValue solver l - else do - m <- varValue solver (negate l) - return $! lnot m - -getVarFixed :: Solver -> Var -> IO LBool -getVarFixed solver !v = do - vd <- varData solver v - lv <- readIOURef (vdLevel vd) - if lv == levelRoot then - readIORef (vdValue vd) - else - return lUndef - -getLitFixed :: Solver -> Lit -> IO LBool -getLitFixed solver !l = do - -- litVar による heap allocation を避けるために、 - -- litPolarityによる分岐後にvarDataを呼ぶ。 - if litPolarity l then - getVarFixed solver l - else do - m <- getVarFixed solver (negate l) - return $! lnot m - -getNFixed :: Solver -> IO Int -getNFixed solver = do - lv <- getDecisionLevel solver - if lv == levelRoot then - Vec.getSize (svTrail solver) - else - Vec.unsafeRead (svTrailLimit solver) 0 - --- | it returns a set of literals that are fixed without any assumptions. -getFixedLiterals :: Solver -> IO [Lit] -getFixedLiterals solver = do - n <- getNFixed solver - revMapM (Vec.unsafeRead (svTrail solver)) [0..n-1] - -varLevel :: Solver -> Var -> IO Level -varLevel solver !v = do - vd <- varData solver v - val <- readIORef (vdValue vd) - when (val == lUndef) $ error ("ToySolver.SAT.varLevel: unassigned var " ++ show v) - readIOURef (vdLevel vd) - -litLevel :: Solver -> Lit -> IO Level -litLevel solver l = varLevel solver (litVar l) - -varReason :: Solver -> Var -> IO (Maybe SomeConstraintHandler) -varReason solver !v = do - vd <- varData solver v - val <- readIORef (vdValue vd) - when (val == lUndef) $ error ("ToySolver.SAT.varReason: unassigned var " ++ show v) - readIORef (vdReason vd) - -varAssignNo :: Solver -> Var -> IO Int -varAssignNo solver !v = do - vd <- varData solver v - val <- readIORef (vdValue vd) - when (val == lUndef) $ error ("ToySolver.SAT.varAssignNo: unassigned var " ++ show v) - readIOURef (vdTrailIndex vd) - --- | Solver instance -data Solver - = Solver - { svOk :: !(IORef Bool) - - , svVarQueue :: !PQ.PriorityQueue - , svTrail :: !(Vec.UVec Lit) - , svTrailLimit :: !(Vec.UVec Lit) - , svTrailNPropagated :: !(IOURef Int) - - , svVarData :: !(Vec.Vec VarData) - , svConstrDB :: !(IORef [SomeConstraintHandler]) - , svLearntDB :: !(IORef (Int,[SomeConstraintHandler])) - - -- Theory - , svTheorySolver :: !(IORef (Maybe TheorySolver)) - , svTheoryChecked :: !(IOURef Int) - - -- Result - , svModel :: !(IORef (Maybe Model)) - , svFailedAssumptions :: !(IORef [Lit]) - , svAssumptionsImplications :: !(IORef LitSet) - - -- Statistics - , svNDecision :: !(IOURef Int) - , svNRandomDecision :: !(IOURef Int) - , svNConflict :: !(IOURef Int) - , svNRestart :: !(IOURef Int) - , svNLearntGC :: !(IOURef Int) - , svNRemovedConstr :: !(IOURef Int) - - -- Configulation - , svConfig :: !(IORef Config) - , svRandomGen :: !(IORef Rand.GenIO) - , svConfBudget :: !(IOURef Int) - - -- Logging - , svLogger :: !(IORef (Maybe (String -> IO ()))) - , svStartWC :: !(IORef TimeSpec) - , svLastStatWC :: !(IORef TimeSpec) - - -- Working spaces - , svCanceled :: !(IORef Bool) - , svAssumptions :: !(Vec.UVec Lit) - , svLearntLim :: !(IORef Int) - , svLearntLimAdjCnt :: !(IORef Int) - , svLearntLimSeq :: !(IORef [(Int,Int)]) - , svSeen :: !(Vec.UVec Bool) - , svPBLearnt :: !(IORef (Maybe PBLinAtLeast)) - - -- | Amount to bump next variable with. - , svVarInc :: !(IOURef Double) - - -- | Amount to bump next constraint with. - , svConstrInc :: !(IOURef Double) - - -- ERWA / LRB - - -- | step-size parameter α - , svERWAStepSize :: !(IOURef Double) - , svEMAScale :: !(IOURef Double) - , svLearntCounter :: !(IOURef Int) - } - -markBad :: Solver -> IO () -markBad solver = do - writeIORef (svOk solver) False - bcpClear solver - -bcpDequeue :: Solver -> IO (Maybe Lit) -bcpDequeue solver = do - n <- Vec.getSize (svTrail solver) - m <- readIOURef (svTrailNPropagated solver) - if m==n then - return Nothing - else do - -- m < n - lit <- Vec.unsafeRead (svTrail solver) m - modifyIOURef (svTrailNPropagated solver) (+1) - return (Just lit) - -bcpIsEmpty :: Solver -> IO Bool -bcpIsEmpty solver = do - p <- readIOURef (svTrailNPropagated solver) - n <- Vec.getSize (svTrail solver) - return $! n == p - -bcpCheckEmpty :: Solver -> IO () -bcpCheckEmpty solver = do - empty <- bcpIsEmpty solver - unless empty $ - error "BUG: BCP Queue should be empty at this point" - -bcpClear :: Solver -> IO () -bcpClear solver = do - m <- Vec.getSize (svTrail solver) - writeIOURef (svTrailNPropagated solver) m - -assignBy :: Solver -> Lit -> SomeConstraintHandler -> IO Bool -assignBy solver lit c = do - lv <- getDecisionLevel solver - let !c2 = if lv == levelRoot - then Nothing - else Just c - assign_ solver lit c2 - -assign :: Solver -> Lit -> IO Bool -assign solver lit = assign_ solver lit Nothing - -assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool -assign_ solver !lit reason = assert (validLit lit) $ do - vd <- varData solver (litVar lit) - let val = liftBool (litPolarity lit) - - val0 <- readIORef (vdValue vd) - if val0 /= lUndef then do - return $ val == val0 - else do - idx <- Vec.getSize (svTrail solver) - lv <- getDecisionLevel solver - - writeIORef (vdValue vd) val - writeIOURef (vdTrailIndex vd) idx - writeIOURef (vdLevel vd) lv - writeIORef (vdReason vd) reason - writeIOURef (vdWhenAssigned vd) =<< readIOURef (svLearntCounter solver) - writeIOURef (vdParticipated vd) 0 - writeIOURef (vdReasoned vd) 0 - - Vec.push (svTrail solver) lit - - when debugMode $ logIO solver $ do - let r = case reason of - Nothing -> "" - Just _ -> " by propagation" - return $ printf "assign(level=%d): %d%s" lv lit r - - return True - -unassign :: Solver -> Var -> IO () -unassign solver !v = assert (validVar v) $ do - vd <- varData solver v - val <- readIORef (vdValue vd) - when (val == lUndef) $ error "unassign: should not happen" - - flag <- configEnablePhaseSaving <$> getConfig solver - when flag $ writeIORef (vdPolarity vd) $! fromJust (unliftBool val) - - writeIORef (vdValue vd) lUndef - writeIOURef (vdTrailIndex vd) maxBound - writeIOURef (vdLevel vd) maxBound - writeIORef (vdReason vd) Nothing - - -- ERWA / LRB computation - interval <- do - t2 <- readIOURef (svLearntCounter solver) - t1 <- readIOURef (vdWhenAssigned vd) - return (t2 - t1) - -- Interval = 0 is possible due to restarts. - when (interval > 0) $ do - participated <- readIOURef (vdParticipated vd) - reasoned <- readIOURef (vdReasoned vd) - alpha <- readIOURef (svERWAStepSize solver) - let learningRate = fromIntegral participated / fromIntegral interval - reasonSideRate = fromIntegral reasoned / fromIntegral interval - scale <- readIOURef (svEMAScale solver) - -- ema := (1 - α)ema + α*r - modifyIOURef (vdEMAScaled vd) $ \orig -> (1 - alpha) * orig + alpha * scale * (learningRate + reasonSideRate) - -- If v is assigned by random decision, it's possible that v is still in the queue. - PQ.update (svVarQueue solver) v - - let !l = if val == lTrue then v else -v - cs <- readIORef (vdOnUnassigned vd) - writeIORef (vdOnUnassigned vd) [] - forM_ cs $ \c -> - constrOnUnassigned solver c c l - - PQ.enqueue (svVarQueue solver) v - -addOnUnassigned :: Solver -> SomeConstraintHandler -> Lit -> IO () -addOnUnassigned solver constr !l = do - vd <- varData solver (litVar l) - val <- readIORef (vdValue vd) - when (val == lUndef) $ error "addOnUnassigned: should not happen" - modifyIORef (vdOnUnassigned vd) (constr :) - --- | Register the constraint to be notified when the literal becames false. -watchLit :: Solver -> Lit -> SomeConstraintHandler -> IO () -watchLit solver !lit c = do - ld <- litData solver lit - modifyIORef (ldWatches ld) (c : ) - --- | Register the constraint to be notified when the variable is assigned. -watchVar :: Solver -> Var -> SomeConstraintHandler -> IO () -watchVar solver !var c = do - vd <- varData solver var - modifyIORef (vdWatches vd) (c : ) - -unwatchLit :: Solver -> Lit -> SomeConstraintHandler -> IO () -unwatchLit solver !lit c = do - ld <- litData solver lit - modifyIORef (ldWatches ld) (delete c) - -unwatchVar :: Solver -> Lit -> SomeConstraintHandler -> IO () -unwatchVar solver !lit c = do - vd <- varData solver lit - modifyIORef (vdWatches vd) (delete c) - -addToDB :: ConstraintHandler c => Solver -> c -> IO () -addToDB solver c = do - let c2 = toConstraintHandler c - modifyIORef (svConstrDB solver) (c2 : ) - when debugMode $ logIO solver $ do - str <- showConstraintHandler c - return $ printf "constraint %s is added" str - - b <- isPBRepresentable c - when b $ do - (lhs,_) <- toPBLinAtLeast c - forM_ lhs $ \(_,lit) -> do - ld <- litData solver lit - modifyIORef' (ldOccurList ld) (HashSet.insert c2) - -addToLearntDB :: ConstraintHandler c => Solver -> c -> IO () -addToLearntDB solver c = do - modifyIORef (svLearntDB solver) $ \(n,xs) -> (n+1, toConstraintHandler c : xs) - when debugMode $ logIO solver $ do - str <- showConstraintHandler c - return $ printf "constraint %s is added" str - -reduceDB :: Solver -> IO () -reduceDB solver = do - (_,cs) <- readIORef (svLearntDB solver) - - xs <- forM cs $ \c -> do - p <- constrIsProtected solver c - w <- constrWeight solver c - actval <- constrReadActivity c - return (c, (p, w*actval)) - - -- Note that False <= True - let ys = sortBy (comparing snd) xs - (zs,ws) = splitAt (length ys `div` 2) ys - - let loop [] ret = return ret - loop ((c,(isShort,_)) : rest) ret = do - flag <- if isShort - then return True - else isLocked solver c - if flag then - loop rest (c:ret) - else do - detach solver c - loop rest ret - zs2 <- loop zs [] - - let cs2 = zs2 ++ map fst ws - n2 = length cs2 - - -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2 - writeIORef (svLearntDB solver) (n2,cs2) - -type VarActivity = Double - -varActivity :: Solver -> Var -> IO VarActivity -varActivity solver !v = do - vd <- varData solver v - readIOURef (vdActivity vd) - -varDecayActivity :: Solver -> IO () -varDecayActivity solver = do - d <- configVarDecay <$> getConfig solver - modifyIOURef (svVarInc solver) (d*) - -varBumpActivity :: Solver -> Var -> IO () -varBumpActivity solver !v = do - inc <- readIOURef (svVarInc solver) - vd <- varData solver v - modifyIOURef (vdActivity vd) (+inc) - conf <- getConfig solver - when (configBranchingStrategy conf == BranchingVSIDS) $ do - PQ.update (svVarQueue solver) v - aval <- readIOURef (vdActivity vd) - when (aval > 1e20) $ - -- Rescale - varRescaleAllActivity solver - -varRescaleAllActivity :: Solver -> IO () -varRescaleAllActivity solver = do - vs <- variables solver - forM_ vs $ \v -> do - vd <- varData solver v - modifyIOURef (vdActivity vd) (* 1e-20) - modifyIOURef (svVarInc solver) (* 1e-20) - -varEMAScaled :: Solver -> Var -> IO Double -varEMAScaled solver v = do - vd <- varData solver v - readIOURef (vdEMAScaled vd) - -varIncrementParticipated :: Solver -> Var -> IO () -varIncrementParticipated solver v = do - vd <- varData solver v - modifyIOURef (vdParticipated vd) (+1) - -varIncrementReasoned :: Solver -> Var -> IO () -varIncrementReasoned solver v = do - vd <- varData solver v - modifyIOURef (vdReasoned vd) (+1) - -varEMADecay :: Solver -> IO () -varEMADecay solver = do - config <- getConfig solver - - alpha <- readIOURef (svERWAStepSize solver) - let alphaMin = configERWAStepSizeMin config - when (alpha > alphaMin) $ do - writeIOURef (svERWAStepSize solver) (max alphaMin (alpha - configERWAStepSizeDec config)) - - case configBranchingStrategy config of - BranchingLRB -> do - modifyIOURef (svEMAScale solver) (configEMADecay config *) - scale <- readIOURef (svEMAScale solver) - when (scale > 1e20) $ do - vs <- variables solver - forM_ vs $ \v -> do - vd <- varData solver v - modifyIOURef (vdEMAScaled vd) (/ scale) - writeIOURef (svEMAScale solver) 1.0 - _ -> return () - -variables :: Solver -> IO [Var] -variables solver = do - n <- getNVars solver - return [1 .. n] - --- | number of variables of the problem. -getNVars :: Solver -> IO Int -getNVars solver = Vec.getSize (svVarData solver) - --- | number of assigned -getNAssigned :: Solver -> IO Int -getNAssigned solver = Vec.getSize (svTrail solver) - --- | number of constraints. -getNConstraints :: Solver -> IO Int -getNConstraints solver = do - xs <- readIORef (svConstrDB solver) - return $ length xs - --- | number of learnt constrints. -getNLearntConstraints :: Solver -> IO Int -getNLearntConstraints solver = do - (n,_) <- readIORef (svLearntDB solver) - return n - -learntConstraints :: Solver -> IO [SomeConstraintHandler] -learntConstraints solver = do - (_,cs) <- readIORef (svLearntDB solver) - return cs - -{-------------------------------------------------------------------- - Solver ---------------------------------------------------------------------} - --- | Create a new 'Solver' instance. -newSolver :: IO Solver -newSolver = newSolverWithConfig def - --- | Create a new 'Solver' instance with a given configulation. -newSolverWithConfig :: Config -> IO Solver -newSolverWithConfig config = do - rec - ok <- newIORef True - trail <- Vec.new - trail_lim <- Vec.new - trail_nprop <- newIOURef 0 - vars <- Vec.new - vqueue <- PQ.newPriorityQueueBy (ltVar solver) - db <- newIORef [] - db2 <- newIORef (0,[]) - as <- Vec.new - m <- newIORef Nothing - canceled <- newIORef False - ndecision <- newIOURef 0 - nranddec <- newIOURef 0 - nconflict <- newIOURef 0 - nrestart <- newIOURef 0 - nlearntgc <- newIOURef 0 - nremoved <- newIOURef 0 - - constrInc <- newIOURef 1 - varInc <- newIOURef 1 - - configRef <- newIORef config - - learntLim <- newIORef undefined - learntLimAdjCnt <- newIORef (-1) - learntLimSeq <- newIORef undefined - - logger <- newIORef Nothing - startWC <- newIORef undefined - lastStatWC <- newIORef undefined - - randgen <- newIORef =<< Rand.create - - failed <- newIORef [] - implied <- newIORef IS.empty - - confBudget <- newIOURef (-1) - - tsolver <- newIORef Nothing - tchecked <- newIOURef 0 - - seen <- Vec.new - pbLearnt <- newIORef Nothing - - alpha <- newIOURef 0.4 - emaScale <- newIOURef 1.0 - learntCounter <- newIOURef 0 - - let solver = - Solver - { svOk = ok - , svVarQueue = vqueue - , svTrail = trail - , svTrailLimit = trail_lim - , svTrailNPropagated = trail_nprop - , svVarData = vars - , svConstrDB = db - , svLearntDB = db2 - - -- Theory - , svTheorySolver = tsolver - , svTheoryChecked = tchecked - - -- Result - , svModel = m - , svFailedAssumptions = failed - , svAssumptionsImplications = implied - - -- Statistics - , svNDecision = ndecision - , svNRandomDecision = nranddec - , svNConflict = nconflict - , svNRestart = nrestart - , svNLearntGC = nlearntgc - , svNRemovedConstr = nremoved - - -- Configulation - , svConfig = configRef - , svRandomGen = randgen - , svConfBudget = confBudget - - -- Logging - , svLogger = logger - , svStartWC = startWC - , svLastStatWC = lastStatWC - - -- Working space - , svCanceled = canceled - , svAssumptions = as - , svLearntLim = learntLim - , svLearntLimAdjCnt = learntLimAdjCnt - , svLearntLimSeq = learntLimSeq - , svVarInc = varInc - , svConstrInc = constrInc - , svSeen = seen - , svPBLearnt = pbLearnt - - , svERWAStepSize = alpha - , svEMAScale = emaScale - , svLearntCounter = learntCounter - } - return solver - -ltVar :: Solver -> Var -> Var -> IO Bool -ltVar solver !v1 !v2 = do - conf <- getConfig solver - case configBranchingStrategy conf of - BranchingVSIDS -> do - a1 <- varActivity solver v1 - a2 <- varActivity solver v2 - return $! a1 > a2 - _ -> do -- BranchingERWA and BranchingLRB - a1 <- varEMAScaled solver v1 - a2 <- varEMAScaled solver v1 - return $! a1 > a2 - -{-------------------------------------------------------------------- - Problem specification ---------------------------------------------------------------------} - -instance NewVar IO Solver where - newVar :: Solver -> IO Var - newVar solver = do - n <- Vec.getSize (svVarData solver) - let v = n + 1 - vd <- newVarData - Vec.push (svVarData solver) vd - PQ.enqueue (svVarQueue solver) v - Vec.push (svSeen solver) False - return v - - newVars :: Solver -> Int -> IO [Var] - newVars solver n = do - nv <- getNVars solver - resizeVarCapacity solver (nv+n) - replicateM n (newVar solver) - - newVars_ :: Solver -> Int -> IO () - newVars_ solver n = do - nv <- getNVars solver - resizeVarCapacity solver (nv+n) - replicateM_ n (newVar solver) - --- |Pre-allocate internal buffer for @n@ variables. -resizeVarCapacity :: Solver -> Int -> IO () -resizeVarCapacity solver n = do - Vec.resizeCapacity (svVarData solver) n - Vec.resizeCapacity (svSeen solver) n - PQ.resizeHeapCapacity (svVarQueue solver) n - PQ.resizeTableCapacity (svVarQueue solver) (n+1) - -instance AddClause IO Solver where - addClause :: Solver -> Clause -> IO () - addClause solver lits = do - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - m <- instantiateClause (getLitFixed solver) lits - case normalizeClause =<< m of - Nothing -> return () - Just [] -> markBad solver - Just [lit] -> do - {- We do not call 'removeBackwardSubsumedBy' here, - because subsumed constraints will be removed by 'simplify'. -} - ret <- assign solver lit - assert ret $ return () - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - Just lits2 -> do - subsumed <- checkForwardSubsumption solver lits - unless subsumed $ do - removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits2], 1) - clause <- newClauseHandler lits2 False - addToDB solver clause - _ <- basicAttachClauseHandler solver clause - return () - -instance AddCardinality IO Solver where - addAtLeast :: Solver -> [Lit] -> Int -> IO () - addAtLeast solver lits n = do - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - (lits',n') <- liftM normalizeAtLeast $ instantiateAtLeast (getLitFixed solver) (lits,n) - let len = length lits' - - if n' <= 0 then return () - else if n' > len then markBad solver - else if n' == 1 then addClause solver lits' - else if n' == len then do - {- We do not call 'removeBackwardSubsumedBy' here, - because subsumed constraints will be removed by 'simplify'. -} - forM_ lits' $ \l -> do - ret <- assign solver l - assert ret $ return () - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - else do -- n' < len - removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits'], fromIntegral n') - c <- newAtLeastHandler lits' n' False - addToDB solver c - _ <- basicAttachAtLeastHandler solver c - return () - -instance AddPBLin IO Solver where - addPBAtLeast :: Solver -> PBLinSum -> Integer -> IO () - addPBAtLeast solver ts n = do - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - (ts',n') <- liftM normalizePBLinAtLeast $ instantiatePBLinAtLeast (getLitFixed solver) (ts,n) - - case pbToAtLeast (ts',n') of - Just (lhs',rhs') -> addAtLeast solver lhs' rhs' - Nothing -> do - let cs = map fst ts' - slack = sum cs - n' - if n' <= 0 then return () - else if slack < 0 then markBad solver - else do - removeBackwardSubsumedBy solver (ts', n') - (ts'',n'') <- do - b <- configEnablePBSplitClausePart <$> getConfig solver - if b - then pbSplitClausePart solver (ts',n') - else return (ts',n') - - c <- newPBHandler solver ts'' n'' False - let constr = toConstraintHandler c - addToDB solver constr - ret <- attach solver constr - if not ret then do - markBad solver - else do - ret2 <- deduce solver - case ret2 of - Nothing -> return () - Just _ -> markBad solver - - addPBExactly :: Solver -> PBLinSum -> Integer -> IO () - addPBExactly solver ts n = do - (ts2,n2) <- liftM normalizePBLinExactly $ instantiatePBLinExactly (getLitFixed solver) (ts,n) - addPBAtLeast solver ts2 n2 - addPBAtMost solver ts2 n2 - - addPBAtLeastSoft :: Solver -> Lit -> PBLinSum -> Integer -> IO () - addPBAtLeastSoft solver sel lhs rhs = do - (lhs', rhs') <- liftM normalizePBLinAtLeast $ instantiatePBLinAtLeast (getLitFixed solver) (lhs,rhs) - addPBAtLeast solver ((rhs', litNot sel) : lhs') rhs' - - addPBExactlySoft :: Solver -> Lit -> PBLinSum -> Integer -> IO () - addPBExactlySoft solver sel lhs rhs = do - (lhs2, rhs2) <- liftM normalizePBLinExactly $ instantiatePBLinExactly (getLitFixed solver) (lhs,rhs) - addPBAtLeastSoft solver sel lhs2 rhs2 - addPBAtMostSoft solver sel lhs2 rhs2 - --- | See documentation of 'setPBSplitClausePart'. -pbSplitClausePart :: Solver -> PBLinAtLeast -> IO PBLinAtLeast -pbSplitClausePart solver (lhs,rhs) = do - let (ts1,ts2) = partition (\(c,_) -> c >= rhs) lhs - if length ts1 < 2 then - return (lhs,rhs) - else do - sel <- newVar solver - addClause solver $ -sel : [l | (_,l) <- ts1] - return ((rhs,sel) : ts2, rhs) - -instance AddXORClause IO Solver where - addXORClause :: Solver -> [Lit] -> Bool -> IO () - addXORClause solver lits rhs = do - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - ok <- readIORef (svOk solver) - when ok $ do - xcl <- instantiateXORClause (getLitFixed solver) (lits,rhs) - case normalizeXORClause xcl of - ([], True) -> markBad solver - ([], False) -> return () - ([l], b) -> addClause solver [if b then l else litNot l] - (l:ls, b) -> do - c <- newXORClauseHandler ((if b then l else litNot l) : ls) False - addToDB solver c - _ <- basicAttachXORClauseHandler solver c - return () - -{-------------------------------------------------------------------- - Problem solving ---------------------------------------------------------------------} - --- | Solve constraints. --- Returns 'True' if the problem is SATISFIABLE. --- Returns 'False' if the problem is UNSATISFIABLE. -solve :: Solver -> IO Bool -solve solver = do - Vec.clear (svAssumptions solver) - solve_ solver - --- | Solve constraints under assuptions. --- Returns 'True' if the problem is SATISFIABLE. --- Returns 'False' if the problem is UNSATISFIABLE. -solveWith :: Solver - -> [Lit] -- ^ Assumptions - -> IO Bool -solveWith solver ls = do - Vec.clear (svAssumptions solver) - mapM_ (Vec.push (svAssumptions solver)) ls - solve_ solver - -solve_ :: Solver -> IO Bool -solve_ solver = do - config <- getConfig solver - writeIORef (svAssumptionsImplications solver) IS.empty - - log solver "Solving starts ..." - resetStat solver - writeIORef (svCanceled solver) False - writeIORef (svModel solver) Nothing - writeIORef (svFailedAssumptions solver) [] - - ok <- readIORef (svOk solver) - if not ok then - return False - else do - when debugMode $ dumpVarActivity solver - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - nv <- getNVars solver - Vec.resizeCapacity (svTrail solver) nv - - unless (configRestartInc config > 1) $ error "RestartInc must be >1" - let restartSeq = - if configRestartFirst config > 0 - then mkRestartSeq (configRestartStrategy config) (configRestartFirst config) (configRestartInc config) - else repeat 0 - - let learntSizeAdj = do - (size,adj) <- shift (svLearntLimSeq solver) - writeIORef (svLearntLim solver) size - writeIORef (svLearntLimAdjCnt solver) adj - onConflict = do - cnt <- readIORef (svLearntLimAdjCnt solver) - if (cnt==0) - then learntSizeAdj - else writeIORef (svLearntLimAdjCnt solver) $! cnt-1 - - cnt <- readIORef (svLearntLimAdjCnt solver) - when (cnt == -1) $ do - unless (configLearntSizeInc config > 1) $ error "LearntSizeInc must be >1" - nc <- getNConstraints solver - let initialLearntLim = if configLearntSizeFirst config > 0 then configLearntSizeFirst config else max ((nc + nv) `div` 3) 16 - learntSizeSeq = iterate (ceiling . (configLearntSizeInc config *) . fromIntegral) initialLearntLim - learntSizeAdjSeq = iterate (\x -> (x * 3) `div` 2) (100::Int) - writeIORef (svLearntLimSeq solver) (zip learntSizeSeq learntSizeAdjSeq) - learntSizeAdj - - unless (0 <= configERWAStepSizeFirst config && configERWAStepSizeFirst config <= 1) $ - error "ERWAStepSizeFirst must be in [0..1]" - unless (0 <= configERWAStepSizeMin config && configERWAStepSizeFirst config <= 1) $ - error "ERWAStepSizeMin must be in [0..1]" - unless (0 <= configERWAStepSizeDec config) $ - error "ERWAStepSizeDec must be >=0" - writeIOURef (svERWAStepSize solver) (configERWAStepSizeFirst config) - - let loop [] = error "solve_: should not happen" - loop (conflict_lim:rs) = do - printStat solver True - ret <- search solver conflict_lim onConflict - case ret of - SRFinished x -> return $ Right x - SRBudgetExceeded -> return $ Left (throw BudgetExceeded) - SRCanceled -> return $ Left (throw Canceled) - SRRestart -> do - modifyIOURef (svNRestart solver) (+1) - backtrackTo solver levelRoot - loop rs - - printStatHeader solver - - startCPU <- getTime ProcessCPUTime - startWC <- getTime Monotonic - writeIORef (svStartWC solver) startWC - result <- loop restartSeq - endCPU <- getTime ProcessCPUTime - endWC <- getTime Monotonic - - case result of - Right True -> do - when (configCheckModel config) $ checkSatisfied solver - constructModel solver - mt <- getTheory solver - case mt of - Nothing -> return () - Just t -> thConstructModel t - _ -> return () - case result of - Right False -> return () - _ -> saveAssumptionsImplications solver - - backtrackTo solver levelRoot - - when debugMode $ dumpVarActivity solver - when debugMode $ dumpConstrActivity solver - printStat solver True - let durationSecs :: TimeSpec -> TimeSpec -> Double - durationSecs start end = fromIntegral (toNanoSecs (end `diffTimeSpec` start)) / 10^(9::Int) - (log solver . printf "#cpu_time = %.3fs") (durationSecs startCPU endCPU) - (log solver . printf "#wall_clock_time = %.3fs") (durationSecs startWC endWC) - (log solver . printf "#decision = %d") =<< readIOURef (svNDecision solver) - (log solver . printf "#random_decision = %d") =<< readIOURef (svNRandomDecision solver) - (log solver . printf "#conflict = %d") =<< readIOURef (svNConflict solver) - (log solver . printf "#restart = %d") =<< readIOURef (svNRestart solver) - - case result of - Right x -> return x - Left m -> m - -data BudgetExceeded = BudgetExceeded - deriving (Show, Typeable) - -instance Exception BudgetExceeded - -data Canceled = Canceled - deriving (Show, Typeable) - -instance Exception Canceled - -data SearchResult - = SRFinished Bool - | SRRestart - | SRBudgetExceeded - | SRCanceled - -search :: Solver -> Int -> IO () -> IO SearchResult -search solver !conflict_lim onConflict = do - conflictCounter <- newIORef 0 - let - loop :: IO SearchResult - loop = do - conflict <- deduce solver - case conflict of - Just constr -> do - ret <- handleConflict conflictCounter constr - case ret of - Just sr -> return sr - Nothing -> loop - Nothing -> do - lv <- getDecisionLevel solver - when (lv == levelRoot) $ simplify solver - checkGC - r <- pickAssumption - case r of - Nothing -> return (SRFinished False) - Just lit - | lit /= litUndef -> decide solver lit >> loop - | otherwise -> do - lit2 <- pickBranchLit solver - if lit2 == litUndef - then return (SRFinished True) - else decide solver lit2 >> loop - loop - - where - checkGC :: IO () - checkGC = do - n <- getNLearntConstraints solver - m <- getNAssigned solver - learnt_lim <- readIORef (svLearntLim solver) - when (learnt_lim >= 0 && n - m > learnt_lim) $ do - modifyIOURef (svNLearntGC solver) (+1) - reduceDB solver - - pickAssumption :: IO (Maybe Lit) - pickAssumption = do - s <- Vec.getSize (svAssumptions solver) - let go = do - d <- getDecisionLevel solver - if not (d < s) then - return (Just litUndef) - else do - l <- Vec.unsafeRead (svAssumptions solver) d - val <- litValue solver l - if val == lTrue then do - -- dummy decision level - pushDecisionLevel solver - go - else if val == lFalse then do - -- conflict with assumption - core <- analyzeFinal solver l - writeIORef (svFailedAssumptions solver) core - return Nothing - else - return (Just l) - go - - handleConflict :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) - handleConflict conflictCounter constr = do - varEMADecay solver - varDecayActivity solver - constrDecayActivity solver - onConflict - - modifyIOURef (svNConflict solver) (+1) - d <- getDecisionLevel solver - - when debugMode $ logIO solver $ do - str <- showConstraintHandler constr - return $ printf "conflict(level=%d): %s" d str - - modifyIORef' conflictCounter (+1) - c <- readIORef conflictCounter - - modifyIOURef (svConfBudget solver) $ \confBudget -> - if confBudget > 0 then confBudget - 1 else confBudget - confBudget <- readIOURef (svConfBudget solver) - canceled <- readIORef (svCanceled solver) - - when (c `mod` 100 == 0) $ do - printStat solver False - - if d == levelRoot then do - markBad solver - return $ Just (SRFinished False) - else if confBudget==0 then - return $ Just SRBudgetExceeded - else if canceled then - return $ Just SRCanceled - else if conflict_lim > 0 && c >= conflict_lim then - return $ Just SRRestart - else do - modifyIOURef (svLearntCounter solver) (+1) - config <- getConfig solver - case configLearningStrategy config of - LearningClause -> learnClause constr >> return Nothing - LearningHybrid -> learnHybrid conflictCounter constr - - learnClause :: SomeConstraintHandler -> IO () - learnClause constr = do - (learntClause, level) <- analyzeConflict solver constr - backtrackTo solver level - case learntClause of - [] -> error "search(LearningClause): should not happen" - [lit] -> do - ret <- assign solver lit - assert ret $ return () - return () - lit:_ -> do - cl <- newClauseHandler learntClause True - let constr = toConstraintHandler cl - addToLearntDB solver constr - basicAttachClauseHandler solver cl - assignBy solver lit constr - constrBumpActivity solver constr - - learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) - learnHybrid conflictCounter constr = do - (learntClause, clauseLevel) <- analyzeConflict solver constr - (pb, minLevel) <- do - z <- readIORef (svPBLearnt solver) - case z of - Nothing -> return (z, clauseLevel) - Just pb -> do - pbLevel <- pbBacktrackLevel solver pb - return (z, min clauseLevel pbLevel) - backtrackTo solver minLevel - - case learntClause of - [] -> error "search(LearningHybrid): should not happen" - [lit] -> do - _ <- assign solver lit -- This should always succeed. - return () - lit:_ -> do - cl <- newClauseHandler learntClause True - let constr = toConstraintHandler cl - addToLearntDB solver constr - basicAttachClauseHandler solver cl - constrBumpActivity solver constr - when (minLevel == clauseLevel) $ do - _ <- assignBy solver lit constr -- This should always succeed. - return () - - ret <- deduce solver - case ret of - Just conflicted -> do - handleConflict conflictCounter conflicted - -- TODO: should also learn the PB constraint? - Nothing -> do - case pb of - Nothing -> return Nothing - Just (lhs,rhs) -> do - h <- newPBHandlerPromoted solver lhs rhs True - case h of - CHClause _ -> do - {- We don't want to add additional clause, - since it would be subsumed by already added one. -} - return Nothing - _ -> do - addToLearntDB solver h - ret2 <- attach solver h - constrBumpActivity solver h - if ret2 then - return Nothing - else - handleConflict conflictCounter h - --- | Cancel exectution of 'solve' or 'solveWith'. --- --- This can be called from other threads. -cancel :: Solver -> IO () -cancel solver = writeIORef (svCanceled solver) True - --- | After 'solve' returns True, it returns an satisfying assignment. -getModel :: Solver -> IO Model -getModel solver = do - m <- readIORef (svModel solver) - return (fromJust m) - --- | After 'solveWith' returns False, it returns a set of assumptions --- that leads to contradiction. In particular, if it returns an empty --- set, the problem is unsatisiable without any assumptions. -getFailedAssumptions :: Solver -> IO [Lit] -getFailedAssumptions solver = readIORef (svFailedAssumptions solver) - --- | __EXPERIMENTAL API__: After 'solveWith' returns True or failed with 'BudgetExceeded' exception, --- it returns a set of literals that are implied by assumptions. -getAssumptionsImplications :: Solver -> IO [Lit] -getAssumptionsImplications solver = liftM IS.toList $ readIORef (svAssumptionsImplications solver) - -{-------------------------------------------------------------------- - Simplification ---------------------------------------------------------------------} - --- | Simplify the constraint database according to the current top-level assigment. -simplify :: Solver -> IO () -simplify solver = do - let loop [] rs !n = return (rs,n) - loop (y:ys) rs !n = do - b1 <- isSatisfied solver y - b2 <- isLocked solver y - if b1 && not b2 then do - detach solver y - loop ys rs (n+1) - else loop ys (y:rs) n - - -- simplify original constraint DB - do - xs <- readIORef (svConstrDB solver) - (ys,n) <- loop xs [] (0::Int) - modifyIOURef (svNRemovedConstr solver) (+n) - writeIORef (svConstrDB solver) ys - - -- simplify learnt constraint DB - do - (m,xs) <- readIORef (svLearntDB solver) - (ys,n) <- loop xs [] (0::Int) - writeIORef (svLearntDB solver) (m-n, ys) - -{- -References: -L. Zhang, "On subsumption removal and On-the-Fly CNF simplification," -Theory and Applications of Satisfiability Testing (2005), pp. 482-489. --} - -checkForwardSubsumption :: Solver -> Clause -> IO Bool -checkForwardSubsumption solver lits = do - flag <- configEnableForwardSubsumptionRemoval <$> getConfig solver - if not flag then - return False - else do - withEnablePhaseSaving solver False $ do - bracket_ - (pushDecisionLevel solver) - (backtrackTo solver levelRoot) $ do - b <- allM (\lit -> assign solver (litNot lit)) lits - if b then - liftM isJust (deduce solver) - else do - when debugMode $ log solver ("forward subsumption: " ++ show lits) - return True - where - withEnablePhaseSaving solver flag m = - bracket - (getConfig solver) - (\saved -> modifyConfig solver (\config -> config{ configEnablePhaseSaving = configEnablePhaseSaving saved })) - (\saved -> setConfig solver saved{ configEnablePhaseSaving = flag } >> m) - -removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO () -removeBackwardSubsumedBy solver pb = do - flag <- configEnableBackwardSubsumptionRemoval <$> getConfig solver - when flag $ do - xs <- backwardSubsumedBy solver pb - when debugMode $ do - forM_ (HashSet.toList xs) $ \c -> do - s <- showConstraintHandler c - log solver (printf "backward subsumption: %s is subsumed by %s\n" s (show pb)) - removeConstraintHandlers solver xs - -backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler) -backwardSubsumedBy solver pb@(lhs,_) = do - xs <- forM lhs $ \(_,lit) -> do - ld <- litData solver lit - readIORef (ldOccurList ld) - case xs of - [] -> return HashSet.empty - s:ss -> do - let p c = do - -- Note that @isPBRepresentable c@ is always True here, - -- because only such constraints are added to occur list. - -- See 'addToDB'. - pb2 <- instantiatePBLinAtLeast (getLitFixed solver) =<< toPBLinAtLeast c - return $ pbLinSubsume pb pb2 - liftM HashSet.fromList - $ filterM p - $ HashSet.toList - $ foldl' HashSet.intersection s ss - -removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO () -removeConstraintHandlers _ zs | HashSet.null zs = return () -removeConstraintHandlers solver zs = do - let loop [] rs !n = return (rs,n) - loop (c:cs) rs !n = do - if c `HashSet.member` zs then do - detach solver c - loop cs rs (n+1) - else loop cs (c:rs) n - xs <- readIORef (svConstrDB solver) - (ys,n) <- loop xs [] (0::Int) - modifyIOURef (svNRemovedConstr solver) (+n) - writeIORef (svConstrDB solver) ys - -{-------------------------------------------------------------------- - Parameter settings. ---------------------------------------------------------------------} - -{-------------------------------------------------------------------- - Configulation ---------------------------------------------------------------------} - -getConfig :: Solver -> IO Config -getConfig solver = readIORef $ svConfig solver - -setConfig :: Solver -> Config -> IO () -setConfig solver conf = do - orig <- getConfig solver - writeIORef (svConfig solver) conf - when (configBranchingStrategy orig /= configBranchingStrategy conf) $ do - PQ.rebuild (svVarQueue solver) - -modifyConfig :: Solver -> (Config -> Config) -> IO () -modifyConfig solver f = do - config <- getConfig solver - setConfig solver $ f config - --- | The default polarity of a variable. -setVarPolarity :: Solver -> Var -> Bool -> IO () -setVarPolarity solver v val = do - vd <- varData solver v - writeIORef (vdPolarity vd) val - --- | Set random generator used by the random variable selection -setRandomGen :: Solver -> Rand.GenIO -> IO () -setRandomGen solver = writeIORef (svRandomGen solver) - --- | Get random generator used by the random variable selection -getRandomGen :: Solver -> IO Rand.GenIO -getRandomGen solver = readIORef (svRandomGen solver) - -setConfBudget :: Solver -> Maybe Int -> IO () -setConfBudget solver (Just b) | b >= 0 = writeIOURef (svConfBudget solver) b -setConfBudget solver _ = writeIOURef (svConfBudget solver) (-1) - -{-------------------------------------------------------------------- - API for implementation of @solve@ ---------------------------------------------------------------------} - -pickBranchLit :: Solver -> IO Lit -pickBranchLit !solver = do - gen <- readIORef (svRandomGen solver) - let vqueue = svVarQueue solver - !randfreq <- configRandomFreq <$> getConfig solver - !size <- PQ.queueSize vqueue - -- System.Random.random produces [0,1), but System.Random.MWC.uniform produces (0,1] - !r <- liftM (1 -) $ Rand.uniform gen - var <- - if (r < randfreq && size >= 2) then do - a <- PQ.getHeapArray vqueue - i <- Rand.uniformR (0, size-1) gen - var <- readArray a i - val <- varValue solver var - if val == lUndef then do - modifyIOURef (svNRandomDecision solver) (1+) - return var - else return litUndef - else - return litUndef - - -- Activity based decision - let loop :: IO Var - loop = do - m <- PQ.dequeue vqueue - case m of - Nothing -> return litUndef - Just var2 -> do - val2 <- varValue solver var2 - if val2 /= lUndef - then loop - else return var2 - var2 <- - if var==litUndef - then loop - else return var - - if var2==litUndef then - return litUndef - else do - vd <- varData solver var2 - -- TODO: random polarity - p <- readIORef (vdPolarity vd) - return $! literal var2 p - -decide :: Solver -> Lit -> IO () -decide solver !lit = do - modifyIOURef (svNDecision solver) (+1) - pushDecisionLevel solver - when debugMode $ do - val <- litValue solver lit - when (val /= lUndef) $ error "decide: should not happen" - assign solver lit - return () - -deduce :: Solver -> IO (Maybe SomeConstraintHandler) -deduce solver = liftM (either Just (const Nothing)) $ runExceptT $ do - let loop = do - deduceB solver - deduceT solver - empty <- liftIO $ bcpIsEmpty solver - unless empty $ loop - loop - -deduceB :: Solver -> ExceptT SomeConstraintHandler IO () -deduceB solver = loop - where - loop :: ExceptT SomeConstraintHandler IO () - loop = do - r <- liftIO $ bcpDequeue solver - case r of - Nothing -> return () - Just lit -> do - processLit lit - processVar lit - loop - - processLit :: Lit -> ExceptT SomeConstraintHandler IO () - processLit !lit = ExceptT $ liftM (maybe (Right ()) Left) $ do - let falsifiedLit = - litNot lit - ld <- litData solver falsifiedLit - let wsref = ldWatches ld - let loop2 [] = return Nothing - loop2 (w:ws) = do - ok <- propagate solver w falsifiedLit - if ok then - loop2 ws - else do - modifyIORef wsref (++ws) - return (Just w) - ws <- readIORef wsref - writeIORef wsref [] - loop2 ws - - processVar :: Lit -> ExceptT SomeConstraintHandler IO () - processVar !lit = ExceptT $ liftM (maybe (Right ()) Left) $ do - let falsifiedLit = litNot lit - vd <- varData solver (litVar lit) - let wsref = vdWatches vd - let loop2 [] = return Nothing - loop2 (w:ws) = do - ok <- propagate solver w falsifiedLit - if ok - then loop2 ws - else do - modifyIORef wsref (++ws) - return (Just w) - ws <- readIORef wsref - writeIORef wsref [] - loop2 ws - -analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level) -analyzeConflict solver constr = do - config <- getConfig solver - let isHybrid = configLearningStrategy config == LearningHybrid - - d <- getDecisionLevel solver - (out :: Vec.UVec Lit) <- Vec.new - Vec.push out 0 -- (leave room for the asserting literal) - (pathC :: IOURef Int) <- newIOURef 0 - - pbConstrRef <- newIORef undefined - - let f lits = do - forM_ lits $ \lit -> do - let !v = litVar lit - lv <- litLevel solver lit - b <- Vec.unsafeRead (svSeen solver) (v - 1) - when (not b && lv > levelRoot) $ do - varBumpActivity solver v - varIncrementParticipated solver v - if lv >= d then do - Vec.unsafeWrite (svSeen solver) (v - 1) True - modifyIOURef pathC (+1) - else do - Vec.push out lit - - processLitHybrid pb constr lit getLits = do - pb2 <- do - let clausePB = do - lits <- getLits - return $ clauseToPBLinAtLeast (lit : lits) - b <- isPBRepresentable constr - if not b then do - clausePB - else do - pb2 <- toPBLinAtLeast constr - o <- pbOverSAT solver pb2 - if o then do - clausePB - else - return pb2 - let pb3 = cutResolve pb pb2 (litVar lit) - ls = IS.fromList [l | (_,l) <- fst pb3] - seq ls $ writeIORef pbConstrRef (ls, pb3) - - popUnseen = do - l <- peekTrail solver - let !v = litVar l - b <- Vec.unsafeRead (svSeen solver) (v - 1) - if b then do - return () - else do - when isHybrid $ do - (ls, pb) <- readIORef pbConstrRef - when (litNot l `IS.member` ls) $ do - Just constr <- varReason solver v - processLitHybrid pb constr l (reasonOf solver constr (Just l)) - popTrail solver - popUnseen - - loop = do - popUnseen - l <- peekTrail solver - let !v = litVar l - Vec.unsafeWrite (svSeen solver) (v - 1) False - modifyIOURef pathC (subtract 1) - c <- readIOURef pathC - if c > 0 then do - Just constr <- varReason solver v - constrBumpActivity solver constr - lits <- reasonOf solver constr (Just l) - f lits - when isHybrid $ do - (ls, pb) <- readIORef pbConstrRef - when (litNot l `IS.member` ls) $ do - processLitHybrid pb constr l (return lits) - popTrail solver - loop - else do - Vec.unsafeWrite out 0 (litNot l) - - constrBumpActivity solver constr - falsifiedLits <- reasonOf solver constr Nothing - f falsifiedLits - when isHybrid $ do - pb <- do - b <- isPBRepresentable constr - if b then - toPBLinAtLeast constr - else - return (clauseToPBLinAtLeast falsifiedLits) - let ls = IS.fromList [l | (_,l) <- fst pb] - seq ls $ writeIORef pbConstrRef (ls, pb) - loop - lits <- liftM IS.fromList $ Vec.getElems out - - lits2 <- minimizeConflictClause solver lits - - incrementReasoned solver (IS.toList lits2) - - xs <- liftM (sortBy (flip (comparing snd))) $ - forM (IS.toList lits2) $ \l -> do - lv <- litLevel solver l - return (l,lv) - - when isHybrid $ do - (_, pb) <- readIORef pbConstrRef - case pbToClause pb of - Just _ -> writeIORef (svPBLearnt solver) Nothing - Nothing -> writeIORef (svPBLearnt solver) (Just pb) - - let level = case xs of - [] -> error "analyzeConflict: should not happen" - [_] -> levelRoot - _:(_,lv):_ -> lv - return (map fst xs, level) - --- { p } ∪ { pにfalseを割り当てる原因のassumption } -analyzeFinal :: Solver -> Lit -> IO [Lit] -analyzeFinal solver p = do - let go :: Int -> VarSet -> [Lit] -> IO [Lit] - go i seen result - | i < 0 = return result - | otherwise = do - l <- Vec.unsafeRead (svTrail solver) i - lv <- litLevel solver l - if lv == levelRoot then - return result - else if litVar l `IS.member` seen then do - r <- varReason solver (litVar l) - case r of - Nothing -> do - let seen' = IS.delete (litVar l) seen - go (i-1) seen' (l : result) - Just constr -> do - c <- reasonOf solver constr (Just l) - let seen' = IS.delete (litVar l) seen `IS.union` IS.fromList [litVar l2 | l2 <- c] - go (i-1) seen' result - else - go (i-1) seen result - n <- Vec.getSize (svTrail solver) - go (n-1) (IS.singleton (litVar p)) [p] - -pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level -pbBacktrackLevel _ ([], rhs) = assert (rhs > 0) $ return levelRoot -pbBacktrackLevel solver (lhs, rhs) = do - levelToLiterals <- liftM (IM.unionsWith IM.union) $ forM lhs $ \(c,lit) -> do - val <- litValue solver lit - if val /= lUndef then do - level <- litLevel solver lit - return $ IM.singleton level (IM.singleton lit (c,val)) - else - return $ IM.singleton maxBound (IM.singleton lit (c,val)) - - let replay [] !_ = error "pbBacktrackLevel: should not happen" - replay ((lv,lv_lits) : lvs) !slack = do - let slack_lv = slack - sum [c | (_,(c,val)) <- IM.toList lv_lits, val == lFalse] - if slack_lv < 0 then - return lv -- CONFLICT - else if any (\(_, lits2) -> any (\(c,_) -> c > slack_lv) (IM.elems lits2)) lvs then - return lv -- UNIT - else - replay lvs slack_lv - - let initial_slack = sum [c | (c,_) <- lhs] - rhs - if any (\(c,_) -> c > initial_slack) lhs then - return 0 - else do - replay (IM.toList levelToLiterals) initial_slack - -minimizeConflictClause :: Solver -> LitSet -> IO LitSet -minimizeConflictClause solver lits = do - ccmin <- configCCMin <$> getConfig solver - if ccmin >= 2 then - minimizeConflictClauseRecursive solver lits - else if ccmin >= 1 then - minimizeConflictClauseLocal solver lits - else - return lits - -minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet -minimizeConflictClauseLocal solver lits = do - let xs = IS.toAscList lits - ys <- filterM (liftM not . isRedundant) xs - when debugMode $ do - log solver "minimizeConflictClauseLocal:" - log solver $ show xs - log solver $ show ys - return $ IS.fromAscList $ ys - - where - isRedundant :: Lit -> IO Bool - isRedundant lit = do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls <- reasonOf solver c2 (Just (litNot lit)) - allM test ls - - test :: Lit -> IO Bool - test lit = do - lv <- litLevel solver lit - return $ lv == levelRoot || lit `IS.member` lits - -minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet -minimizeConflictClauseRecursive solver lits = do - let - isRedundant :: Lit -> IO Bool - isRedundant lit = do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls <- reasonOf solver c2 (Just (litNot lit)) - go ls IS.empty - - go :: [Lit] -> IS.IntSet -> IO Bool - go [] _ = return True - go (lit : ls) seen = do - lv <- litLevel solver lit - if lv == levelRoot || lit `IS.member` lits || lit `IS.member` seen then - go ls seen - else do - c <- varReason solver (litVar lit) - case c of - Nothing -> return False - Just c2 -> do - ls2 <- reasonOf solver c2 (Just (litNot lit)) - go (ls2 ++ ls) (IS.insert lit seen) - - let xs = IS.toAscList lits - ys <- filterM (liftM not . isRedundant) xs - when debugMode $ do - log solver "minimizeConflictClauseRecursive:" - log solver $ show xs - log solver $ show ys - return $ IS.fromAscList $ ys - -incrementReasoned :: Solver -> Clause -> IO () -incrementReasoned solver ls = do - let f reasonSided l = do - m <- varReason solver (litVar l) - case m of - Nothing -> return reasonSided - Just constr -> do - v <- litValue solver l - unless (v == lFalse) undefined - xs <- constrReasonOf solver constr (Just (litNot l)) - return $ reasonSided `IS.union` IS.fromList (map litVar xs) - reasonSided <- foldM f IS.empty ls - mapM_ (varIncrementReasoned solver) (IS.toList reasonSided) - -peekTrail :: Solver -> IO Lit -peekTrail solver = do - n <- Vec.getSize (svTrail solver) - Vec.unsafeRead (svTrail solver) (n-1) - -popTrail :: Solver -> IO Lit -popTrail solver = do - l <- Vec.unsafePop (svTrail solver) - unassign solver (litVar l) - return l - -getDecisionLevel ::Solver -> IO Int -getDecisionLevel solver = Vec.getSize (svTrailLimit solver) - -pushDecisionLevel :: Solver -> IO () -pushDecisionLevel solver = do - Vec.push (svTrailLimit solver) =<< Vec.getSize (svTrail solver) - mt <- getTheory solver - case mt of - Nothing -> return () - Just t -> thPushBacktrackPoint t - -popDecisionLevel :: Solver -> IO () -popDecisionLevel solver = do - n <- Vec.unsafePop (svTrailLimit solver) - let loop = do - m <- Vec.getSize (svTrail solver) - when (m > n) $ do - popTrail solver - loop - loop - mt <- getTheory solver - case mt of - Nothing -> return () - Just t -> thPopBacktrackPoint t - --- | Revert to the state at given level --- (keeping all assignment at @level@ but not beyond). -backtrackTo :: Solver -> Int -> IO () -backtrackTo solver level = do - when debugMode $ log solver $ printf "backtrackTo: %d" level - loop - bcpClear solver - mt <- getTheory solver - case mt of - Nothing -> return () - Just _ -> do - n <- Vec.getSize (svTrail solver) - writeIOURef (svTheoryChecked solver) n - where - loop :: IO () - loop = do - lv <- getDecisionLevel solver - when (lv > level) $ do - popDecisionLevel solver - loop - -constructModel :: Solver -> IO () -constructModel solver = do - n <- getNVars solver - (marr::IOUArray Var Bool) <- newArray_ (1,n) - forLoop 1 (<=n) (+1) $ \v -> do - vd <- varData solver v - val <- readIORef (vdValue vd) - writeArray marr v (fromJust (unliftBool val)) - m <- unsafeFreeze marr - writeIORef (svModel solver) (Just m) - -saveAssumptionsImplications :: Solver -> IO () -saveAssumptionsImplications solver = do - n <- Vec.getSize (svAssumptions solver) - lv <- getDecisionLevel solver - - lim_beg <- - if lv == 0 then - return 0 - else - Vec.read (svTrailLimit solver) 0 - lim_end <- - if lv > n then - Vec.read (svTrailLimit solver) n - else - Vec.getSize (svTrail solver) - - let ref = svAssumptionsImplications solver - forM_ [lim_beg .. lim_end-1] $ \i -> do - lit <- Vec.read (svTrail solver) i - modifyIORef' ref (IS.insert lit) - forM_ [0..n-1] $ \i -> do - lit <- Vec.read (svAssumptions solver) i - modifyIORef' ref (IS.delete lit) - -constrDecayActivity :: Solver -> IO () -constrDecayActivity solver = do - d <- configConstrDecay <$> getConfig solver - modifyIOURef (svConstrInc solver) (d*) - -constrBumpActivity :: ConstraintHandler a => Solver -> a -> IO () -constrBumpActivity solver this = do - aval <- constrReadActivity this - when (aval >= 0) $ do -- learnt clause - inc <- readIOURef (svConstrInc solver) - let aval2 = aval+inc - constrWriteActivity this $! aval2 - when (aval2 > 1e20) $ - -- Rescale - constrRescaleAllActivity solver - -constrRescaleAllActivity :: Solver -> IO () -constrRescaleAllActivity solver = do - xs <- learntConstraints solver - forM_ xs $ \c -> do - aval <- constrReadActivity c - when (aval >= 0) $ - constrWriteActivity c $! (aval * 1e-20) - modifyIOURef (svConstrInc solver) (* 1e-20) - -resetStat :: Solver -> IO () -resetStat solver = do - writeIOURef (svNDecision solver) 0 - writeIOURef (svNRandomDecision solver) 0 - writeIOURef (svNConflict solver) 0 - writeIOURef (svNRestart solver) 0 - writeIOURef (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 <- getTime Monotonic - b <- if force - then return True - else do - lastWC <- readIORef (svLastStatWC solver) - return $ sec (nowWC `diffTimeSpec` lastWC) > 1 - when b $ do - startWC <- readIORef (svStartWC solver) - let tm = showTimeDiff $ nowWC `diffTimeSpec` startWC - restart <- readIOURef (svNRestart solver) - dec <- readIOURef (svNDecision solver) - conflict <- readIOURef (svNConflict solver) - learntLim <- readIORef (svLearntLim solver) - learntGC <- readIOURef (svNLearntGC solver) - fixed <- getNFixed solver - removed <- readIOURef (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 :: TimeSpec -> String -showTimeDiff t - | 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 = fromIntegral (toNanoSecs t) / 10^(9::Int) - - si :: Integer - si = fromIntegral (sec t) - - m :: Rational - m = s / 60 - - mi :: Integer - mi = round m - - h :: Rational - h = m / 60 - - hi :: Integer - hi = round h - -{-------------------------------------------------------------------- - constraint implementation ---------------------------------------------------------------------} - -class (Eq a, Hashable a) => ConstraintHandler a where - toConstraintHandler :: a -> SomeConstraintHandler - - showConstraintHandler :: a -> IO String - - constrAttach :: Solver -> SomeConstraintHandler -> a -> IO Bool - - constrDetach :: Solver -> SomeConstraintHandler -> a -> IO () - - constrIsLocked :: Solver -> SomeConstraintHandler -> a -> IO Bool - - -- | invoked with the watched literal when the literal is falsified. - -- 'watch' で 'toConstraint' を呼び出して heap allocation が発生するのを - -- 避けるために、元の 'SomeConstraintHandler' も渡しておく。 - constrPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool - - -- | deduce a clause C∨l from the constraint and return C. - -- C and l should be false and true respectively under the current - -- assignment. - constrReasonOf :: Solver -> a -> Maybe Lit -> IO Clause - - constrOnUnassigned :: Solver -> SomeConstraintHandler -> a -> Lit -> IO () - - isPBRepresentable :: a -> IO Bool - toPBLinAtLeast :: a -> IO PBLinAtLeast - - isSatisfied :: Solver -> a -> IO Bool - - constrIsProtected :: Solver -> a -> IO Bool - constrIsProtected _ _ = return False - - constrWeight :: Solver -> a -> IO Double - constrWeight _ _ = return 1.0 - - constrReadActivity :: a -> IO Double - - constrWriteActivity :: a -> Double -> IO () - -attach :: Solver -> SomeConstraintHandler -> IO Bool -attach solver c = constrAttach solver c c - -detach :: Solver -> SomeConstraintHandler -> IO () -detach solver c = do - constrDetach solver c c - b <- isPBRepresentable c - when b $ do - (lhs,_) <- toPBLinAtLeast c - forM_ lhs $ \(_,lit) -> do - ld <- litData solver lit - modifyIORef' (ldOccurList ld) (HashSet.delete c) - --- | invoked with the watched literal when the literal is falsified. -propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool -propagate solver c l = constrPropagate solver c c l - --- | deduce a clause C∨l from the constraint and return C. --- C and l should be false and true respectively under the current --- assignment. -reasonOf :: ConstraintHandler a => Solver -> a -> Maybe Lit -> IO Clause -reasonOf solver c x = do - when debugMode $ - case x of - Nothing -> return () - Just lit -> do - val <- litValue solver lit - unless (lTrue == val) $ do - str <- showConstraintHandler c - error (printf "reasonOf: value of literal %d should be True but %s (constrReasonOf %s %s)" lit (show val) str (show x)) - cl <- constrReasonOf solver c x - when debugMode $ do - forM_ cl $ \lit -> do - val <- litValue solver lit - unless (lFalse == val) $ do - str <- showConstraintHandler c - error (printf "reasonOf: value of literal %d should be False but %s (constrReasonOf %s %s)" lit (show val) str (show x)) - return cl - -isLocked :: Solver -> SomeConstraintHandler -> IO Bool -isLocked solver c = constrIsLocked solver c c - -data SomeConstraintHandler - = CHClause !ClauseHandler - | CHAtLeast !AtLeastHandler - | CHPBCounter !PBHandlerCounter - | CHPBPueblo !PBHandlerPueblo - | CHXORClause !XORClauseHandler - | CHTheory !TheoryHandler - deriving Eq - -instance Hashable SomeConstraintHandler where - hashWithSalt s (CHClause c) = s `hashWithSalt` (0::Int) `hashWithSalt` c - hashWithSalt s (CHAtLeast c) = s `hashWithSalt` (1::Int) `hashWithSalt` c - hashWithSalt s (CHPBCounter c) = s `hashWithSalt` (2::Int) `hashWithSalt` c - hashWithSalt s (CHPBPueblo c) = s `hashWithSalt` (3::Int) `hashWithSalt` c - hashWithSalt s (CHXORClause c) = s `hashWithSalt` (4::Int) `hashWithSalt` c - hashWithSalt s (CHTheory c) = s `hashWithSalt` (5::Int) `hashWithSalt` c - -instance ConstraintHandler SomeConstraintHandler where - toConstraintHandler = id - - showConstraintHandler (CHClause c) = showConstraintHandler c - showConstraintHandler (CHAtLeast c) = showConstraintHandler c - showConstraintHandler (CHPBCounter c) = showConstraintHandler c - showConstraintHandler (CHPBPueblo c) = showConstraintHandler c - showConstraintHandler (CHXORClause c) = showConstraintHandler c - showConstraintHandler (CHTheory c) = showConstraintHandler c - - constrAttach solver this (CHClause c) = constrAttach solver this c - constrAttach solver this (CHAtLeast c) = constrAttach solver this c - constrAttach solver this (CHPBCounter c) = constrAttach solver this c - constrAttach solver this (CHPBPueblo c) = constrAttach solver this c - constrAttach solver this (CHXORClause c) = constrAttach solver this c - constrAttach solver this (CHTheory c) = constrAttach solver this c - - constrDetach solver this (CHClause c) = constrDetach solver this c - constrDetach solver this (CHAtLeast c) = constrDetach solver this c - constrDetach solver this (CHPBCounter c) = constrDetach solver this c - constrDetach solver this (CHPBPueblo c) = constrDetach solver this c - constrDetach solver this (CHXORClause c) = constrDetach solver this c - constrDetach solver this (CHTheory c) = constrDetach solver this c - - constrIsLocked solver this (CHClause c) = constrIsLocked solver this c - constrIsLocked solver this (CHAtLeast c) = constrIsLocked solver this c - constrIsLocked solver this (CHPBCounter c) = constrIsLocked solver this c - constrIsLocked solver this (CHPBPueblo c) = constrIsLocked solver this c - constrIsLocked solver this (CHXORClause c) = constrIsLocked solver this c - constrIsLocked solver this (CHTheory c) = constrIsLocked solver this c - - constrPropagate solver this (CHClause c) lit = constrPropagate solver this c lit - constrPropagate solver this (CHAtLeast c) lit = constrPropagate solver this c lit - constrPropagate solver this (CHPBCounter c) lit = constrPropagate solver this c lit - constrPropagate solver this (CHPBPueblo c) lit = constrPropagate solver this c lit - constrPropagate solver this (CHXORClause c) lit = constrPropagate solver this c lit - constrPropagate solver this (CHTheory c) lit = constrPropagate solver this c lit - - constrReasonOf solver (CHClause c) l = constrReasonOf solver c l - constrReasonOf solver (CHAtLeast c) l = constrReasonOf solver c l - constrReasonOf solver (CHPBCounter c) l = constrReasonOf solver c l - constrReasonOf solver (CHPBPueblo c) l = constrReasonOf solver c l - constrReasonOf solver (CHXORClause c) l = constrReasonOf solver c l - constrReasonOf solver (CHTheory c) l = constrReasonOf solver c l - - constrOnUnassigned solver this (CHClause c) l = constrOnUnassigned solver this c l - constrOnUnassigned solver this (CHAtLeast c) l = constrOnUnassigned solver this c l - constrOnUnassigned solver this (CHPBCounter c) l = constrOnUnassigned solver this c l - constrOnUnassigned solver this (CHPBPueblo c) l = constrOnUnassigned solver this c l - constrOnUnassigned solver this (CHXORClause c) l = constrOnUnassigned solver this c l - constrOnUnassigned solver this (CHTheory c) l = constrOnUnassigned solver this c l - - isPBRepresentable (CHClause c) = isPBRepresentable c - isPBRepresentable (CHAtLeast c) = isPBRepresentable c - isPBRepresentable (CHPBCounter c) = isPBRepresentable c - isPBRepresentable (CHPBPueblo c) = isPBRepresentable c - isPBRepresentable (CHXORClause c) = isPBRepresentable c - isPBRepresentable (CHTheory c) = isPBRepresentable c - - toPBLinAtLeast (CHClause c) = toPBLinAtLeast c - toPBLinAtLeast (CHAtLeast c) = toPBLinAtLeast c - toPBLinAtLeast (CHPBCounter c) = toPBLinAtLeast c - toPBLinAtLeast (CHPBPueblo c) = toPBLinAtLeast c - toPBLinAtLeast (CHXORClause c) = toPBLinAtLeast c - toPBLinAtLeast (CHTheory c) = toPBLinAtLeast c - - isSatisfied solver (CHClause c) = isSatisfied solver c - isSatisfied solver (CHAtLeast c) = isSatisfied solver c - isSatisfied solver (CHPBCounter c) = isSatisfied solver c - isSatisfied solver (CHPBPueblo c) = isSatisfied solver c - isSatisfied solver (CHXORClause c) = isSatisfied solver c - isSatisfied solver (CHTheory c) = isSatisfied solver c - - constrIsProtected solver (CHClause c) = constrIsProtected solver c - constrIsProtected solver (CHAtLeast c) = constrIsProtected solver c - constrIsProtected solver (CHPBCounter c) = constrIsProtected solver c - constrIsProtected solver (CHPBPueblo c) = constrIsProtected solver c - constrIsProtected solver (CHXORClause c) = constrIsProtected solver c - constrIsProtected solver (CHTheory c) = constrIsProtected solver c - - constrReadActivity (CHClause c) = constrReadActivity c - constrReadActivity (CHAtLeast c) = constrReadActivity c - constrReadActivity (CHPBCounter c) = constrReadActivity c - constrReadActivity (CHPBPueblo c) = constrReadActivity c - constrReadActivity (CHXORClause c) = constrReadActivity c - constrReadActivity (CHTheory c) = constrReadActivity c - - constrWriteActivity (CHClause c) aval = constrWriteActivity c aval - constrWriteActivity (CHAtLeast c) aval = constrWriteActivity c aval - constrWriteActivity (CHPBCounter c) aval = constrWriteActivity c aval - constrWriteActivity (CHPBPueblo c) aval = constrWriteActivity c aval - constrWriteActivity (CHXORClause c) aval = constrWriteActivity c aval - constrWriteActivity (CHTheory c) aval = constrWriteActivity c aval - -isReasonOf :: Solver -> SomeConstraintHandler -> Lit -> IO Bool -isReasonOf solver c lit = do - val <- litValue solver lit - if val == lUndef then - return False - else do - m <- varReason solver (litVar lit) - case m of - Nothing -> return False - Just c2 -> return $! c == c2 - --- To avoid heap-allocation Maybe value, it returns -1 when not found. -findForWatch :: Solver -> IOUArray Int Lit -> Int -> Int -> IO Int -#ifndef __GLASGOW_HASKELL__ -findForWatch solver a beg end = go beg end - where - go :: Int -> Int -> IO Int - go i end | i > end = return (-1) - go i end = do - val <- litValue s =<< unsafeRead a i - if val /= lFalse - then return i - else go (i+1) end -#else -{- We performed worker-wrapper transfomation manually, since the worker - generated by GHC has type - "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", - not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". - We want latter one to avoid heap-allocating Int value. -} -findForWatch solver a (I# beg) (I# end) = IO $ \w -> - case go# beg end w of - (# w2, ret #) -> (# w2, I# ret #) - where - go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) - go# i end w | isTrue# (i ># end) = (# w, -1# #) - go# i end w = - case unIO (litValue solver =<< unsafeRead a (I# i)) w of - (# w2, val #) -> - if val /= lFalse - then (# w2, i #) - else go# (i +# 1#) end w2 - - unIO (IO f) = f -#endif - --- To avoid heap-allocating Maybe value, it returns -1 when not found. -findForWatch2 :: Solver -> IOUArray Int Lit -> Int -> Int -> IO Int -#ifndef __GLASGOW_HASKELL__ -findForWatch2 solver a beg end = go beg end - where - go :: Int -> Int -> IO Int - go i end | i > end = return (-1) - go i end = do - val <- litValue s =<< unsafeRead a i - if val == lUndef - then return i - else go (i+1) end -#else -{- We performed worker-wrapper transfomation manually, since the worker - generated by GHC has type - "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", - not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". - We want latter one to avoid heap-allocating Int value. -} -findForWatch2 solver a (I# beg) (I# end) = IO $ \w -> - case go# beg end w of - (# w2, ret #) -> (# w2, I# ret #) - where - go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) - go# i end w | isTrue# (i ># end) = (# w, -1# #) - go# i end w = - case unIO (litValue solver =<< unsafeRead a (I# i)) w of - (# w2, val #) -> - if val == lUndef - then (# w2, i #) - else go# (i +# 1#) end w2 - - unIO (IO f) = f -#endif - -{-------------------------------------------------------------------- - Clause ---------------------------------------------------------------------} - -data ClauseHandler - = ClauseHandler - { claLits :: !(IOUArray Int Lit) - , claActivity :: !(IORef Double) - , claHash :: !Int - } - -claGetSize :: ClauseHandler -> IO Int -claGetSize cla = do - (lb,ub) <- getBounds (claLits cla) - assert (lb == 0) $ return () - return $! ub-lb+1 - -instance Eq ClauseHandler where - (==) = (==) `on` claLits - -instance Hashable ClauseHandler where - hash = claHash - hashWithSalt = defaultHashWithSalt - -newClauseHandler :: Clause -> Bool -> IO ClauseHandler -newClauseHandler ls learnt = do - let size = length ls - a <- newListArray (0, size-1) ls - act <- newIORef $! (if learnt then 0 else -1) - return (ClauseHandler a act (hash ls)) - -instance ConstraintHandler ClauseHandler where - toConstraintHandler = CHClause - - showConstraintHandler this = do - lits <- getElems (claLits this) - return (show lits) - - constrAttach solver this this2 = do - -- BCP Queue should be empty at this point. - -- If not, duplicated propagation happens. - bcpCheckEmpty solver - - size <- claGetSize this2 - if size == 0 then do - markBad solver - return False - else if size == 1 then do - lit0 <- unsafeRead (claLits this2) 0 - assignBy solver lit0 this - else do - ref <- newIORef 1 - let f i = do - lit_i <- unsafeRead (claLits this2) i - val_i <- litValue solver lit_i - if val_i /= lFalse then - return True - else do - j <- readIORef ref - k <- findForWatch solver (claLits this2) j (size - 1) - case k of - -1 -> do - return False - _ -> do - lit_k <- unsafeRead (claLits this2) k - unsafeWrite (claLits this2) i lit_k - unsafeWrite (claLits this2) k lit_i - writeIORef ref $! (k+1) - return True - - b <- f 0 - if b then do - lit0 <- unsafeRead (claLits this2) 0 - watchLit solver lit0 this - b2 <- f 1 - if b2 then do - lit1 <- unsafeRead (claLits this2) 1 - watchLit solver lit1 this - return True - else do -- UNIT - -- We need to watch the most recently falsified literal - (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..size-1] $ \l -> do - lit <- unsafeRead (claLits this2) l - lv <- litLevel solver lit - return (l,lv) - lit1 <- unsafeRead (claLits this2) 1 - liti <- unsafeRead (claLits this2) i - unsafeWrite (claLits this2) 1 liti - unsafeWrite (claLits this2) i lit1 - watchLit solver liti this - assignBy solver lit0 this -- should always succeed - else do -- CONFLICT - ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [0..size-1] $ \l -> do - lit <- unsafeRead (claLits this2) l - lv <- litLevel solver lit - return (l,lv) - forM_ (zip [0..] ls) $ \(i,lit) -> do - unsafeWrite (claLits this2) i lit - lit0 <- unsafeRead (claLits this2) 0 - lit1 <- unsafeRead (claLits this2) 1 - watchLit solver lit0 this - watchLit solver lit1 this - return False - - constrDetach solver this this2 = do - size <- claGetSize this2 - when (size >= 2) $ do - lit0 <- unsafeRead (claLits this2) 0 - lit1 <- unsafeRead (claLits this2) 1 - unwatchLit solver lit0 this - unwatchLit solver lit1 this - - constrIsLocked solver this this2 = do - size <- claGetSize this2 - if size < 2 then - return False - else do - lit <- unsafeRead (claLits this2) 0 - isReasonOf solver this lit - - constrPropagate !solver this this2 !falsifiedLit = do - preprocess - - !lit0 <- unsafeRead a 0 - !val0 <- litValue solver lit0 - if val0 == lTrue then do - watchLit solver falsifiedLit this - return True - else do - size <- claGetSize this2 - i <- findForWatch solver a 2 (size - 1) - case i of - -1 -> do - when debugMode $ logIO solver $ do - str <- showConstraintHandler this - return $ printf "constrPropagate: %s is unit" str - watchLit solver falsifiedLit this - assignBy solver lit0 this - _ -> do - !lit1 <- unsafeRead a 1 - !liti <- unsafeRead a i - unsafeWrite a 1 liti - unsafeWrite a i lit1 - watchLit solver liti this - return True - - where - a = claLits this2 - - preprocess :: IO () - preprocess = do - !l0 <- unsafeRead a 0 - !l1 <- unsafeRead a 1 - assert (l0==falsifiedLit || l1==falsifiedLit) $ return () - when (l0==falsifiedLit) $ do - unsafeWrite a 0 l1 - unsafeWrite a 1 l0 - - constrReasonOf _ this l = do - lits <- getElems (claLits this) - case l of - Nothing -> return lits - Just lit -> do - assert (lit == head lits) $ return () - return $ tail lits - - constrOnUnassigned _solver _this _this2 _lit = return () - - isPBRepresentable _ = return True - - toPBLinAtLeast this = do - lits <- getElems (claLits this) - return ([(1,l) | l <- lits], 1) - - isSatisfied solver this = do - (lb,ub) <- getBounds (claLits this) - liftM isLeft $ runExceptT $ numLoop lb ub $ \i -> do - v <- lift $ litValue solver =<< unsafeRead (claLits this) i - when (v == lTrue) $ throwE () - - constrIsProtected _ this = do - size <- claGetSize this - return $! size <= 2 - - constrReadActivity this = readIORef (claActivity this) - - constrWriteActivity this aval = writeIORef (claActivity this) $! aval - -basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool -basicAttachClauseHandler solver this = do - let constr = toConstraintHandler this - lits <- getElems (claLits this) - case lits of - [] -> do - markBad solver - return False - [l1] -> do - assignBy solver l1 constr - l1:l2:_ -> do - watchLit solver l1 constr - watchLit solver l2 constr - return True - -{-------------------------------------------------------------------- - Cardinality Constraint ---------------------------------------------------------------------} - -data AtLeastHandler - = AtLeastHandler - { atLeastLits :: IOUArray Int Lit - , atLeastNum :: !Int - , atLeastActivity :: !(IORef Double) - , atLeastHash :: !Int - } - -instance Eq AtLeastHandler where - (==) = (==) `on` atLeastLits - -instance Hashable AtLeastHandler where - hash = atLeastHash - hashWithSalt = defaultHashWithSalt - -newAtLeastHandler :: [Lit] -> Int -> Bool -> IO AtLeastHandler -newAtLeastHandler ls n learnt = do - let size = length ls - a <- newListArray (0, size-1) ls - act <- newIORef $! (if learnt then 0 else -1) - return (AtLeastHandler a n act (hash (ls,n))) - -instance ConstraintHandler AtLeastHandler where - toConstraintHandler = CHAtLeast - - showConstraintHandler this = do - lits <- getElems (atLeastLits this) - return $ show lits ++ " >= " ++ show (atLeastNum this) - - -- FIXME: simplify implementation - constrAttach solver this this2 = do - -- BCP Queue should be empty at this point. - -- If not, duplicated propagation happens. - bcpCheckEmpty solver - - let a = atLeastLits this2 - (lb,ub) <- getBounds a - assert (lb == 0) $ return () - let m = ub - lb + 1 - n = atLeastNum this2 - - if m < n then do - markBad solver - return False - else if m == n then do - let f i = do - lit <- unsafeRead a i - assignBy solver lit this - allM f [0..n-1] - else do -- m > n - let f !i !j - | i == n = do - -- NOT VIOLATED: n literals (0 .. n-1) are watched - k <- findForWatch solver a j ub - if k /= -1 then do - -- NOT UNIT - lit_n <- unsafeRead a n - lit_k <- unsafeRead a k - unsafeWrite a n lit_k - unsafeWrite a k lit_n - watchLit solver lit_k this - -- n+1 literals (0 .. n) are watched. - else do - -- UNIT - forLoop 0 ( do - lit <- unsafeRead a l - _ <- assignBy solver lit this -- should always succeed - return () - -- We need to watch the most recently falsified literal - (l,_) <- liftM (maximumBy (comparing snd)) $ forM [n..ub] $ \l -> do - lit <- unsafeRead a l - lv <- litLevel solver lit - when debugMode $ do - val <- litValue solver lit - unless (val == lFalse) $ error "AtLeastHandler.attach: should not happen" - return (l,lv) - lit_n <- unsafeRead a n - lit_l <- unsafeRead a l - unsafeWrite a n lit_l - unsafeWrite a l lit_n - watchLit solver lit_l this - -- n+1 literals (0 .. n) are watched. - return True - | otherwise = do - assert (i < n && n <= j) $ return () - lit_i <- unsafeRead a i - val_i <- litValue solver lit_i - if val_i /= lFalse then do - watchLit solver lit_i this - f (i+1) j - else do - k <- findForWatch solver a j ub - if k /= -1 then do - lit_k <- unsafeRead a k - unsafeWrite a i lit_k - unsafeWrite a k lit_i - watchLit solver lit_k this - f (i+1) (k+1) - else do - -- CONFLICT - -- We need to watch unassigned literals or most recently falsified literals. - do xs <- liftM (sortBy (flip (comparing snd))) $ forM [i..ub] $ \l -> do - lit <- readArray a l - val <- litValue solver lit - if val == lFalse then do - lv <- litLevel solver lit - return (lit, lv) - else do - return (lit, maxBound) - forM_ (zip [i..ub] xs) $ \(l,(lit,_lv)) -> do - writeArray a l lit - forLoop i (<=n) (+1) $ \l -> do - lit_l <- readArray a l - watchLit solver lit_l this - -- n+1 literals (0 .. n) are watched. - return False - f 0 n - - constrDetach solver this this2 = do - lits <- getElems (atLeastLits this2) - let n = atLeastNum this2 - when (length lits > n) $ do - forLoop 0 (<=n) (+1) $ \i -> do - lit <- unsafeRead (atLeastLits this2) i - unwatchLit solver lit this - - constrIsLocked solver this this2 = do - (lb,ub) <- getBounds (atLeastLits this2) - let size = ub - lb + 1 - n = atLeastNum this2 - loop i - | i > n = return False - | otherwise = do - l <- unsafeRead (atLeastLits this2) i - b <- isReasonOf solver this l - if b then return True else loop (i+1) - if size >= n+1 then - loop 0 - else - return False - - constrPropagate solver this this2 falsifiedLit = do - preprocess - - when debugMode $ do - litn <- readArray a n - unless (litn == falsifiedLit) $ error "AtLeastHandler.constrPropagate: should not happen" - - (lb,ub) <- getBounds a - assert (lb==0) $ return () - i <- findForWatch solver a (n+1) ub - case i of - -1 -> do - when debugMode $ logIO solver $ do - str <- showConstraintHandler this - return $ printf "constrPropagate: %s is unit" str - watchLit solver falsifiedLit this - let loop :: Int -> IO Bool - loop i - | i >= n = return True - | otherwise = do - liti <- unsafeRead a i - ret2 <- assignBy solver liti this - if ret2 - then loop (i+1) - else return False - loop 0 - _ -> do - liti <- unsafeRead a i - litn <- unsafeRead a n - unsafeWrite a i litn - unsafeWrite a n liti - watchLit solver liti this - return True - - where - a = atLeastLits this2 - n = atLeastNum this2 - - preprocess :: IO () - preprocess = loop 0 - where - loop :: Int -> IO () - loop i - | i >= n = return () - | otherwise = do - li <- unsafeRead a i - if (li /= falsifiedLit) then - loop (i+1) - else do - ln <- unsafeRead a n - unsafeWrite a n li - unsafeWrite a i ln - - constrReasonOf solver this concl = do - (lb,ub) <- getBounds (atLeastLits this) - assert (lb==0) $ return () - let n = atLeastNum this - falsifiedLits <- mapM (readArray (atLeastLits this)) [n..ub] -- drop first n elements - when debugMode $ do - forM_ falsifiedLits $ \lit -> do - val <- litValue solver lit - unless (val == lFalse) $ do - error $ printf "AtLeastHandler.constrReasonOf: %d is %s (lFalse expected)" lit (show val) - case concl of - Nothing -> do - let go :: Int -> IO Lit - go i - | i >= n = error $ printf "AtLeastHandler.constrReasonOf: cannot find falsified literal in first %d elements" n - | otherwise = do - lit <- readArray (atLeastLits this) i - val <- litValue solver lit - if val == lFalse - then return lit - else go (i+1) - lit <- go lb - return $ lit : falsifiedLits - Just lit -> do - when debugMode $ do - es <- getElems (atLeastLits this) - unless (lit `elem` take n es) $ - error $ printf "AtLeastHandler.constrReasonOf: cannot find %d in first %d elements" n - return falsifiedLits - - constrOnUnassigned _solver _this _this2 _lit = return () - - isPBRepresentable _ = return True - - toPBLinAtLeast this = do - lits <- getElems (atLeastLits this) - return ([(1,l) | l <- lits], fromIntegral (atLeastNum this)) - - isSatisfied solver this = do - (lb,ub) <- getBounds (atLeastLits this) - liftM isLeft $ runExceptT $ numLoopState lb ub 0 $ \(!n) i -> do - v <- lift $ litValue solver =<< unsafeRead (atLeastLits this) i - if v /= lTrue then do - return n - else do - let n' = n + 1 - when (n' >= atLeastNum this) $ throwE () - return n' - - constrReadActivity this = readIORef (atLeastActivity this) - - constrWriteActivity this aval = writeIORef (atLeastActivity this) $! aval - -basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool -basicAttachAtLeastHandler solver this = do - lits <- getElems (atLeastLits this) - let m = length lits - n = atLeastNum this - constr = toConstraintHandler this - if m < n then do - markBad solver - return False - else if m == n then do - allM (\l -> assignBy solver l constr) lits - else do -- m > n - forM_ (take (n+1) lits) $ \l -> watchLit solver l constr - return True - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint ---------------------------------------------------------------------} - -newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler -newPBHandler solver ts degree learnt = do - config <- configPBHandlerType <$> getConfig solver - case config of - PBHandlerTypeCounter -> do - c <- newPBHandlerCounter ts degree learnt - return (toConstraintHandler c) - PBHandlerTypePueblo -> do - c <- newPBHandlerPueblo ts degree learnt - return (toConstraintHandler c) - -newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler -newPBHandlerPromoted solver lhs rhs learnt = do - case pbToAtLeast (lhs,rhs) of - Nothing -> newPBHandler solver lhs rhs learnt - Just (lhs2, rhs2) -> do - if rhs2 /= 1 then do - h <- newAtLeastHandler lhs2 rhs2 learnt - return $ toConstraintHandler h - else do - h <- newClauseHandler lhs2 learnt - return $ toConstraintHandler h - -pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool -pbOverSAT solver (lhs, rhs) = do - ss <- forM lhs $ \(c,l) -> do - v <- litValue solver l - if v /= lFalse - then return c - else return 0 - return $! sum ss > rhs - -pbToAtLeast :: PBLinAtLeast -> Maybe AtLeast -pbToAtLeast (lhs, rhs) = do - let cs = [c | (c,_) <- lhs] - guard $ Set.size (Set.fromList cs) == 1 - let c = head cs - return $ (map snd lhs, fromInteger ((rhs+c-1) `div` c)) - -pbToClause :: PBLinAtLeast -> Maybe Clause -pbToClause pb = do - (lhs, rhs) <- pbToAtLeast pb - guard $ rhs == 1 - return lhs - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint (Counter) ---------------------------------------------------------------------} - -data PBHandlerCounter - = PBHandlerCounter - { pbTerms :: !PBLinSum -- sorted in the decending order on coefficients. - , pbDegree :: !Integer - , pbCoeffMap :: !(LitMap Integer) - , pbMaxSlack :: !Integer - , pbSlack :: !(IORef Integer) - , pbActivity :: !(IORef Double) - , pbHash :: !Int - } - -instance Eq PBHandlerCounter where - (==) = (==) `on` pbSlack - -instance Hashable PBHandlerCounter where - hash = pbHash - hashWithSalt = defaultHashWithSalt - -newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter -newPBHandlerCounter ts degree learnt = do - let ts' = sortBy (flip compare `on` fst) ts - slack = sum (map fst ts) - degree - m = IM.fromList [(l,c) | (c,l) <- ts] - s <- newIORef slack - act <- newIORef $! (if learnt then 0 else -1) - return (PBHandlerCounter ts' degree m slack s act (hash (ts,degree))) - -instance ConstraintHandler PBHandlerCounter where - toConstraintHandler = CHPBCounter - - showConstraintHandler this = do - return $ show (pbTerms this) ++ " >= " ++ show (pbDegree this) - - constrAttach solver this this2 = do - -- BCP queue should be empty at this point. - -- It is important for calculating slack. - bcpCheckEmpty solver - s <- liftM sum $ forM (pbTerms this2) $ \(c,l) -> do - watchLit solver l this - val <- litValue solver l - if val == lFalse then do - addOnUnassigned solver this l - return 0 - else do - return c - let slack = s - pbDegree this2 - writeIORef (pbSlack this2) $! slack - if slack < 0 then - return False - else do - flip allM (pbTerms this2) $ \(c,l) -> do - val <- litValue solver l - if c > slack && val == lUndef then do - assignBy solver l this - else - return True - - constrDetach solver this this2 = do - forM_ (pbTerms this2) $ \(_,l) -> do - unwatchLit solver l this - - constrIsLocked solver this this2 = do - anyM (\(_,l) -> isReasonOf solver this l) (pbTerms this2) - - constrPropagate solver this this2 falsifiedLit = do - watchLit solver falsifiedLit this - let c = pbCoeffMap this2 IM.! falsifiedLit - modifyIORef' (pbSlack this2) (subtract c) - addOnUnassigned solver this falsifiedLit - s <- readIORef (pbSlack this2) - if s < 0 then - return False - else do - forM_ (takeWhile (\(c1,_) -> c1 > s) (pbTerms this2)) $ \(_,l1) -> do - v <- litValue solver l1 - when (v == lUndef) $ do - assignBy solver l1 this - return () - return True - - constrReasonOf solver this l = do - case l of - Nothing -> do - let p _ = return True - f p (pbMaxSlack this) (pbTerms this) - Just lit -> do - idx <- varAssignNo solver (litVar lit) - -- PB制約の場合には複数回unitになる可能性があり、 - -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 - let p lit2 =do - idx2 <- varAssignNo solver (litVar lit2) - return $ idx2 < idx - let c = pbCoeffMap this IM.! lit - f p (pbMaxSlack this - c) (pbTerms this) - where - {-# INLINE f #-} - f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] - f p s xs = go s xs [] - where - go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] - go s _ ret | s < 0 = return ret - go _ [] _ = error "PBHandlerCounter.constrReasonOf: should not happen" - go s ((c,lit):xs) ret = do - val <- litValue solver lit - if val == lFalse then do - b <- p lit - if b - then go (s - c) xs (lit:ret) - else go s xs ret - else do - go s xs ret - - constrOnUnassigned _solver _this this2 lit = do - let c = pbCoeffMap this2 IM.! (- lit) - modifyIORef' (pbSlack this2) (+ c) - - isPBRepresentable _ = return True - - toPBLinAtLeast this = do - return (pbTerms this, pbDegree this) - - isSatisfied solver this = do - xs <- forM (pbTerms this) $ \(c,l) -> do - v <- litValue solver l - if v == lTrue - then return c - else return 0 - return $ sum xs >= pbDegree this - - constrWeight _ _ = return 0.5 - - constrReadActivity this = readIORef (pbActivity this) - - constrWriteActivity this aval = writeIORef (pbActivity this) $! aval - -{-------------------------------------------------------------------- - Pseudo Boolean Constraint (Pueblo) ---------------------------------------------------------------------} - -data PBHandlerPueblo - = PBHandlerPueblo - { puebloTerms :: !PBLinSum - , puebloDegree :: !Integer - , puebloMaxSlack :: !Integer - , puebloWatches :: !(IORef LitSet) - , puebloWatchSum :: !(IORef Integer) - , puebloActivity :: !(IORef Double) - , puebloHash :: !Int - } - -instance Eq PBHandlerPueblo where - (==) = (==) `on` puebloWatchSum - -instance Hashable PBHandlerPueblo where - hash = puebloHash - hashWithSalt = defaultHashWithSalt - -puebloAMax :: PBHandlerPueblo -> Integer -puebloAMax this = - case puebloTerms this of - (c,_):_ -> c - [] -> 0 -- should not happen? - -newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo -newPBHandlerPueblo ts degree learnt = do - let ts' = sortBy (flip compare `on` fst) ts - slack = sum [c | (c,_) <- ts'] - degree - ws <- newIORef IS.empty - wsum <- newIORef 0 - act <- newIORef $! (if learnt then 0 else -1) - return $ PBHandlerPueblo ts' degree slack ws wsum act (hash (ts,degree)) - -puebloGetWatchSum :: PBHandlerPueblo -> IO Integer -puebloGetWatchSum pb = readIORef (puebloWatchSum pb) - -puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO () -puebloWatch solver constr !pb (c, lit) = do - watchLit solver lit constr - modifyIORef' (puebloWatches pb) (IS.insert lit) - modifyIORef' (puebloWatchSum pb) (+c) - -puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO () -puebloUnwatch _solver pb (c, lit) = do - modifyIORef' (puebloWatches pb) (IS.delete lit) - modifyIORef' (puebloWatchSum pb) (subtract c) - -instance ConstraintHandler PBHandlerPueblo where - toConstraintHandler = CHPBPueblo - - showConstraintHandler this = do - return $ show (puebloTerms this) ++ " >= " ++ show (puebloDegree this) - - constrAttach solver this this2 = do - bcpCheckEmpty solver - ret <- puebloPropagate solver this this2 - - -- register to watch recently falsified literals to recover - -- "WatchSum >= puebloDegree this + puebloAMax this" when backtrack is performed. - wsum <- puebloGetWatchSum this2 - unless (wsum >= puebloDegree this2 + puebloAMax this2) $ do - let f m tm@(_,lit) = do - val <- litValue solver lit - if val == lFalse then do - idx <- varAssignNo solver (litVar lit) - return (IM.insert idx tm m) - else - return m - xs <- liftM (map snd . IM.toDescList) $ foldM f IM.empty (puebloTerms this2) - let g !_ [] = return () - g !s ((c,l):ts) = do - addOnUnassigned solver this l - if s+c >= puebloDegree this2 + puebloAMax this2 then return () - else g (s+c) ts - g wsum xs - - return ret - - constrDetach solver this this2 = do - ws <- readIORef (puebloWatches this2) - forM_ (IS.toList ws) $ \l -> do - unwatchLit solver l this - - constrIsLocked solver this this2 = do - anyM (\(_,l) -> isReasonOf solver this l) (puebloTerms this2) - - constrPropagate solver this this2 falsifiedLit = do - let t = fromJust $ find (\(_,l) -> l==falsifiedLit) (puebloTerms this2) - puebloUnwatch solver this2 t - ret <- puebloPropagate solver this this2 - wsum <- puebloGetWatchSum this2 - unless (wsum >= puebloDegree this2 + puebloAMax this2) $ - addOnUnassigned solver this falsifiedLit - return ret - - constrReasonOf solver this l = do - case l of - Nothing -> do - let p _ = return True - f p (puebloMaxSlack this) (puebloTerms this) - Just lit -> do - idx <- varAssignNo solver (litVar lit) - -- PB制約の場合には複数回unitになる可能性があり、 - -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 - let p lit2 =do - idx2 <- varAssignNo solver (litVar lit2) - return $ idx2 < idx - let c = fst $ fromJust $ find (\(_,l) -> l == lit) (puebloTerms this) - f p (puebloMaxSlack this - c) (puebloTerms this) - where - {-# INLINE f #-} - f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] - f p s xs = go s xs [] - where - go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] - go s _ ret | s < 0 = return ret - go _ [] _ = error "PBHandlerPueblo.constrReasonOf: should not happen" - go s ((c,lit):xs) ret = do - val <- litValue solver lit - if val == lFalse then do - b <- p lit - if b - then go (s - c) xs (lit:ret) - else go s xs ret - else do - go s xs ret - - constrOnUnassigned solver this this2 lit = do - let t = fromJust $ find (\(_,l) -> l == - lit) (puebloTerms this2) - puebloWatch solver this this2 t - - isPBRepresentable _ = return True - - toPBLinAtLeast this = do - return (puebloTerms this, puebloDegree this) - - isSatisfied solver this = do - xs <- forM (puebloTerms this) $ \(c,l) -> do - v <- litValue solver l - if v == lTrue - then return c - else return 0 - return $ sum xs >= puebloDegree this - - constrWeight _ _ = return 0.5 - - constrReadActivity this = readIORef (puebloActivity this) - - constrWriteActivity this aval = writeIORef (puebloActivity this) $! aval - -puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool -puebloPropagate solver constr this = do - puebloUpdateWatchSum solver constr this - watchsum <- puebloGetWatchSum this - if puebloDegree this + puebloAMax this <= watchsum then - return True - else if watchsum < puebloDegree this then do - -- CONFLICT - return False - else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this - -- UNIT PROPAGATION - let f [] = return True - f ((c,lit) : ts) = do - watchsum <- puebloGetWatchSum this - if watchsum - c >= puebloDegree this then - return True - else do - val <- litValue solver lit - when (val == lUndef) $ do - b <- assignBy solver lit constr - assert b $ return () - f ts - f $ puebloTerms this - -puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO () -puebloUpdateWatchSum solver constr this = do - let f [] = return () - f (t@(_,lit):ts) = do - watchSum <- puebloGetWatchSum this - if watchSum >= puebloDegree this + puebloAMax this then - return () - else do - val <- litValue solver lit - watched <- liftM (lit `IS.member`) $ readIORef (puebloWatches this) - when (val /= lFalse && not watched) $ do - puebloWatch solver constr this t - f ts - f (puebloTerms this) - -{-------------------------------------------------------------------- - XOR Clause ---------------------------------------------------------------------} - -data XORClauseHandler - = XORClauseHandler - { xorLits :: !(IOUArray Int Lit) - , xorActivity :: !(IORef Double) - , xorHash :: !Int - } - -instance Eq XORClauseHandler where - (==) = (==) `on` xorLits - -instance Hashable XORClauseHandler where - hash = xorHash - hashWithSalt = defaultHashWithSalt - -newXORClauseHandler :: [Lit] -> Bool -> IO XORClauseHandler -newXORClauseHandler ls learnt = do - let size = length ls - a <- newListArray (0, size-1) ls - act <- newIORef $! (if learnt then 0 else -1) - return (XORClauseHandler a act (hash ls)) - -instance ConstraintHandler XORClauseHandler where - toConstraintHandler = CHXORClause - - showConstraintHandler this = do - lits <- getElems (xorLits this) - return ("XOR " ++ show lits) - - constrAttach solver this this2 = do - -- BCP Queue should be empty at this point. - -- If not, duplicated propagation happens. - bcpCheckEmpty solver - - let a = xorLits this2 - (lb,ub) <- getBounds a - assert (lb == 0) $ return () - let size = ub-lb+1 - - if size == 0 then do - markBad solver - return False - else if size == 1 then do - lit0 <- unsafeRead a 0 - assignBy solver lit0 this - else do - ref <- newIORef 1 - let f i = do - lit_i <- unsafeRead a i - val_i <- litValue solver lit_i - if val_i == lUndef then - return True - else do - j <- readIORef ref - k <- findForWatch2 solver a j ub - case k of - -1 -> do - return False - _ -> do - lit_k <- unsafeRead a k - unsafeWrite a i lit_k - unsafeWrite a k lit_i - writeIORef ref $! (k+1) - return True - - b <- f 0 - if b then do - lit0 <- unsafeRead a 0 - watchVar solver (litVar lit0) this - b2 <- f 1 - if b2 then do - lit1 <- unsafeRead a 1 - watchVar solver (litVar lit1) this - return True - else do -- UNIT - -- We need to watch the most recently falsified literal - (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..ub] $ \l -> do - lit <- unsafeRead a l - lv <- litLevel solver lit - return (l,lv) - lit1 <- unsafeRead a 1 - liti <- unsafeRead a i - unsafeWrite a 1 liti - unsafeWrite a i lit1 - watchVar solver (litVar liti) this - -- lit0 ⊕ y - y <- do - ref <- newIORef False - forLoop 1 (<=ub) (+1) $ \j -> do - lit_j <- unsafeRead a j - val_j <- litValue solver lit_j - modifyIORef' ref (/= fromJust (unliftBool val_j)) - readIORef ref - assignBy solver (if y then litNot lit0 else lit0) this -- should always succeed - else do - ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [lb..ub] $ \l -> do - lit <- unsafeRead a l - lv <- litLevel solver lit - return (l,lv) - forM_ (zip [0..] ls) $ \(i,lit) -> do - unsafeWrite a i lit - lit0 <- unsafeRead a 0 - lit1 <- unsafeRead a 1 - watchVar solver (litVar lit0) this - watchVar solver (litVar lit1) this - isSatisfied solver this2 - - constrDetach solver this this2 = do - (lb,ub) <- getBounds (xorLits this2) - let size = ub-lb+1 - when (size >= 2) $ do - lit0 <- unsafeRead (xorLits this2) 0 - lit1 <- unsafeRead (xorLits this2) 1 - unwatchVar solver (litVar lit0) this - unwatchVar solver (litVar lit1) this - - constrIsLocked solver this this2 = do - lit0 <- unsafeRead (xorLits this2) 0 - lit1 <- unsafeRead (xorLits this2) 1 - b0 <- isReasonOf solver this lit0 - b1 <- isReasonOf solver this lit1 - return $ b0 || b1 - - constrPropagate !solver this this2 !falsifiedLit = do - b <- constrIsLocked solver this this2 - if b then - return True - else do - preprocess - - !lit0 <- unsafeRead a 0 - (!lb,!ub) <- getBounds a - assert (lb==0) $ return () - i <- findForWatch2 solver a 2 ub - case i of - -1 -> do - when debugMode $ logIO solver $ do - str <- showConstraintHandler this - return $ printf "constrPropagate: %s is unit" str - watchVar solver v this - -- lit0 ⊕ y - y <- do - ref <- newIORef False - forLoop 1 (<=ub) (+1) $ \j -> do - lit_j <- unsafeRead a j - val_j <- litValue solver lit_j - modifyIORef' ref (/= fromJust (unliftBool val_j)) - readIORef ref - assignBy solver (if y then litNot lit0 else lit0) this - _ -> do - !lit1 <- unsafeRead a 1 - !liti <- unsafeRead a i - unsafeWrite a 1 liti - unsafeWrite a i lit1 - watchVar solver (litVar liti) this - return True - - where - v = litVar falsifiedLit - a = xorLits this2 - - preprocess :: IO () - preprocess = do - !l0 <- unsafeRead a 0 - !l1 <- unsafeRead a 1 - assert (litVar l0 == v || litVar l1 == v) $ return () - when (litVar l0 == v) $ do - unsafeWrite a 0 l1 - unsafeWrite a 1 l0 - - constrReasonOf solver this l = do - lits <- getElems (xorLits this) - xs <- - case l of - Nothing -> mapM f lits - Just lit -> do - case lits of - l1:ls -> do - assert (litVar lit == litVar l1) $ return () - mapM f ls - _ -> error "XORClauseHandler.constrReasonOf: should not happen" - return xs - where - f :: Lit -> IO Lit - f lit = do - let v = litVar lit - val <- varValue solver v - return $ literal v (not (fromJust (unliftBool val))) - - constrOnUnassigned _solver _this _this2 _lit = return () - - isPBRepresentable _ = return False - - toPBLinAtLeast _ = error "XORClauseHandler does not support toPBLinAtLeast" - - isSatisfied solver this = do - lits <- getElems (xorLits this) - vals <- mapM (litValue solver) lits - let f x y - | x == lUndef || y == lUndef = lUndef - | otherwise = liftBool (x /= y) - return $ foldl' f lFalse vals == lTrue - - constrIsProtected _ this = do - size <- liftM rangeSize (getBounds (xorLits this)) - return $! size <= 2 - - constrReadActivity this = readIORef (xorActivity this) - - constrWriteActivity this aval = writeIORef (xorActivity this) $! aval - -basicAttachXORClauseHandler :: Solver -> XORClauseHandler -> IO Bool -basicAttachXORClauseHandler solver this = do - lits <- getElems (xorLits this) - let constr = toConstraintHandler this - case lits of - [] -> do - markBad solver - return False - [l1] -> do - assignBy solver l1 constr - l1:l2:_ -> do - watchVar solver (litVar l1) constr - watchVar solver (litVar l2) constr - return True - -{-------------------------------------------------------------------- - Arbitrary Boolean Theory ---------------------------------------------------------------------} - -setTheory :: Solver -> TheorySolver -> IO () -setTheory solver tsolver = do - d <- getDecisionLevel solver - assert (d == levelRoot) $ return () - - m <- readIORef (svTheorySolver solver) - case m of - Just _ -> do - error $ "ToySolver.SAT.setTheory: cannot replace TheorySolver" - Nothing -> do - writeIORef (svTheorySolver solver) (Just tsolver) - ret <- deduce solver - case ret of - Nothing -> return () - Just _ -> markBad solver - -getTheory :: Solver -> IO (Maybe TheorySolver) -getTheory solver = readIORef (svTheorySolver solver) - -deduceT :: Solver -> ExceptT SomeConstraintHandler IO () -deduceT solver = do - mt <- liftIO $ readIORef (svTheorySolver solver) - case mt of - Nothing -> return () - Just t -> do - n <- liftIO $ Vec.getSize (svTrail solver) - let h = CHTheory TheoryHandler - callback l = assignBy solver l h - loop i = do - when (i < n) $ do - l <- liftIO $ Vec.unsafeRead (svTrail solver) i - ok <- liftIO $ thAssertLit t callback l - if ok then - loop (i+1) - else - throwE h - loop =<< liftIO (readIOURef (svTheoryChecked solver)) - b2 <- liftIO $ thCheck t callback - if b2 then do - liftIO $ writeIOURef (svTheoryChecked solver) n - else - throwE h - -data TheoryHandler = TheoryHandler deriving (Eq) - -instance Hashable TheoryHandler where - hash _ = hash () - hashWithSalt = defaultHashWithSalt - -instance ConstraintHandler TheoryHandler where - toConstraintHandler = CHTheory - - showConstraintHandler _this = return "TheoryHandler" - - constrAttach _solver _this _this2 = error "TheoryHandler.constrAttach" - - constrDetach _solver _this _this2 = return () - - constrIsLocked _solver _this _this2 = return True - - constrPropagate _solver _this _this2 _falsifiedLit = error "TheoryHandler.constrPropagate" - - constrReasonOf solver _this l = do - Just t <- readIORef (svTheorySolver solver) - lits <- thExplain t l - return $ [-lit | lit <- lits] - - constrOnUnassigned _solver _this _this2 _lit = return () - - isPBRepresentable _this = return False - - toPBLinAtLeast _this = error "TheoryHandler.toPBLinAtLeast" - - isSatisfied _solver _this = error "TheoryHandler.isSatisfied" - - constrIsProtected _solver _this = error "TheoryHandler.constrIsProtected" - - constrReadActivity _this = return 0 - - constrWriteActivity _this _aval = return () - -{-------------------------------------------------------------------- - Restart strategy ---------------------------------------------------------------------} - -mkRestartSeq :: RestartStrategy -> Int -> Double -> [Int] -mkRestartSeq MiniSATRestarts = miniSatRestartSeq -mkRestartSeq ArminRestarts = arminRestartSeq -mkRestartSeq LubyRestarts = lubyRestartSeq - -miniSatRestartSeq :: Int -> Double -> [Int] -miniSatRestartSeq start inc = iterate (ceiling . (inc *) . fromIntegral) start - -{- -miniSatRestartSeq :: Int -> Double -> [Int] -miniSatRestartSeq start inc = map round $ iterate (inc*) (fromIntegral start) --} - -arminRestartSeq :: Int -> Double -> [Int] -arminRestartSeq start inc = go (fromIntegral start) (fromIntegral start) - where - go !inner !outer = round inner : go inner' outer' - where - (inner',outer') = - if inner >= outer - then (fromIntegral start, outer * inc) - else (inner * inc, outer) - -lubyRestartSeq :: Int -> Double -> [Int] -lubyRestartSeq start inc = map (ceiling . (fromIntegral start *) . luby inc) [0..] - -{- - Finite subsequences of the Luby-sequence: - - 0: 1 - 1: 1 1 2 - 2: 1 1 2 1 1 2 4 - 3: 1 1 2 1 1 2 4 1 1 2 1 1 2 4 8 - ... - - --} -luby :: Double -> Integer -> Double -luby y x = go2 size1 sequ1 x - where - -- Find the finite subsequence that contains index 'x', and the - -- size of that subsequence: - (size1, sequ1) = go 1 0 - - go :: Integer -> Integer -> (Integer, Integer) - go size sequ - | size < x+1 = go (2*size+1) (sequ+1) - | otherwise = (size, sequ) - - go2 :: Integer -> Integer -> Integer -> Double - go2 size sequ x2 - | size-1 /= x2 = let size' = (size-1) `div` 2 in go2 size' (sequ - 1) (x2 `mod` size') - | otherwise = y ^ sequ - - -{-------------------------------------------------------------------- - utility ---------------------------------------------------------------------} - -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM p = go - where - go [] = return True - go (x:xs) = do - b <- p x - if b - then go xs - else return False - -anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool -anyM p = go - where - go [] = return False - go (x:xs) = do - b <- p x - if b - then return True - else go xs - -shift :: IORef [a] -> IO a -shift ref = do - (x:xs) <- readIORef ref - writeIORef ref xs - return x - -defaultHashWithSalt :: Hashable a => Int -> a -> Int -defaultHashWithSalt salt x = salt `combine` hash x -#if MIN_VERSION_hashable(1,2,0) - where - combine :: Int -> Int -> Int - combine h1 h2 = (h1 * 16777619) `xor` h2 -#endif - -{-------------------------------------------------------------------- - debug ---------------------------------------------------------------------} - -debugMode :: Bool -debugMode = False - -checkSatisfied :: Solver -> IO () -checkSatisfied solver = do - cls <- readIORef (svConstrDB solver) - forM_ cls $ \c -> do - b <- isSatisfied solver c - unless b $ do - s <- showConstraintHandler c - log solver $ "BUG: " ++ s ++ " is violated" - -dumpVarActivity :: Solver -> IO () -dumpVarActivity solver = do - log solver "Variable activity:" - vs <- variables solver - forM_ vs $ \v -> do - activity <- varActivity solver v - log solver $ printf "activity(%d) = %d" v activity - -dumpConstrActivity :: Solver -> IO () -dumpConstrActivity solver = do - log solver "Learnt constraints activity:" - xs <- learntConstraints solver - forM_ xs $ \c -> do - s <- showConstraintHandler c - aval <- constrReadActivity c - log solver $ printf "activity(%s) = %f" s aval - --- | set callback function for receiving messages. -setLogger :: Solver -> (String -> IO ()) -> IO () -setLogger solver logger = do - writeIORef (svLogger solver) (Just logger) - -log :: Solver -> String -> IO () -log solver msg = logIO solver (return msg) - -logIO :: Solver -> IO String -> IO () -logIO solver action = do - m <- readIORef (svLogger solver) - case m of - Nothing -> return () - Just logger -> action >>= logger +module ToySolver.SAT + ( module ToySolver.SAT.Solver.CDCL + ) where + +import ToySolver.SAT.Solver.CDCL diff --git a/src/ToySolver/SAT/Config.hs b/src/ToySolver/SAT/Config.hs deleted file mode 100644 --- a/src/ToySolver/SAT/Config.hs +++ /dev/null @@ -1,203 +0,0 @@ -module ToySolver.SAT.Config - ( -- * Solver configulation - Config (..) - , RestartStrategy (..) - , showRestartStrategy - , parseRestartStrategy - , LearningStrategy (..) - , showLearningStrategy - , parseLearningStrategy - , BranchingStrategy (..) - , showBranchingStrategy - , parseBranchingStrategy - , PBHandlerType (..) - , showPBHandlerType - , parsePBHandlerType - ) where - -import Data.Char -import Data.Default.Class - -data Config - = Config - { configRestartStrategy :: !RestartStrategy - , configRestartFirst :: !Int - -- ^ The initial restart limit. (default 100) - -- Zero and negative values are used to disable restart. - , configRestartInc :: !Double - -- ^ The factor with which the restart limit is multiplied in each restart. (default 1.5) - -- This must be @>1@. - , configLearningStrategy :: !LearningStrategy - , configLearntSizeFirst :: !Int - -- ^ The initial limit for learnt constraints. - -- Negative value means computing default value from problem instance. - , configLearntSizeInc :: !Double - -- ^ The limit for learnt constraints is multiplied with this factor periodically. (default 1.1) - -- This must be @>1@. - , configCCMin :: !Int - -- ^ Controls conflict constraint minimization (0=none, 1=local, 2=recursive) - , configBranchingStrategy :: !BranchingStrategy - , configERWAStepSizeFirst :: !Double - -- ^ step-size α in ERWA and LRB branching heuristic is initialized with this value. (default 0.4) - , configERWAStepSizeDec :: !Double - -- ^ step-size α in ERWA and LRB branching heuristic is decreased by this value after each conflict. (default 0.06) - , configERWAStepSizeMin :: !Double - -- ^ step-size α in ERWA and LRB branching heuristic is decreased until it reach the value. (default 0.06) - , configEMADecay :: !Double - -- ^ inverse of the variable EMA decay factor used by LRB branching heuristic. (default 1 / 0.95) - , configEnablePhaseSaving :: !Bool - , configEnableForwardSubsumptionRemoval :: !Bool - , configEnableBackwardSubsumptionRemoval :: !Bool - , configRandomFreq :: !Double - -- ^ The frequency with which the decision heuristic tries to choose a random variable - , configPBHandlerType :: !PBHandlerType - , configEnablePBSplitClausePart :: !Bool - -- ^ Split PB-constraints into a PB part and a clause part. - -- - -- Example from minisat+ paper: - -- - -- * 4 x1 + 4 x2 + 4 x3 + 4 x4 + 2y1 + y2 + y3 ≥ 4 - -- - -- would be split into - -- - -- * x1 + x2 + x3 + x4 + ¬z ≥ 1 (clause part) - -- - -- * 2 y1 + y2 + y3 + 4 z ≥ 4 (PB part) - -- - -- where z is a newly introduced variable, not present in any other constraint. - -- - -- Reference: - -- - -- * N . Eéen and N. Sörensson. Translating Pseudo-Boolean Constraints into SAT. JSAT 2:1–26, 2006. - -- - , configCheckModel :: !Bool - , configVarDecay :: !Double - -- ^ Inverse of the variable activity decay factor. (default 1 / 0.95) - , configConstrDecay :: !Double - -- ^ Inverse of the constraint activity decay factor. (1 / 0.999) - } deriving (Show, Eq, Ord) - -instance Default Config where - def = - Config - { configRestartStrategy = def - , configRestartFirst = 100 - , configRestartInc = 1.5 - , configLearningStrategy = def - , configLearntSizeFirst = -1 - , configLearntSizeInc = 1.1 - , configCCMin = 2 - , configBranchingStrategy = def - , configERWAStepSizeFirst = 0.4 - , configERWAStepSizeDec = 10**(-6) - , configERWAStepSizeMin = 0.06 - , configEMADecay = 1 / 0.95 - , configEnablePhaseSaving = True - , configEnableForwardSubsumptionRemoval = False - , configEnableBackwardSubsumptionRemoval = False - , configRandomFreq = 0.005 - , configPBHandlerType = def - , configEnablePBSplitClausePart = False - , configCheckModel = False - , configVarDecay = 1 / 0.95 - , configConstrDecay = 1 / 0.999 - } - --- | Restart strategy. --- --- The default value can be obtained by 'def'. -data RestartStrategy = MiniSATRestarts | ArminRestarts | LubyRestarts - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Default RestartStrategy where - def = MiniSATRestarts - -showRestartStrategy :: RestartStrategy -> String -showRestartStrategy MiniSATRestarts = "minisat" -showRestartStrategy ArminRestarts = "armin" -showRestartStrategy LubyRestarts = "luby" - -parseRestartStrategy :: String -> Maybe RestartStrategy -parseRestartStrategy s = - case map toLower s of - "minisat" -> Just MiniSATRestarts - "armin" -> Just ArminRestarts - "luby" -> Just LubyRestarts - _ -> Nothing - --- | Learning strategy. --- --- The default value can be obtained by 'def'. -data LearningStrategy - = LearningClause - | LearningHybrid - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Default LearningStrategy where - def = LearningClause - -showLearningStrategy :: LearningStrategy -> String -showLearningStrategy LearningClause = "clause" -showLearningStrategy LearningHybrid = "hybrid" - -parseLearningStrategy :: String -> Maybe LearningStrategy -parseLearningStrategy s = - case map toLower s of - "clause" -> Just LearningClause - "hybrid" -> Just LearningHybrid - _ -> Nothing - --- | Branching strategy. --- --- The default value can be obtained by 'def'. --- --- 'BranchingERWA' and 'BranchingLRB' is based on [Liang et al 2016]. --- --- * J. Liang, V. Ganesh, P. Poupart, and K. Czarnecki, "Learning rate based branching heuristic for SAT solvers," --- in Proceedings of Theory and Applications of Satisfiability Testing (SAT 2016), pp. 123-140. --- --- -data BranchingStrategy - = BranchingVSIDS - -- ^ VSIDS (Variable State Independent Decaying Sum) branching heuristic - | BranchingERWA - -- ^ ERWA (Exponential Recency Weighted Average) branching heuristic - | BranchingLRB - -- ^ LRB (Learning Rate Branching) heuristic - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Default BranchingStrategy where - def = BranchingVSIDS - -showBranchingStrategy :: BranchingStrategy -> String -showBranchingStrategy BranchingVSIDS = "vsids" -showBranchingStrategy BranchingERWA = "erwa" -showBranchingStrategy BranchingLRB = "lrb" - -parseBranchingStrategy :: String -> Maybe BranchingStrategy -parseBranchingStrategy s = - case map toLower s of - "vsids" -> Just BranchingVSIDS - "erwa" -> Just BranchingERWA - "lrb" -> Just BranchingLRB - _ -> Nothing - --- | Pseudo boolean constraint handler implimentation. --- --- The default value can be obtained by 'def'. -data PBHandlerType = PBHandlerTypeCounter | PBHandlerTypePueblo - deriving (Show, Eq, Ord, Enum, Bounded) - -instance Default PBHandlerType where - def = PBHandlerTypeCounter - -showPBHandlerType :: PBHandlerType -> String -showPBHandlerType PBHandlerTypeCounter = "counter" -showPBHandlerType PBHandlerTypePueblo = "pueblo" - -parsePBHandlerType :: String -> Maybe PBHandlerType -parsePBHandlerType s = - case map toLower s of - "counter" -> Just PBHandlerTypeCounter - "pueblo" -> Just PBHandlerTypePueblo - _ -> Nothing diff --git a/src/ToySolver/SAT/Encoder/Cardinality.hs b/src/ToySolver/SAT/Encoder/Cardinality.hs --- a/src/ToySolver/SAT/Encoder/Cardinality.hs +++ b/src/ToySolver/SAT/Encoder/Cardinality.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -19,6 +20,11 @@ , newEncoder , newEncoderWithStrategy , encodeAtLeast + + -- XXX + , TotalizerDefinitions + , getTotalizerDefinitions + , evalTotalizerDefinitions ) where import Control.Monad.Primitive @@ -26,43 +32,71 @@ import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin import ToySolver.SAT.Encoder.Cardinality.Internal.Naive import ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter +import ToySolver.SAT.Encoder.PB.Internal.BDD as BDD +import qualified ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer as Totalizer -- ------------------------------------------------------------------- -data Encoder m = Encoder (Tseitin.Encoder m) Strategy +-- XXX +data Encoder m = Encoder (Totalizer.Encoder m) Strategy data Strategy = Naive + | SequentialCounter | ParallelCounter + | Totalizer deriving (Show, Eq, Ord, Enum, Bounded) +{- +"Sequential Counter" from "Towards an Optimal CNF Encoding of Boolean +Cardinality Constraints" is a special case of BDD-based encoding of +"Translating Pseudo-Boolean Constraints into SAT" (using the fact C→B +to represent ite(A,B,C) as (A∧B)∨C instead of (A∧B)∨(¬A∧C))? -newEncoder :: Monad m => Tseitin.Encoder m -> m (Encoder m) -newEncoder tseitin = return $ Encoder tseitin ParallelCounter +http://www.carstensinz.de/papers/CP-2005.pdf +http://www.st.ewi.tudelft.nl/jsat/content/volume2/JSAT2_1_Een.pdf +-} -newEncoderWithStrategy :: Monad m => Tseitin.Encoder m -> Strategy -> m (Encoder m) -newEncoderWithStrategy tseitin strategy = return (Encoder tseitin strategy) +newEncoder :: PrimMonad m => Tseitin.Encoder m -> m (Encoder m) +newEncoder tseitin = newEncoderWithStrategy tseitin ParallelCounter +newEncoderWithStrategy :: PrimMonad m => Tseitin.Encoder m -> Strategy -> m (Encoder m) +newEncoderWithStrategy tseitin strategy = do + base <- Totalizer.newEncoder tseitin + return $ Encoder base strategy + +type TotalizerDefinitions = Totalizer.Definitions + +getTotalizerDefinitions :: PrimMonad m => Encoder m -> m TotalizerDefinitions +getTotalizerDefinitions (Encoder base _) = Totalizer.getDefinitions base + +evalTotalizerDefinitions :: SAT.IModel m => m -> TotalizerDefinitions -> [(SAT.Var, Bool)] +evalTotalizerDefinitions m defs = Totalizer.evalDefinitions m defs + -- getTseitinEncoder :: Encoder m -> Tseitin.Encoder m -- getTseitinEncoder (Encoder tseitin _) = tseitin instance Monad m => SAT.NewVar m (Encoder m) where - newVar (Encoder tseitin _) = SAT.newVar tseitin - newVars (Encoder tseitin _) = SAT.newVars tseitin - newVars_ (Encoder tseitin _) = SAT.newVars_ tseitin + newVar (Encoder base _) = SAT.newVar base + newVars (Encoder base _) = SAT.newVars base + newVars_ (Encoder base _) = SAT.newVars_ base instance Monad m => SAT.AddClause m (Encoder m) where - addClause (Encoder tseitin _) = SAT.addClause tseitin + addClause (Encoder base _) = SAT.addClause base instance PrimMonad m => SAT.AddCardinality m (Encoder m) where - addAtLeast (Encoder tseitin strategy) lhs rhs + addAtLeast (Encoder base@(Totalizer.Encoder tseitin _) strategy) lhs rhs | rhs <= 0 = return () | otherwise = case strategy of Naive -> addAtLeastNaive tseitin (lhs,rhs) ParallelCounter -> addAtLeastParallelCounter tseitin (lhs,rhs) + SequentialCounter -> BDD.addPBLinAtLeastBDD tseitin ([(1,l) | l <- lhs], fromIntegral rhs) + Totalizer -> Totalizer.addAtLeast base (lhs,rhs) encodeAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m SAT.Lit -encodeAtLeast (Encoder tseitin strategy) = +encodeAtLeast (Encoder base@(Totalizer.Encoder tseitin _) strategy) = case strategy of Naive -> encodeAtLeastNaive tseitin ParallelCounter -> encodeAtLeastParallelCounter tseitin + SequentialCounter -> \(lhs,rhs) -> BDD.encodePBLinAtLeastBDD tseitin ([(1,l) | l <- lhs], fromIntegral rhs) + Totalizer -> Totalizer.encodeAtLeast base diff --git a/src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs b/src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs --- a/src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs +++ b/src/ToySolver/SAT/Encoder/Cardinality/Internal/ParallelCounter.hs @@ -1,9 +1,10 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | --- Module : ToySolver.SAT.Encoder.Cardinality.Internal +-- Module : ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter -- Copyright : (c) Masahiro Sakai 2019 -- License : BSD-style -- @@ -33,10 +34,15 @@ -- TODO: consider polarity encodeAtLeastParallelCounter :: forall m. PrimMonad m => Tseitin.Encoder m -> SAT.AtLeast -> m SAT.Lit encodeAtLeastParallelCounter enc (lhs,rhs) = do - let rhs_bits = bits (fromIntegral rhs) - (cnt, overflowBits) <- encodeSumParallelCounter enc (length rhs_bits) lhs - isGE <- encodeGE enc cnt rhs_bits - Tseitin.encodeDisj enc $ isGE : overflowBits + if rhs <= 0 then + Tseitin.encodeConj enc [] + else if length lhs < rhs then + Tseitin.encodeDisj enc [] + else do + let rhs_bits = bits (fromIntegral rhs) + (cnt, overflowBits) <- encodeSumParallelCounter enc (length rhs_bits) lhs + isGE <- encodeGE enc cnt rhs_bits + Tseitin.encodeDisj enc $ isGE : overflowBits where bits :: Integer -> [Bool] bits n = f n 0 diff --git a/src/ToySolver/SAT/Encoder/Cardinality/Internal/Totalizer.hs b/src/ToySolver/SAT/Encoder/Cardinality/Internal/Totalizer.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Encoder/Cardinality/Internal/Totalizer.hs @@ -0,0 +1,164 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer +-- Copyright : (c) Masahiro Sakai 2020 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer + ( Encoder (..) + , newEncoder + + , Definitions + , getDefinitions + , evalDefinitions + + , addAtLeast + , encodeAtLeast + + , addCardinality + , encodeCardinality + + , encodeSum + ) where + +import Control.Monad.Primitive +import Control.Monad.State.Strict +import qualified Data.IntSet as IntSet +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Primitive.MutVar +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V +import qualified ToySolver.SAT.Types as SAT +import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin + + +data Encoder m = Encoder (Tseitin.Encoder m) (MutVar (PrimState m) (Map SAT.LitSet (Vector SAT.Var))) + +instance Monad m => SAT.NewVar m (Encoder m) where + newVar (Encoder a _) = SAT.newVar a + newVars (Encoder a _) = SAT.newVars a + newVars_ (Encoder a _) = SAT.newVars_ a + +instance Monad m => SAT.AddClause m (Encoder m) where + addClause (Encoder a _) = SAT.addClause a + +newEncoder :: PrimMonad m => Tseitin.Encoder m -> m (Encoder m) +newEncoder tseitin = do + tableRef <- newMutVar Map.empty + return $ Encoder tseitin tableRef + + +type Definitions = [(Vector SAT.Var, SAT.LitSet)] + +getDefinitions :: PrimMonad m => Encoder m -> m Definitions +getDefinitions (Encoder _ tableRef) = do + m <- readMutVar tableRef + return [(vars', lits) | (lits, vars') <- Map.toList m] + + +evalDefinitions :: SAT.IModel m => m -> Definitions -> [(SAT.Var, Bool)] +evalDefinitions m defs = do + (vars', lits) <- defs + let n = length [() | l <- IntSet.toList lits, SAT.evalLit m l] + (i, v) <- zip [1..] (V.toList vars') + return (v, i <= n) + + +addAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m () +addAtLeast enc (lhs, rhs) = do + addCardinality enc lhs (rhs, length lhs) + + +addCardinality :: PrimMonad m => Encoder m -> [SAT.Lit] -> (Int, Int) -> m () +addCardinality enc lits (lb, ub) = do + let n = length lits + if lb <= 0 && n <= ub then + return () + else if n < lb || ub < 0 then + SAT.addClause enc [] + else do + lits' <- encodeSum enc lits + forM_ (take lb lits') $ \l -> SAT.addClause enc [l] + forM_ (drop ub lits') $ \l -> SAT.addClause enc [- l] + + +-- TODO: consider polarity +encodeAtLeast :: PrimMonad m => Encoder m -> SAT.AtLeast -> m SAT.Lit +encodeAtLeast enc (lhs,rhs) = do + encodeCardinality enc lhs (rhs, length lhs) + + +-- TODO: consider polarity +encodeCardinality :: PrimMonad m => Encoder m -> [SAT.Lit] -> (Int, Int) -> m SAT.Lit +encodeCardinality enc@(Encoder tseitin _) lits (lb, ub) = do + let n = length lits + if lb <= 0 && n <= ub then + Tseitin.encodeConj tseitin [] + else if n < lb || ub < 0 then + Tseitin.encodeDisj tseitin [] + else do + lits' <- encodeSum enc lits + forM_ (zip lits' (tail lits')) $ \(l1, l2) -> do + SAT.addClause enc [-l2, l1] -- l2→l1 or equivalently ¬l1→¬l2 + Tseitin.encodeConj tseitin $ + [lits' !! (lb - 1) | lb > 0] ++ [- (lits' !! (ub + 1 - 1)) | ub < n] + + +encodeSum :: PrimMonad m => Encoder m -> [SAT.Lit] -> m [SAT.Lit] +encodeSum enc = liftM V.toList . encodeSumV enc . V.fromList + + +encodeSumV :: PrimMonad m => Encoder m -> Vector SAT.Lit -> m (Vector SAT.Lit) +encodeSumV (Encoder enc tableRef) = f + where + f lits + | n <= 1 = return lits + | otherwise = do + m <- readMutVar tableRef + let key = IntSet.fromList (V.toList lits) + case Map.lookup key m of + Just vars -> return vars + Nothing -> do + rs <- liftM V.fromList $ SAT.newVars enc n + writeMutVar tableRef (Map.insert key rs m) + case V.splitAt n1 lits of + (lits1, lits2) -> do + lits1' <- f lits1 + lits2' <- f lits2 + forM_ [0 .. n] $ \sigma -> + -- a + b = sigma, 0 <= a <= n1, 0 <= b <= n2 + forM_ [max 0 (sigma - n2) .. min n1 sigma] $ \a -> do + let b = sigma - a + -- card(lits1) >= a ∧ card(lits2) >= b → card(lits) >= sigma + -- ¬(card(lits1) >= a) ∨ ¬(card(lits2) >= b) ∨ card(lits) >= sigma + unless (sigma == 0) $ do + SAT.addClause enc $ + [- (lits1' V.! (a - 1)) | a > 0] ++ + [- (lits2' V.! (b - 1)) | b > 0] ++ + [rs V.! (sigma - 1)] + -- card(lits) > sigma → (card(lits1) > a ∨ card(lits2) > b) + -- card(lits) >= sigma+1 → (card(lits1) >= a+1 ∨ card(lits2) >= b+1) + -- card(lits1) >= a+1 ∨ card(lits2) >= b+1 ∨ ¬(card(lits) >= sigma+1) + unless (sigma + 1 == n + 1) $ do + SAT.addClause enc $ + [lits1' V.! (a + 1 - 1) | a + 1 < n1 + 1] ++ + [lits2' V.! (b + 1 - 1) | b + 1 < n2 + 1] ++ + [- (rs V.! (sigma + 1 - 1))] + return rs + where + n = V.length lits + n1 = n `div` 2 + n2 = n - n1 + diff --git a/src/ToySolver/SAT/Encoder/Integer.hs b/src/ToySolver/SAT/Encoder/Integer.hs --- a/src/ToySolver/SAT/Encoder/Integer.hs +++ b/src/ToySolver/SAT/Encoder/Integer.hs @@ -1,4 +1,16 @@ +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Encoder.Integer +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.Integer ( Expr (..) , newVar diff --git a/src/ToySolver/SAT/Encoder/PB.hs b/src/ToySolver/SAT/Encoder/PB.hs --- a/src/ToySolver/SAT/Encoder/PB.hs +++ b/src/ToySolver/SAT/Encoder/PB.hs @@ -1,14 +1,18 @@ -{-# LANGUAGE BangPatterns, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.PB -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- -- References: -- diff --git a/src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs b/src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs --- a/src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs +++ b/src/ToySolver/SAT/Encoder/PB/Internal/Adder.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.PB.Internal.Adder -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable diff --git a/src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs b/src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs --- a/src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs +++ b/src/ToySolver/SAT/Encoder/PB/Internal/BDD.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.PB.Internal.BDD -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable diff --git a/src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs b/src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs --- a/src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs +++ b/src/ToySolver/SAT/Encoder/PB/Internal/Sorter.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.PB.Internal.Sorter -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable diff --git a/src/ToySolver/SAT/Encoder/PBNLC.hs b/src/ToySolver/SAT/Encoder/PBNLC.hs --- a/src/ToySolver/SAT/Encoder/PBNLC.hs +++ b/src/ToySolver/SAT/Encoder/PBNLC.hs @@ -1,15 +1,19 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.PBNLC -- Copyright : (c) Masahiro Sakai 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ExistentialQuantification, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses) --- +-- Portability : non-portable +-- ----------------------------------------------------------------------------- module ToySolver.SAT.Encoder.PBNLC ( @@ -20,7 +24,7 @@ -- * Adding constraints , addPBNLAtLeast - , addPBNLAtMost + , addPBNLAtMost , addPBNLExactly , addPBNLAtLeastSoft , addPBNLAtMostSoft @@ -113,7 +117,7 @@ -- * If @'polarityPosOccurs' p@, the value of resulting 'PBLinSum' is /greater than/ or /equal to/ the value of original 'PBSum'. -- -- * If @'polarityNegOccurs' p@, the value of resulting 'PBLinSum' is /lesser than/ or /equal to/ the value of original 'PBSum'. --- +-- linearizePBSumWithPolarity :: PrimMonad m => Encoder m diff --git a/src/ToySolver/SAT/Encoder/Tseitin.hs b/src/ToySolver/SAT/Encoder/Tseitin.hs --- a/src/ToySolver/SAT/Encoder/Tseitin.hs +++ b/src/ToySolver/SAT/Encoder/Tseitin.hs @@ -1,35 +1,39 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Encoder.Tseitin -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, ExistentialQuantification) --- +-- Portability : non-portable +-- -- Tseitin encoding -- -- TODO: --- +-- -- * reduce variables. -- -- References: -- -- * [Tse83] G. Tseitin. On the complexity of derivation in propositional -- calculus. Automation of Reasoning: Classical Papers in Computational --- Logic, 2:466-483, 1983. Springer-Verlag. +-- Logic, 2:466-483, 1983. Springer-Verlag. -- -- * [For60] R. Fortet. Application de l'algèbre de Boole en rechercheop -- opérationelle. Revue Française de Recherche Opérationelle, 4:17-26, --- 1960. +-- 1960. -- -- * [BM84a] E. Balas and J. B. Mazzola. Nonlinear 0-1 programming: -- I. Linearization techniques. Mathematical Programming, 30(1):1-21, -- 1984. --- +-- -- * [BM84b] E. Balas and J. B. Mazzola. Nonlinear 0-1 programming: -- II. Dominance relations and algorithms. Mathematical Programming, -- 30(1):22-45, 1984. @@ -345,7 +349,7 @@ SAT.addClause encoder [-x, -c, t] SAT.addClause encoder [-x, c, e] SAT.addClause encoder [t, e, -x] -- redundant, but will increase the strength of unit propagation. - + defineNeg :: SAT.Lit -> m () defineNeg x = do -- ite(c,t,e) → x @@ -399,10 +403,10 @@ definePos x = do -- x → FASum(a,b,c) -- ⇔ ¬FASum(a,b,c) → ¬x - SAT.addClause encoder [a,b,c,-x] -- ¬a ∧ ¬b ∧ ¬c → -x - SAT.addClause encoder [a,-b,-c,-x] -- ¬a ∧ b ∧ c → -x - SAT.addClause encoder [-a,b,-c,-x] -- a ∧ ¬b ∧ c → -x - SAT.addClause encoder [-a,-b,c,-x] -- a ∧ b ∧ ¬c → -x + SAT.addClause encoder [a,b,c,-x] -- ¬a ∧ ¬b ∧ ¬c → ¬x + SAT.addClause encoder [a,-b,-c,-x] -- ¬a ∧ b ∧ c → ¬x + SAT.addClause encoder [-a,b,-c,-x] -- a ∧ ¬b ∧ c → ¬x + SAT.addClause encoder [-a,-b,c,-x] -- a ∧ b ∧ ¬c → ¬x encodeWithPolarityHelper encoder (encFASumTable encoder) definePos defineNeg polarity (a,b,c) -- | Return an "carry"-pin of a full-adder. diff --git a/src/ToySolver/SAT/ExistentialQuantification.hs b/src/ToySolver/SAT/ExistentialQuantification.hs --- a/src/ToySolver/SAT/ExistentialQuantification.hs +++ b/src/ToySolver/SAT/ExistentialQuantification.hs @@ -1,5 +1,6 @@ {-# Language BangPatterns #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ---------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.ExistentialQuantification @@ -66,12 +67,14 @@ CNF.CNF { CNF.cnfNumVars = CNF.cnfNumVars cnf + IntSet.size vs , CNF.cnfNumClauses = CNF.cnfNumClauses cnf + IntSet.size vs - , CNF.cnfClauses = [ VG.map f c | c <- CNF.cnfClauses cnf ] ++ [SAT.packClause [-xp,-xn] | (xp,xn) <- IntMap.elems forward] + , CNF.cnfClauses = + [ VG.map f c | c <- CNF.cnfClauses cnf ] ++ + [ SAT.packClause [-xp,-xn] | (xp,xn) <- IntMap.elems forward ] } f x = - case IntMap.lookup (abs x) forward of + case IntMap.lookup (abs (SAT.unpackLit x)) forward of Nothing -> x - Just (xp,xn) -> if x > 0 then xp else xn + Just (xp,xn) -> SAT.packLit $ if x > 0 then xp else xn forward = IntMap.fromList [ (x, (x,x')) @@ -103,7 +106,7 @@ blockingClause :: Info -> SAT.Model -> Clause blockingClause info m = [-y | y <- IntMap.keys (backwardMap info), SAT.evalLit m y] -{-# DEPRECATED shortestImplicants "Use shortestImplicantsE instead" #-} +{-# DEPRECATED shortestImplicants "Use shortestImplicantsE instead" #-} -- | Given a set of variables \(X = \{x_1, \ldots, x_k\}\) and CNF formula \(\phi\), -- this function computes shortest implicants of \(\phi\) in terms of \(X\). -- Variables except \(X\) are treated as if they are existentially quantified. diff --git a/src/ToySolver/SAT/MUS.hs b/src/ToySolver/SAT/MUS.hs --- a/src/ToySolver/SAT/MUS.hs +++ b/src/ToySolver/SAT/MUS.hs @@ -4,10 +4,10 @@ -- Module : ToySolver.SAT.MUS -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable +-- Portability : portable -- -- Minimal Unsatifiable Subset (MUS) Finder -- diff --git a/src/ToySolver/SAT/MUS/Base.hs b/src/ToySolver/SAT/MUS/Base.hs --- a/src/ToySolver/SAT/MUS/Base.hs +++ b/src/ToySolver/SAT/MUS/Base.hs @@ -3,9 +3,10 @@ -- Module : ToySolver.SAT.MUS.Base -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional +-- Portability : portable -- ----------------------------------------------------------------------------- module ToySolver.SAT.MUS.Base diff --git a/src/ToySolver/SAT/MUS/Deletion.hs b/src/ToySolver/SAT/MUS/Deletion.hs --- a/src/ToySolver/SAT/MUS/Deletion.hs +++ b/src/ToySolver/SAT/MUS/Deletion.hs @@ -3,10 +3,10 @@ -- Module : ToySolver.SAT.MUS.Deletion -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable +-- Portability : portable -- -- Minimal Unsatifiable Subset (MUS) Finder -- @@ -32,7 +32,7 @@ -> IO MUS findMUSAssumptions solver opt = do log "computing a minimal unsatisfiable core by deletion method" - core <- liftM IS.fromList $ SAT.getFailedAssumptions solver + core <- SAT.getFailedAssumptions solver log $ "initial core = " ++ showLits core update core if IS.null core then @@ -63,7 +63,7 @@ log $ "trying to remove " ++ showLit l ret <- SAT.solveWith solver (IS.toList ls) if not ret then do - ls2 <- liftM IS.fromList $ SAT.getFailedAssumptions solver + ls2 <- SAT.getFailedAssumptions solver let removed = ls1 `IS.difference` ls2 log $ "successed to remove " ++ showLits removed log $ "new core = " ++ showLits (ls2 `IS.union` fixed) diff --git a/src/ToySolver/SAT/MUS/Enum.hs b/src/ToySolver/SAT/MUS/Enum.hs --- a/src/ToySolver/SAT/MUS/Enum.hs +++ b/src/ToySolver/SAT/MUS/Enum.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- @@ -6,10 +7,10 @@ -- Module : ToySolver.SAT.MUS.Enum -- Copyright : (c) Masahiro Sakai 2012-2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (MultiParamTypeClasses) +-- Portability : non-portable -- -- In this module, we assume each soft constraint /C_i/ is represented as a literal. -- If a constraint /C_i/ is not a literal, we can represent it as a fresh variable /v/ @@ -19,7 +20,7 @@ -- -- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal -- unsatisfiable subsets of constraints, Journal of Automated Reasoning, --- vol. 40, no. 1, pp. 1-33, Jan. 2008. +-- vol. 40, no. 1, pp. 1-33, Jan. 2008. -- -- -- * [HYCAM] A. Gregoire, B. Mazure, and C. Piette, Boosting a complete @@ -116,7 +117,7 @@ return $ I.InterestingSet $ IntSet.fromList [l | l <- IntSet.toList univ, optEvalConstr opt m l] else do zs <- SAT.getFailedAssumptions solver - return $ I.UninterestingSet $ IntSet.fromList zs + return $ I.UninterestingSet zs grow prob@(Problem _ _ opt) xs = do optLogger opt $ show (optMethod opt) ++ ": grow " ++ showLits prob xs diff --git a/src/ToySolver/SAT/MUS/Enum/Base.hs b/src/ToySolver/SAT/MUS/Enum/Base.hs --- a/src/ToySolver/SAT/MUS/Enum/Base.hs +++ b/src/ToySolver/SAT/MUS/Enum/Base.hs @@ -1,3 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.MUS.Enum.Base +-- Copyright : (c) Masahiro Sakai 2016 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.SAT.MUS.Enum.Base ( module ToySolver.SAT.MUS.Types , Method (..) diff --git a/src/ToySolver/SAT/MUS/Enum/CAMUS.hs b/src/ToySolver/SAT/MUS/Enum/CAMUS.hs --- a/src/ToySolver/SAT/MUS/Enum/CAMUS.hs +++ b/src/ToySolver/SAT/MUS/Enum/CAMUS.hs @@ -3,7 +3,7 @@ -- Module : ToySolver.SAT.MUS.Enum.CAMUS -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -16,7 +16,7 @@ -- -- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal -- unsatisfiable subsets of constraints, Journal of Automated Reasoning, --- vol. 40, no. 1, pp. 1-33, Jan. 2008. +-- vol. 40, no. 1, pp. 1-33, Jan. 2008. -- -- -- * [HYCAM] A. Gregoire, B. Mazure, and C. Piette, Boosting a complete @@ -91,7 +91,7 @@ allMCSAssumptions :: SAT.Solver -> [Lit] -> Options -> IO [MCS] allMCSAssumptions solver sels opt = do - ref <- newIORef [] + ref <- newIORef [] let opt2 = opt { optOnMCSFound = \mcs -> do diff --git a/src/ToySolver/SAT/MUS/Insertion.hs b/src/ToySolver/SAT/MUS/Insertion.hs --- a/src/ToySolver/SAT/MUS/Insertion.hs +++ b/src/ToySolver/SAT/MUS/Insertion.hs @@ -3,10 +3,10 @@ -- Module : ToySolver.SAT.MUS.Insertion -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable +-- Portability : portable -- -- Minimal Unsatifiable Subset (MUS) Finder -- @@ -36,7 +36,7 @@ -> IO MUS findMUSAssumptions solver opt = do log "computing a minimal unsatisfiable core by insertion method" - core <- liftM IntSet.fromList $ SAT.getFailedAssumptions solver + core <- SAT.getFailedAssumptions solver log $ "initial core = " ++ showLits core update core if IntSet.null core then diff --git a/src/ToySolver/SAT/MUS/QuickXplain.hs b/src/ToySolver/SAT/MUS/QuickXplain.hs --- a/src/ToySolver/SAT/MUS/QuickXplain.hs +++ b/src/ToySolver/SAT/MUS/QuickXplain.hs @@ -3,10 +3,10 @@ -- Module : ToySolver.SAT.MUS.QuickXplain -- Copyright : (c) Masahiro Sakai 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable +-- Portability : portable -- -- Minimal Unsatifiable Subset (MUS) Finder based on QuickXplain algorithm. -- @@ -39,7 +39,7 @@ -> IO MUS findMUSAssumptions solver opt = do log "computing a minimal unsatisfiable core by QuickXplain" - core <- liftM IS.fromList $ SAT.getFailedAssumptions solver + core <- SAT.getFailedAssumptions solver log $ "initial core = " ++ showLits core update core if IS.null core then @@ -84,7 +84,7 @@ SAT.solveWith solver (IS.toList bs) if not ret then do log $ showLits bs ++ " is unsatisfiable" - bs' <- liftM IS.fromList $ SAT.getFailedAssumptions solver + bs' <- SAT.getFailedAssumptions solver log $ "new core = " ++ showLits bs' update bs' return (IS.empty, bs') diff --git a/src/ToySolver/SAT/MUS/Types.hs b/src/ToySolver/SAT/MUS/Types.hs --- a/src/ToySolver/SAT/MUS/Types.hs +++ b/src/ToySolver/SAT/MUS/Types.hs @@ -3,7 +3,7 @@ -- Module : ToySolver.SAT.MUS.Types -- Copyright : (c) Masahiro Sakai 2012-2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -16,7 +16,7 @@ -- -- * [CAMUS] M. Liffiton and K. Sakallah, Algorithms for computing minimal -- unsatisfiable subsets of constraints, Journal of Automated Reasoning, --- vol. 40, no. 1, pp. 1-33, Jan. 2008. +-- vol. 40, no. 1, pp. 1-33, Jan. 2008. -- -- ----------------------------------------------------------------------------- @@ -33,12 +33,12 @@ -- | Unsatisfiable Subset of constraints (US). -- --- A subset U ⊆ C is an US if U is unsatisfiable. +-- A subset U ⊆ C is an US if U is unsatisfiable. type US = LitSet -- | Minimal Unsatisfiable Subset of constraints (MUS). -- --- A subset U ⊆ C is an MUS if U is unsatisfiable and ∀C_i ∈ U, U\\{C_i} is satisfiable [CAMUS]. +-- A subset U ⊆ C is an MUS if U is unsatisfiable and ∀C_i ∈ U, U\\{C_i} is satisfiable [CAMUS]. type MUS = LitSet -- | Correction Subset of constraints (CS). diff --git a/src/ToySolver/SAT/MessagePassing/SurveyPropagation.hs b/src/ToySolver/SAT/MessagePassing/SurveyPropagation.hs deleted file mode 100644 --- a/src/ToySolver/SAT/MessagePassing/SurveyPropagation.hs +++ /dev/null @@ -1,467 +0,0 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns, TypeFamilies #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.SAT.MessagePassing.SurveyPropagation --- Copyright : (c) Masahiro Sakai 2016 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns, TypeFamilies) --- --- References: --- --- * Alfredo Braunstein, Marc Mézard and Riccardo Zecchina. --- Survey Propagation: An Algorithm for Satisfiability, --- --- --- * Corrie Scalisi. Visualizing Survey Propagation in 3-SAT Factor Graphs, --- . --- ------------------------------------------------------------------------------ -module ToySolver.SAT.MessagePassing.SurveyPropagation - ( - -- * The Solver type - Solver - , newSolver - , deleteSolver - - -- * Problem information - , getNVars - , getNConstraints - - -- * Parameters - , getTolerance - , setTolerance - , getIterationLimit - , setIterationLimit - , getNThreads - , setNThreads - - -- * Computing marginal distributions - , initializeRandom - , initializeRandomDirichlet - , propagate - , getVarProb - - -- * Solving - , fixLit - , unfixLit - - -- * Debugging - , printInfo - ) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Loop -import Control.Monad -import qualified Data.IntMap as IntMap -import qualified Data.IntSet as IntSet -import Data.IORef -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as VM -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Unboxed.Mutable as VUM -import Data.Vector.Generic ((!)) -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import qualified Numeric.Log as L -import qualified System.Random.MWC as Rand -import qualified System.Random.MWC.Distributions as Rand - -import qualified ToySolver.SAT.Types as SAT - -infixr 8 ^* - -(^*) :: Num a => L.Log a -> a -> L.Log a -L.Exp a ^* b = L.Exp (a*b) - -comp :: (RealFloat a, L.Precise a) => L.Log a -> L.Log a -comp (L.Exp a) = L.Exp $ L.log1p $ max (-1) $ negate (exp a) - -type ClauseIndex = Int -type EdgeIndex = Int - -data Solver - = Solver - { svVarEdges :: !(V.Vector (VU.Vector EdgeIndex)) - , svVarProbT :: !(VUM.IOVector (L.Log Double)) - , svVarProbF :: !(VUM.IOVector (L.Log Double)) - , svVarFixed :: !(VM.IOVector (Maybe Bool)) - - , svClauseEdges :: !(V.Vector (VU.Vector EdgeIndex)) - , svClauseWeight :: !(VU.Vector Double) - - , svEdgeLit :: !(VU.Vector SAT.Lit) -- i - , svEdgeClause :: !(VU.Vector ClauseIndex) -- a - , svEdgeSurvey :: !(VUM.IOVector (L.Log Double)) -- η_{a → i} - , svEdgeProbU :: !(VUM.IOVector (L.Log Double)) -- Π^u_{i → a} / (Π^u_{i → a} + Π^s_{i → a} + Π^0_{i → a}) - - , svTolRef :: !(IORef Double) - , svIterLimRef :: !(IORef (Maybe Int)) - , svNThreadsRef :: !(IORef Int) - } - -newSolver :: Int -> [(Double, SAT.PackedClause)] -> IO Solver -newSolver nv clauses = do - let num_clauses = length clauses - num_edges = sum [VG.length c | (_,c) <- clauses] - - varEdgesRef <- newIORef IntMap.empty - clauseEdgesM <- VGM.new num_clauses - - (edgeLitM :: VUM.IOVector SAT.Lit) <- VGM.new num_edges - (edgeClauseM :: VUM.IOVector ClauseIndex) <- VGM.new num_edges - - ref <- newIORef 0 - forM_ (zip [0..] clauses) $ \(i,(_,c)) -> do - es <- forM (SAT.unpackClause c) $ \lit -> do - e <- readIORef ref - modifyIORef' ref (+1) - modifyIORef' varEdgesRef (IntMap.insertWith IntSet.union (abs lit) (IntSet.singleton e)) - VGM.unsafeWrite edgeLitM e lit - VGM.unsafeWrite edgeClauseM e i - return e - VGM.unsafeWrite clauseEdgesM i (VG.fromList es) - - varEdges <- readIORef varEdgesRef - clauseEdges <- VG.unsafeFreeze clauseEdgesM - - edgeLit <- VG.unsafeFreeze edgeLitM - edgeClause <- VG.unsafeFreeze edgeClauseM - - -- Initialize all surveys with non-zero values. - -- If we initialize to zero, following trivial solution exists: - -- - -- η_{a→i} = 0 for all i and a. - -- - -- Π^0_{i→a} = 1, Π^u_{i→a} = Π^s_{i→a} = 0 for all i and a, - -- - -- \^{Π}^{0}_i = 1, \^{Π}^{+}_i = \^{Π}^{-}_i = 0 - -- - edgeSurvey <- VGM.replicate num_edges 0.5 - edgeProbU <- VGM.new num_edges - - varFixed <- VGM.replicate nv Nothing - varProbT <- VGM.new nv - varProbF <- VGM.new nv - - tolRef <- newIORef 0.01 - maxIterRef <- newIORef (Just 1000) - nthreadsRef <- newIORef 1 - - let solver = Solver - { svVarEdges = VG.generate nv $ \i -> - case IntMap.lookup (i+1) varEdges of - Nothing -> VG.empty - Just es -> VG.fromListN (IntSet.size es) (IntSet.toList es) - , svVarProbT = varProbT - , svVarProbF = varProbF - , svVarFixed = varFixed - - , svClauseEdges = clauseEdges - , svClauseWeight = VG.fromListN (VG.length clauseEdges) (map fst clauses) - - , svEdgeLit = edgeLit - , svEdgeClause = edgeClause - , svEdgeSurvey = edgeSurvey - , svEdgeProbU = edgeProbU - - , svTolRef = tolRef - , svIterLimRef = maxIterRef - , svNThreadsRef = nthreadsRef - } - - return solver - -deleteSolver :: Solver -> IO () -deleteSolver _solver = return () - -initializeRandom :: Solver -> Rand.GenIO -> IO () -initializeRandom solver gen = do - VG.forM_ (svClauseEdges solver) $ \es -> do - case VG.length es of - 0 -> return () - 1 -> VGM.unsafeWrite (svEdgeSurvey solver) (es ! 0) 1 - n -> do - let p :: Double - p = 1 / fromIntegral n - VG.forM_ es $ \e -> do - d <- Rand.uniformR (p*0.5, p*1.5) gen - VGM.unsafeWrite (svEdgeSurvey solver) e (realToFrac d) - -initializeRandomDirichlet :: Solver -> Rand.GenIO -> IO () -initializeRandomDirichlet solver gen = do - VG.forM_ (svClauseEdges solver) $ \es -> do - case VG.length es of - 0 -> return () - 1 -> VGM.unsafeWrite (svEdgeSurvey solver) (es ! 0) 1 - len -> do - (ps :: V.Vector Double) <- Rand.dirichlet (VG.replicate len 1) gen - numLoop 0 (len-1) $ \i -> do - VGM.unsafeWrite (svEdgeSurvey solver) (es ! i) (realToFrac (ps ! i)) - --- | number of variables of the problem. -getNVars :: Solver -> IO Int -getNVars solver = return $ VG.length (svVarEdges solver) - --- | number of constraints of the problem. -getNConstraints :: Solver -> IO Int -getNConstraints solver = return $ VG.length (svClauseEdges solver) - --- | number of edges of the factor graph -getNEdges :: Solver -> IO Int -getNEdges solver = return $ VG.length (svEdgeLit solver) - -getTolerance :: Solver -> IO Double -getTolerance solver = readIORef (svTolRef solver) - -setTolerance :: Solver -> Double -> IO () -setTolerance solver !tol = writeIORef (svTolRef solver) tol - -getIterationLimit :: Solver -> IO (Maybe Int) -getIterationLimit solver = readIORef (svIterLimRef solver) - -setIterationLimit :: Solver -> Maybe Int -> IO () -setIterationLimit solver val = writeIORef (svIterLimRef solver) val - -getNThreads :: Solver -> IO Int -getNThreads solver = readIORef (svNThreadsRef solver) - -setNThreads :: Solver -> Int -> IO () -setNThreads solver val = writeIORef (svNThreadsRef solver) val - -propagate :: Solver -> IO Bool -propagate solver = do - nthreads <- getNThreads solver - if nthreads > 1 then - propagateMT solver nthreads - else - propagateST solver - -propagateST :: Solver -> IO Bool -propagateST solver = do - tol <- getTolerance solver - lim <- getIterationLimit solver - nv <- getNVars solver - nc <- getNConstraints solver - let max_v_len = VG.maximum $ VG.map VG.length $ svVarEdges solver - max_c_len = VG.maximum $ VG.map VG.length $ svClauseEdges solver - tmp <- VGM.new (max (max_v_len * 2) max_c_len) - let loop !i - | Just l <- lim, i >= l = return False - | otherwise = do - numLoop 1 nv $ \v -> updateEdgeProb solver v tmp - let f maxDelta c = max maxDelta <$> updateEdgeSurvey solver c tmp - delta <- foldM f 0 [0 .. nc-1] - if delta <= tol then do - numLoop 1 nv $ \v -> computeVarProb solver v - return True - else - loop (i+1) - loop 0 - -data WorkerCommand - = WCUpdateEdgeProb - | WCUpdateSurvey - | WCComputeVarProb - | WCTerminate - -propagateMT :: Solver -> Int -> IO Bool -propagateMT solver nthreads = do - tol <- getTolerance solver - lim <- getIterationLimit solver - nv <- getNVars solver - nc <- getNConstraints solver - - mask $ \restore -> do - ex <- newEmptyTMVarIO - let wait :: STM a -> IO a - wait m = join $ atomically $ liftM return m `orElse` liftM throwIO (takeTMVar ex) - - workers <- do - let mV = (nv + nthreads - 1) `div` nthreads - mC = (nc + nthreads - 1) `div` nthreads - forM [0..nthreads-1] $ \i -> do - let lbV = mV * i + 1 -- inclusive - ubV = min (lbV + mV) (nv + 1) -- exclusive - lbC = mC * i -- exclusive - ubC = min (lbC + mC) nc -- exclusive - let max_v_len = VG.maximum $ VG.map VG.length $ VG.slice (lbV - 1) (ubV - lbV) (svVarEdges solver) - max_c_len = VG.maximum $ VG.map VG.length $ VG.slice lbC (ubC - lbC) (svClauseEdges solver) - tmp <- VGM.new (max (max_v_len*2) max_c_len) - reqVar <- newEmptyMVar - respVar <- newEmptyTMVarIO - respVar2 <- newEmptyTMVarIO - th <- forkIO $ do - let loop = do - cmd <- takeMVar reqVar - case cmd of - WCTerminate -> return () - WCUpdateEdgeProb -> do - numLoop lbV (ubV-1) $ \v -> updateEdgeProb solver v tmp - atomically $ putTMVar respVar () - loop - WCUpdateSurvey -> do - let f maxDelta c = max maxDelta <$> updateEdgeSurvey solver c tmp - delta <- foldM f 0 [lbC .. ubC-1] - atomically $ putTMVar respVar2 delta - loop - WCComputeVarProb -> do - numLoop lbV (ubV-1) $ \v -> computeVarProb solver v - atomically $ putTMVar respVar () - loop - restore loop `catch` \(e :: SomeException) -> atomically (tryPutTMVar ex e >> return ()) - return (th, reqVar, respVar, respVar2) - - let loop !i - | Just l <- lim, i >= l = return False - | otherwise = do - mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCUpdateEdgeProb) workers - mapM_ (\(_,_,respVar,_) -> wait (takeTMVar respVar)) workers - mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCUpdateSurvey) workers - delta <- foldM (\delta (_,_,_,respVar2) -> max delta <$> wait (takeTMVar respVar2)) 0 workers - if delta <= tol then do - mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCComputeVarProb) workers - mapM_ (\(_,_,respVar,_) -> wait (takeTMVar respVar)) workers - mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCTerminate) workers - return True - else - loop (i+1) - - ret <- try $ restore $ loop 0 - case ret of - Right b -> return b - Left (e :: SomeException) -> do - mapM_ (\(th,_,_,_) -> killThread th) workers - throwIO e - --- tmp1 must have at least @VG.length (svVarEdges solver ! (v - 1)) * 2@ elements -updateEdgeProb :: Solver -> SAT.Var -> VUM.IOVector (L.Log Double) -> IO () -updateEdgeProb solver v tmp = do - let i = v - 1 - edges = svVarEdges solver ! i - m <- VGM.unsafeRead (svVarFixed solver) i - case m of - Just val -> do - VG.forM_ edges $ \e -> do - let lit = svEdgeLit solver ! e - flag = (lit > 0) == val - VGM.unsafeWrite (svEdgeProbU solver) e (if flag then 0 else 1) - Nothing -> do - let f !k !val1_pre !val2_pre - | k >= VG.length edges = return () - | otherwise = do - let e = edges ! k - a = svEdgeClause solver ! e - VGM.unsafeWrite tmp (k*2) val1_pre - VGM.unsafeWrite tmp (k*2+1) val2_pre - eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e -- η_{a→i} - let w = svClauseWeight solver ! a - lit2 = svEdgeLit solver ! e - val1_pre' = if lit2 > 0 then val1_pre * comp eta_ai ^* w else val1_pre - val2_pre' = if lit2 > 0 then val2_pre else val2_pre * comp eta_ai ^* w - f (k+1) val1_pre' val2_pre' - f 0 1 1 - -- tmp ! (k*2) == Π_{a∈edges[0..k-1], a∈V^{+}(i)} (1 - eta_ai)^{w_i} - -- tmp ! (k*2+1) == Π_{a∈edges[0..k-1], a∈V^{-}(i)} (1 - eta_ai)^{w_i} - - let g !k !val1_post !val2_post - | k < 0 = return () - | otherwise = do - let e = edges ! k - a = svEdgeClause solver ! e - lit2 = svEdgeLit solver ! e - val1_pre <- VGM.unsafeRead tmp (k*2) - val2_pre <- VGM.unsafeRead tmp (k*2+1) - let val1 = val1_pre * val1_post -- val1 == Π_{b∈edges, b∈V^{+}(i), a≠b} (1 - eta_bi)^{w_i} - val2 = val2_pre * val2_post -- val2 == Π_{b∈edges, b∈V^{-}(i), a≠b} (1 - eta_bi)^{w_i} - eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e -- η_{a→i} - let w = svClauseWeight solver ! a - val1_post' = if lit2 > 0 then val1_post * comp eta_ai ^* w else val1_post - val2_post' = if lit2 > 0 then val2_post else val2_post * comp eta_ai ^* w - let pi_0 = val1 * val2 -- Π^0_{i→a} - pi_u = if lit2 > 0 then comp val2 * val1 else comp val1 * val2 -- Π^u_{i→a} - pi_s = if lit2 > 0 then comp val1 * val2 else comp val2 * val1 -- Π^s_{i→a} - VGM.unsafeWrite (svEdgeProbU solver) e (pi_u / L.sum [pi_0, pi_u, pi_s]) - g (k-1) val1_post' val2_post' - g (VG.length edges - 1) 1 1 - --- tmp must have at least @VG.length (svClauseEdges solver ! a)@ elements -updateEdgeSurvey :: Solver -> ClauseIndex -> VUM.IOVector (L.Log Double) -> IO Double -updateEdgeSurvey solver a tmp = do - let edges = svClauseEdges solver ! a - let f !k !p_pre - | k >= VG.length edges = return () - | otherwise = do - let e = edges ! k - VGM.unsafeWrite tmp k p_pre - p <- VGM.unsafeRead (svEdgeProbU solver) e - -- p is the probability of lit being false, if the edge does not exist. - f (k+1) (p_pre * p) - let g !k !p_post !maxDelta - | k < 0 = return maxDelta - | otherwise = do - let e = edges ! k - -- p_post == Π_{e∈edges[k+1..]} p_e - p_pre <- VGM.unsafeRead tmp k -- Π_{e∈edges[0..k-1]} p_e - p <- VGM.unsafeRead (svEdgeProbU solver) e - eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e - let eta_ai' = p_pre * p_post -- Π_{e∈edges[0,..,k-1,k+1,..]} p_e - VGM.unsafeWrite (svEdgeSurvey solver) e eta_ai' - let delta = abs (realToFrac eta_ai' - realToFrac eta_ai) - g (k-1) (p_post * p) (max delta maxDelta) - f 0 1 - -- tmp ! k == Π_{e∈edges[0..k-1]} p_e - g (VG.length edges - 1) 1 0 - -computeVarProb :: Solver -> SAT.Var -> IO () -computeVarProb solver v = do - let i = v - 1 - f (val1,val2) e = do - let lit = svEdgeLit solver ! e - a = svEdgeClause solver ! e - w = svClauseWeight solver ! a - eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e - let val1' = if lit > 0 then val1 * comp eta_ai ^* w else val1 - val2' = if lit < 0 then val2 * comp eta_ai ^* w else val2 - return (val1',val2') - (val1,val2) <- VG.foldM' f (1,1) (svVarEdges solver ! i) - let p0 = val1 * val2 -- \^{Π}^{0}_i - pp = comp val1 * val2 -- \^{Π}^{+}_i - pn = comp val2 * val1 -- \^{Π}^{-}_i - let wp = pp / (pp + pn + p0) - wn = pn / (pp + pn + p0) - VGM.unsafeWrite (svVarProbT solver) i wp -- W^{(+)}_i - VGM.unsafeWrite (svVarProbF solver) i wn -- W^{(-)}_i - --- | Get the marginal probability of the variable to be @True@, @False@ and unspecified respectively. -getVarProb :: Solver -> SAT.Var -> IO (Double, Double, Double) -getVarProb solver v = do - pt <- realToFrac <$> VGM.unsafeRead (svVarProbT solver) (v - 1) - pf <- realToFrac <$> VGM.unsafeRead (svVarProbF solver) (v - 1) - return (pt, pf, 1 - (pt + pf)) - -fixLit :: Solver -> SAT.Lit -> IO () -fixLit solver lit = do - VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) (if lit > 0 then Just True else Just False) - -unfixLit :: Solver -> SAT.Lit -> IO () -unfixLit solver lit = do - VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) Nothing - -printInfo :: Solver -> IO () -printInfo solver = do - (surveys :: VU.Vector (L.Log Double)) <- VG.freeze (svEdgeSurvey solver) - (u :: VU.Vector (L.Log Double)) <- VG.freeze (svEdgeProbU solver) - let xs = [(clause, lit, eta, u ! e) | (e, eta) <- zip [0..] (VG.toList surveys), let lit = svEdgeLit solver ! e, let clause = svEdgeClause solver ! e] - putStrLn $ "edges: " ++ show xs - - (pt :: VU.Vector (L.Log Double)) <- VG.freeze (svVarProbT solver) - (pf :: VU.Vector (L.Log Double)) <- VG.freeze (svVarProbF solver) - nv <- getNVars solver - let xs2 = [(v, realToFrac (pt ! i) :: Double, realToFrac (pf ! i) :: Double, realToFrac (pt ! i) - realToFrac (pf ! i) :: Double) | v <- [1..nv], let i = v - 1] - putStrLn $ "vars: " ++ show xs2 diff --git a/src/ToySolver/SAT/MessagePassing/SurveyPropagation/OpenCL.hs b/src/ToySolver/SAT/MessagePassing/SurveyPropagation/OpenCL.hs deleted file mode 100644 --- a/src/ToySolver/SAT/MessagePassing/SurveyPropagation/OpenCL.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ScopedTypeVariables, BangPatterns, TemplateHaskell #-} -{-# OPTIONS_GHC -Wall #-} ------------------------------------------------------------------------------ --- | --- Module : ToySolver.SAT.MessagePassing.SurveyPropagation.OpenCL --- Copyright : (c) Masahiro Sakai 2016 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable (ScopedTypeVariables, BangPatterns, TypeFamilies) --- --- References: --- --- * Alfredo Braunstein, Marc Mézard and Riccardo Zecchina. --- Survey Propagation: An Algorithm for Satisfiability, --- --- --- * Corrie Scalisi. Visualizing Survey Propagation in 3-SAT Factor Graphs, --- . --- ------------------------------------------------------------------------------ -module ToySolver.SAT.MessagePassing.SurveyPropagation.OpenCL - ( - -- * The Solver type - Solver - , newSolver - , deleteSolver - - -- * Problem information - , getNVars - , getNConstraints - - -- * Parameters - , getTolerance - , setTolerance - , getIterationLimit - , setIterationLimit - - -- * Computing marginal distributions - , initializeRandom - , initializeRandomDirichlet - , propagate - , getVarProb - - -- * Solving - , fixLit - , unfixLit - ) where - -import Control.Exception -import Control.Loop -import Control.Monad -import Control.Parallel.OpenCL -import Data.Bits -import Data.Int -import Data.IORef -import qualified Data.Vector as V -import qualified Data.Vector.Mutable as VM -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as VSM -import Data.Vector.Generic ((!)) -import qualified Data.Vector.Generic as VG -import qualified Data.Vector.Generic.Mutable as VGM -import Foreign( castPtr, nullPtr, sizeOf ) -import Foreign.C.Types( CFloat ) -import Language.Haskell.TH (runIO, litE, stringL) -import Language.Haskell.TH.Syntax (addDependentFile) -import qualified Numeric.Log as L -import System.IO -import qualified System.Random.MWC as Rand -import qualified System.Random.MWC.Distributions as Rand -import Text.Printf - -import qualified ToySolver.SAT.Types as SAT - -data Solver - = Solver - { svOutputMessage :: !(String -> IO ()) - - , svContext :: !CLContext - , svDevice :: !CLDeviceID - , svQueue :: !CLCommandQueue - , svUpdateEdgeProb :: !CLKernel - , svUpdateEdgeSurvey :: !CLKernel - , svComputeVarProb :: !CLKernel - - , svVarEdges :: !(VSM.IOVector CLint) - , svVarEdgesWeight :: !(VSM.IOVector CFloat) - , svVarOffset :: !(VSM.IOVector CLint) - , svVarLength :: !(VSM.IOVector CLint) - , svVarFixed :: !(VSM.IOVector Int8) - , svVarProb :: !(VSM.IOVector (L.Log CFloat)) - , svClauseOffset :: !(VSM.IOVector CLint) - , svClauseLength :: !(VSM.IOVector CLint) - , svEdgeSurvey :: !(VSM.IOVector (L.Log CFloat)) -- η_{a → i} - , svEdgeProbU :: !(VSM.IOVector (L.Log CFloat)) -- Π^u_{i → a} / (Π^u_{i → a} + Π^s_{i → a} + Π^0_{i → a}) - - , svTolRef :: !(IORef Double) - , svIterLimRef :: !(IORef (Maybe Int)) - } - -newSolver :: (String -> IO ()) -> CLContext -> CLDeviceID -> Int -> [(Double, SAT.PackedClause)] -> IO Solver -newSolver outputMessage context dev nv clauses = do - _ <- clRetainContext context - queue <- clCreateCommandQueue context dev [] - - let num_clauses = length clauses - num_edges = sum [VG.length c | (_,c) <- clauses] - - (varEdgesTmp :: VM.IOVector [(Int,Bool,Double)]) <- VGM.replicate nv [] - clauseOffset <- VGM.new num_clauses - clauseLength <- VGM.new num_clauses - - ref <- newIORef 0 - forM_ (zip [0..] clauses) $ \(i,(w,c)) -> do - VGM.write clauseOffset i =<< liftM fromIntegral (readIORef ref) - VGM.write clauseLength i (fromIntegral (VG.length c)) - forM_ (SAT.unpackClause c) $ \lit -> do - e <- readIORef ref - modifyIORef' ref (+1) -#if MIN_VERSION_vector(0,11,0) - VGM.modify varEdgesTmp ((e,lit>0,w) :) (abs lit - 1) -#else - VGM.write varEdgesTmp (abs lit - 1) =<< liftM ((e,lit>0,w) :) (VGM.read varEdgesTmp (abs lit - 1)) -#endif - - varOffset <- VGM.new nv - varLength <- VGM.new nv - varFixed <- VGM.new nv - varEdges <- VGM.new num_edges - varEdgesWeight <- VGM.new num_edges - let loop !i !offset - | i >= nv = return () - | otherwise = do - xs <- VGM.read (varEdgesTmp) i - let len = length xs - VGM.write varOffset i (fromIntegral offset) - VGM.write varLength i (fromIntegral len) - VGM.write varFixed i 0 - forM_ (zip [offset..] (reverse xs)) $ \(j, (e,polarity,w)) -> do - VGM.write varEdges j $ (fromIntegral e `shiftL` 1) .|. (if polarity then 1 else 0) - VGM.write varEdgesWeight j (realToFrac w) - loop (i+1) (offset + len) - loop 0 0 - - -- Initialize all surveys with non-zero values. - -- If we initialize to zero, following trivial solution exists: - -- - -- η_{a→i} = 0 for all i and a. - -- - -- Π^0_{i→a} = 1, Π^u_{i→a} = Π^s_{i→a} = 0 for all i and a, - -- - -- \^{Π}^{0}_i = 1, \^{Π}^{+}_i = \^{Π}^{-}_i = 0 - -- - edgeSurvey <- VGM.replicate num_edges (L.Exp (log 0.5)) - edgeProbU <- VGM.new num_edges - - varProb <- VGM.new (nv*2) - - tolRef <- newIORef 0.01 - maxIterRef <- newIORef (Just 1000) - - -- Compile - let byteSize :: forall a. VSM.Storable a => VSM.IOVector a -> Int - byteSize v = VGM.length v * sizeOf (undefined :: a) - (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev - let reqConstantBufferSize = - byteSize varEdges + byteSize varEdgesWeight + - byteSize varOffset + byteSize varLength + - byteSize clauseOffset + byteSize clauseLength - let flags = - ["-DUSE_CONSTANT_BUFFER" | maxConstantBufferSize >= reqConstantBufferSize] - -- programSource <- openBinaryFile "sp.cl" ReadMode >>= hGetContents - let programSource = $(runIO (do{ h <- openFile "src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl" ReadMode; hSetEncoding h utf8; hGetContents h }) >>= \s -> addDependentFile "src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl" >> litE (stringL s)) - outputMessage $ "Compiling kernels with options: " ++ unwords flags - program <- clCreateProgramWithSource context programSource - finally (clBuildProgram program [dev] (unwords flags)) - (outputMessage =<< clGetProgramBuildLog program dev) - update_edge_prob <- clCreateKernel program "update_edge_prob" - update_edge_survey <- clCreateKernel program "update_edge_survey" - compute_var_prob <- clCreateKernel program "compute_var_prob" - - return $ - Solver - { svOutputMessage = outputMessage - - , svContext = context - , svDevice = dev - , svQueue = queue - , svUpdateEdgeProb = update_edge_prob - , svUpdateEdgeSurvey = update_edge_survey - , svComputeVarProb = compute_var_prob - - , svVarEdges = varEdges - , svVarEdgesWeight = varEdgesWeight - , svVarOffset = varOffset - , svVarLength = varLength - , svVarFixed = varFixed - , svVarProb = varProb - , svClauseOffset = clauseOffset - , svClauseLength = clauseLength - , svEdgeSurvey = edgeSurvey - , svEdgeProbU = edgeProbU - - , svTolRef = tolRef - , svIterLimRef = maxIterRef - } - -deleteSolver :: Solver -> IO () -deleteSolver solver = do - _ <- clReleaseKernel (svUpdateEdgeProb solver) - _ <- clReleaseKernel (svUpdateEdgeSurvey solver) - _ <- clReleaseKernel (svComputeVarProb solver) - _ <- clReleaseCommandQueue (svQueue solver) - _ <- clReleaseContext (svContext solver) - return () - -initializeRandom :: Solver -> Rand.GenIO -> IO () -initializeRandom solver gen = do - n <- getNConstraints solver - numLoop 0 (n-1) $ \i -> do - off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i - len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i - case len of - 0 -> return () - 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0) - _ -> do - let p :: Double - p = 1 / fromIntegral len - numLoop 0 (len-1) $ \i -> do - d <- Rand.uniformR (p*0.5, p*1.5) gen - VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log d))) - -initializeRandomDirichlet :: Solver -> Rand.GenIO -> IO () -initializeRandomDirichlet solver gen = do - n <- getNConstraints solver - numLoop 0 (n-1) $ \i -> do - off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i - len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i - case len of - 0 -> return () - 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0) - _ -> do - (ps :: V.Vector Double) <- Rand.dirichlet (VG.replicate len 1) gen - numLoop 0 (len-1) $ \i -> do - VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log (ps ! i)))) - --- | number of variables of the problem. -getNVars :: Solver -> IO Int -getNVars solver = return $ VGM.length (svVarOffset solver) - --- | number of constraints of the problem. -getNConstraints :: Solver -> IO Int -getNConstraints solver = return $ VGM.length (svClauseOffset solver) - --- | number of edges of the factor graph -getNEdges :: Solver -> IO Int -getNEdges solver = return $ VGM.length (svEdgeSurvey solver) - -getTolerance :: Solver -> IO Double -getTolerance solver = readIORef (svTolRef solver) - -setTolerance :: Solver -> Double -> IO () -setTolerance solver !tol = writeIORef (svTolRef solver) tol - -getIterationLimit :: Solver -> IO (Maybe Int) -getIterationLimit solver = readIORef (svIterLimRef solver) - -setIterationLimit :: Solver -> Maybe Int -> IO () -setIterationLimit solver val = writeIORef (svIterLimRef solver) val - --- | Get the marginal probability of the variable to be @True@, @False@ and unspecified respectively. -getVarProb :: Solver -> SAT.Var -> IO (Double, Double, Double) -getVarProb solver v = do - let i = v - 1 - pt <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2) - pf <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2+1) - return (pt, pf, 1 - (pt + pf)) - -propagate :: Solver -> IO Bool -propagate solver = do - tol <- getTolerance solver - lim <- getIterationLimit solver - nv <- getNVars solver - nc <- getNConstraints solver - let ne = VGM.length (svEdgeSurvey solver) - - let context = svContext solver - dev = svDevice solver - queue = svQueue solver - platform <- clGetDevicePlatform dev - - let infos = [CL_PLATFORM_PROFILE, CL_PLATFORM_VERSION, CL_PLATFORM_NAME, CL_PLATFORM_VENDOR, CL_PLATFORM_EXTENSIONS] - forM_ infos $ \info -> do - s <- clGetPlatformInfo platform info - svOutputMessage solver $ show info ++ " = " ++ s - devname <- clGetDeviceName dev - svOutputMessage solver $ "DEVICE = " ++ devname - - (maxComputeUnits :: Int) <- fromIntegral <$> clGetDeviceMaxComputeUnits dev - (maxWorkGroupSize :: Int) <- fromIntegral <$> clGetDeviceMaxWorkGroupSize dev - maxWorkItemSizes@(maxWorkItemSize:_) <- fmap fromIntegral <$> clGetDeviceMaxWorkItemSizes dev - svOutputMessage solver $ "MAX_COMPUTE_UNITS = " ++ show maxComputeUnits - svOutputMessage solver $ "MAX_WORK_GROUP_SIZE = " ++ show maxWorkGroupSize - svOutputMessage solver $ "MAX_WORK_ITEM_SIZES = " ++ show maxWorkItemSizes - (globalMemSize :: Int) <- fromIntegral <$> clGetDeviceGlobalMemSize dev - (localMemSize :: Int) <- fromIntegral <$> clGetDeviceLocalMemSize dev - (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev - (maxConstantArgs :: Int) <- fromIntegral <$> clGetDeviceMaxConstantArgs dev - svOutputMessage solver $ "GLOBAL_MEM_SIZE = " ++ show globalMemSize - svOutputMessage solver $ "LOCAL_MEM_SIZE = " ++ show localMemSize - svOutputMessage solver $ "MAX_CONSTANT_BUFFER_SIZE = " ++ show maxConstantBufferSize - svOutputMessage solver $ "MAX_CONSTANT_ARGS = " ++ show maxConstantArgs - - let defaultNumGroups = maxComputeUnits * 4 - - (updateEdgeProb_kernel_workgroup_size :: Int) - <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeProb solver) dev - let updateEdgeProb_local_size = min 32 updateEdgeProb_kernel_workgroup_size - updateEdgeProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeProb_local_size) - updateEdgeProb_global_size = updateEdgeProb_num_groups * updateEdgeProb_local_size - svOutputMessage solver $ - printf "update_edge_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" - updateEdgeProb_kernel_workgroup_size updateEdgeProb_local_size updateEdgeProb_num_groups updateEdgeProb_global_size - - (updateEdgeSurvey_kernel_workgroup_size :: Int) - <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeSurvey solver) dev - let updateEdgeSurvey_local_size = min 32 updateEdgeSurvey_kernel_workgroup_size - updateEdgeSurvey_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeSurvey_local_size) - updateEdgeSurvey_global_size = updateEdgeSurvey_num_groups * updateEdgeSurvey_local_size - svOutputMessage solver $ - printf "update_edge_survey kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" - updateEdgeSurvey_kernel_workgroup_size updateEdgeSurvey_local_size updateEdgeSurvey_num_groups updateEdgeSurvey_global_size - - (computeVarProb_kernel_workgroup_size :: Int) - <- fromIntegral <$> clGetKernelWorkGroupSize (svComputeVarProb solver) dev - let computeVarProb_local_size = min 32 computeVarProb_kernel_workgroup_size - computeVarProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` computeVarProb_local_size) - computeVarProb_global_size = computeVarProb_num_groups * computeVarProb_local_size - svOutputMessage solver $ - printf "compute_var_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" - computeVarProb_kernel_workgroup_size computeVarProb_local_size computeVarProb_num_groups computeVarProb_global_size - - let createBufferFromVector :: forall a. VSM.Storable a => [CLMemFlag] -> VSM.IOVector a -> IO CLMem - createBufferFromVector flags v = do - VSM.unsafeWith v $ \ptr -> - clCreateBuffer context (CL_MEM_COPY_HOST_PTR : flags) - (VGM.length v * sizeOf (undefined :: a), castPtr ptr) - - readBufferToVectorAsync :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO CLEvent - readBufferToVectorAsync mem vec = do - VSM.unsafeWith vec $ \ptr -> do - clEnqueueReadBuffer queue mem False - 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) [] - - readBufferToVector :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO () - readBufferToVector mem vec = do - VSM.unsafeWith vec $ \ptr -> do - ev <- clEnqueueReadBuffer queue mem True - 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) [] - _ <- clReleaseEvent ev - return () - - var_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarOffset solver - var_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarLength solver - var_fixed <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarFixed solver - var_edges <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdges solver - var_edges_weight <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdgesWeight solver - clause_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseOffset solver - clause_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseLength solver - edge_survey <- createBufferFromVector [CL_MEM_READ_WRITE] $ svEdgeSurvey solver - edge_prob_u <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}] - (ne * sizeOf (undefined :: CFloat), nullPtr) - - global_buf <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}] - (ne * sizeOf (undefined :: CFloat) * 2, nullPtr) - var_prob <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}] - (nv * sizeOf (undefined :: CFloat) * 2, nullPtr) - group_max_delta <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}] - (updateEdgeSurvey_num_groups * sizeOf (undefined :: CFloat), nullPtr) - - clSetKernelArgSto (svUpdateEdgeProb solver) 0 (fromIntegral nv :: CLint) - clSetKernelArgSto (svUpdateEdgeProb solver) 1 var_offset - clSetKernelArgSto (svUpdateEdgeProb solver) 2 var_degree - clSetKernelArgSto (svUpdateEdgeProb solver) 3 var_fixed - clSetKernelArgSto (svUpdateEdgeProb solver) 4 var_edges - clSetKernelArgSto (svUpdateEdgeProb solver) 5 var_edges_weight - clSetKernelArgSto (svUpdateEdgeProb solver) 6 global_buf - clSetKernelArgSto (svUpdateEdgeProb solver) 7 edge_survey - clSetKernelArgSto (svUpdateEdgeProb solver) 8 edge_prob_u - - clSetKernelArgSto (svUpdateEdgeSurvey solver) 0 (fromIntegral nc :: CLint) - clSetKernelArgSto (svUpdateEdgeSurvey solver) 1 clause_offset - clSetKernelArgSto (svUpdateEdgeSurvey solver) 2 clause_degree - clSetKernelArgSto (svUpdateEdgeSurvey solver) 3 edge_survey - clSetKernelArgSto (svUpdateEdgeSurvey solver) 4 edge_prob_u - clSetKernelArgSto (svUpdateEdgeSurvey solver) 5 global_buf - clSetKernelArgSto (svUpdateEdgeSurvey solver) 6 group_max_delta - clSetKernelArg (svUpdateEdgeSurvey solver) 7 (updateEdgeSurvey_local_size * sizeOf (undefined :: CFloat)) nullPtr -- reduce_buf - - clSetKernelArgSto (svComputeVarProb solver) 0 (fromIntegral nv :: CLint) - clSetKernelArgSto (svComputeVarProb solver) 1 var_offset - clSetKernelArgSto (svComputeVarProb solver) 2 var_degree - clSetKernelArgSto (svComputeVarProb solver) 3 var_prob - clSetKernelArgSto (svComputeVarProb solver) 4 var_edges - clSetKernelArgSto (svComputeVarProb solver) 5 var_edges_weight - clSetKernelArgSto (svComputeVarProb solver) 6 edge_survey - - (group_max_delta_vec :: VSM.IOVector CFloat) <- VGM.new updateEdgeSurvey_num_groups - - let loop !i - | Just l <- lim, i >= l = return (False,i) - | otherwise = do - _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeProb solver) - [updateEdgeProb_global_size] [updateEdgeProb_local_size] [] - _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeSurvey solver) - [updateEdgeSurvey_global_size] [updateEdgeSurvey_local_size] [] - readBufferToVector group_max_delta group_max_delta_vec - !delta <- VG.maximum <$> VS.unsafeFreeze group_max_delta_vec - if realToFrac delta <= tol then do - return (True,i) - else - loop (i+1) - - (b,_steps) <- loop 0 - - _ <- clReleaseEvent =<< readBufferToVectorAsync edge_survey (svEdgeSurvey solver) - when b $ do - _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svComputeVarProb solver) - [computeVarProb_global_size] [computeVarProb_local_size] [] - _ <- clReleaseEvent =<< readBufferToVectorAsync var_prob (svVarProb solver) - return () - - _ <- clFinish queue - - _ <- clReleaseMemObject var_offset - _ <- clReleaseMemObject var_degree - _ <- clReleaseMemObject var_edges - _ <- clReleaseMemObject var_edges_weight - _ <- clReleaseMemObject clause_offset - _ <- clReleaseMemObject clause_degree - _ <- clReleaseMemObject edge_survey - _ <- clReleaseMemObject edge_prob_u - _ <- clReleaseMemObject global_buf - _ <- clReleaseMemObject var_prob - _ <- clReleaseMemObject group_max_delta - - return b - -fixLit :: Solver -> SAT.Lit -> IO () -fixLit solver lit = do - VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) (if lit > 0 then 1 else -1) - -unfixLit :: Solver -> SAT.Lit -> IO () -unfixLit solver lit = do - VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) 0 diff --git a/src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl b/src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl deleted file mode 100644 --- a/src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl +++ /dev/null @@ -1,193 +0,0 @@ -/* -*- mode: c -*- */ - -#ifdef USE_CONSTANT_BUFFER -#define CONSTANT __constant -#else -#define CONSTANT __global -#endif - -typedef float logfloat; -typedef float2 logfloat2; - -static inline logfloat comp(logfloat x) { - return log1p(fmax(-1.0f, -exp(x))); -} - -__kernel void -update_edge_prob( - int n_vars, - CONSTANT int *var_offset, // int[n_vars] - CONSTANT int *var_degree, // int[n_vars] - CONSTANT char *var_fixed, // char[n_vars] - CONSTANT int *var_edges, // int[M] - CONSTANT float *var_edges_weight, // float[M] - __global logfloat2 *var_edges_buf,// logfloat2[M] - __global logfloat *edge_survey, // logfloat[n_edges] - __global logfloat *edge_prob_u // logfloat[n_edges] - ) -{ - int global_size = get_global_size(0); - for (int i = get_global_id(0); i < n_vars; i += global_size) { - int offset = var_offset[i]; - int degree = var_degree[i]; - int fixed = var_fixed[i]; - - if (fixed != 0) { - for (int j = 0; j < degree; j++) { - int tmp = var_edges[offset+j]; - int e = tmp >> 1; - bool polarity = tmp & 1; - if (polarity == (bool)(tmp > 0)) - edge_prob_u[e] = log(0.0f); - else - edge_prob_u[e] = log(1.0f); - } - } - - logfloat val1_pre = log(1.0f); - logfloat val2_pre = log(1.0f); - for (int j = 0; j < degree; j++) { - var_edges_buf[offset+j] = (float2)(val1_pre, val2_pre); - - int tmp = var_edges[offset+j]; - int e = tmp >> 1; - bool polarity = tmp & 1; - logfloat eta_ai = edge_survey[e]; - logfloat w = var_edges_weight[offset+j]; - - if (polarity) { - val1_pre += comp(eta_ai) * w; - } else { - val2_pre += comp(eta_ai) * w; - } - } - - logfloat val1_post = log(1.0f); - logfloat val2_post = log(1.0f); - for (int j = degree - 1; j >= 0; j--) { - int tmp = var_edges[offset+j]; - int e = tmp >> 1; - bool polarity = tmp & 1; - logfloat eta_ai = edge_survey[e]; - float w = var_edges_weight[offset+j]; - - logfloat2 pre = var_edges_buf[offset+j]; - logfloat val1 = pre.x + val1_post; // probability that other edges do not depends on v=1. - logfloat val2 = pre.y + val2_post; // probability that other edges do not depends on v=0. - logfloat pi_0 = val1 + val2; // Π^0_{i→a} - logfloat pi_u; // Π^u_{i→a} - logfloat pi_s; // Π^s_{i→a} - if (polarity) { - pi_u = comp(val2) + val1; - pi_s = comp(val1) + val2; - val1_post += comp(eta_ai) * w; - } else { - pi_u = comp(val1) + val2; - pi_s = comp(val2) + val1; - val2_post += comp(eta_ai) * w; - } - float psum = exp(pi_0) + exp(pi_u) + exp(pi_s); - if (psum > 0) { - edge_prob_u[e] = pi_u - log(psum); - } else { - edge_prob_u[e] = log(0.0f); // is that ok? - } - } - } -} - - -__kernel void -update_edge_survey( - int n_clauses, - CONSTANT int *clause_offset, // int[n_clauses] - CONSTANT int *clause_degree, // int[n_clauses] - __global logfloat *edge_survey, // logfloat[n_edges] - __global logfloat *edge_prob_u, // logfloat[n_edges] - __global logfloat *edge_buf, // logfloat[n_edges] - __global float *group_max_delta, // float[get_num_groups(0)] - __local float *reduce_buf // float[get_local_size(0)] - ) -{ - float max_delta = 0; - - int global_size = get_global_size(0); - for (int a = get_global_id(0); a < n_clauses; a += global_size) { - int len = clause_degree[a]; - int offset = clause_offset[a]; - - logfloat pre = log(1.0f); - for (int j = 0; j < len; j++) { - int e = offset+j; - edge_buf[e] = pre; - pre += edge_prob_u[e]; - } - - logfloat post = log(1.0f); - for (int j = len-1; j >=0; j--) { - int e = offset+j; - logfloat pre = edge_buf[e]; - logfloat eta_ai_orig = edge_survey[e]; - logfloat eta_ai_new = pre + post; - edge_survey[e] = eta_ai_new; - max_delta = fmax(max_delta, fabs(exp(eta_ai_new) - exp(eta_ai_orig))); - post += edge_prob_u[e]; - } - } - - // reduction - int local_id = get_local_id(0); - int local_size = get_local_size(0); - barrier(CLK_LOCAL_MEM_FENCE); - reduce_buf[local_id] = max_delta; - for (int stride = local_size / 2; stride > 0; stride /= 2) { - barrier(CLK_LOCAL_MEM_FENCE); - if (local_id < stride) { - reduce_buf[local_id] = fmax(reduce_buf[local_id], reduce_buf[local_id + stride]); - } - } - if (local_id==0) - group_max_delta[get_group_id(0)] = reduce_buf[0]; -} - -__kernel void -compute_var_prob( - int n_vars, - CONSTANT int *var_offset, // int[n_vars] - CONSTANT int *var_degree, // int[n_vars] - __global logfloat2 *var_prob, // logfloat2[n_vars] - CONSTANT int *var_edges, // int[M] - CONSTANT logfloat *var_edges_weight, // logfloat[M] - __global logfloat *edge_survey // logfloat[E] - ) -{ - int global_size = get_global_size(0); - - for (int i = get_global_id(0); i < n_vars; i += global_size) { - int offset = var_offset[i]; - int degree = var_degree[i]; - - logfloat val1 = log(1.0f); - logfloat val2 = log(1.0f); - for (int j = 0; j < degree; j++) { - int tmp = var_edges[offset+j]; - int e = tmp >> 1; - bool polarity = tmp & 1; - float eta_ai = edge_survey[e]; - float w = var_edges_weight[offset+j]; - - if (polarity) { - val1 += comp(eta_ai) * w; - } else { - val2 += comp(eta_ai) * w; - } - } - - float p0 = val1 + val2; // \^{Π}^{0}_i - float pp = comp(val1) + val2; // \^{Π}^{+}_i - float pn = comp(val2) + val1; // \^{Π}^{-}_i - float wp = pp - log(exp(pp) + exp(pn) + exp(p0)); // W^{(+)}_i - float wn = pn - log(exp(pp) + exp(pn) + exp(p0)); // W^{(-)}_i - var_prob[i] = (float2)(wp, wn); - } -} diff --git a/src/ToySolver/SAT/PBO.hs b/src/ToySolver/SAT/PBO.hs --- a/src/ToySolver/SAT/PBO.hs +++ b/src/ToySolver/SAT/PBO.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.SAT.PBO -- Copyright : (c) Masahiro Sakai 2012-2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -257,7 +257,7 @@ loop = do result <- SAT.solve solver if result then do - m <- SAT.getModel solver + m <- SAT.getModel solver let val = C.evalObjectiveFunction cxt m let ub = val - 1 C.addSolution cxt m diff --git a/src/ToySolver/SAT/PBO/BC.hs b/src/ToySolver/SAT/PBO/BC.hs --- a/src/ToySolver/SAT/PBO/BC.hs +++ b/src/ToySolver/SAT/PBO/BC.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.SAT.PBO.BC -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -17,7 +17,7 @@ -- Core-Guided binary search algorithms for maximum satisfiability, -- Twenty-Fifth AAAI Conference on Artificial Intelligence, 2011. -- --- +-- ----------------------------------------------------------------------------- module ToySolver.SAT.PBO.BC ( solve @@ -71,7 +71,7 @@ else do core <- SAT.getFailedAssumptions solver SAT.addClause solver [-sel] -- delete temporary constraint - let core2 = IntSet.fromList core `IntSet.intersection` unrelaxed + let core2 = core `IntSet.intersection` unrelaxed if IntSet.null core2 then do C.logMessage cxt $ printf "BC: updating lower bound: %d -> %d" lb (mid+1) C.addLowerBound cxt (mid+1) diff --git a/src/ToySolver/SAT/PBO/BCD.hs b/src/ToySolver/SAT/PBO/BCD.hs --- a/src/ToySolver/SAT/PBO/BCD.hs +++ b/src/ToySolver/SAT/PBO/BCD.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.SAT.PBO.BCD -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable @@ -22,7 +22,7 @@ -- pp. 284-297. -- -- --- +-- ----------------------------------------------------------------------------- module ToySolver.SAT.PBO.BCD ( solve @@ -106,7 +106,7 @@ cont (unrelaxed, relaxed) cores' ub' else do core <- SAT.getFailedAssumptions solver - case core of + case IntSet.toList core of [] -> return () [sel] | Just info <- IntMap.lookup sel sels -> do let info' = info{ coreLB = coreMidValue info + 1 } @@ -115,16 +115,15 @@ SAT.addPBAtLeast solver (coreCostFun info') (coreLB info') -- redundant, but useful for direct search cont (unrelaxed, relaxed) cores' ub _ -> do - let coreSet = IntSet.fromList core - torelax = unrelaxed `IntSet.intersection` coreSet - intersected = [info | (sel,info) <- IntMap.toList sels, sel `IntSet.member` coreSet] - rest = [info | (sel,info) <- IntMap.toList sels, sel `IntSet.notMember` coreSet] + let torelax = unrelaxed `IntSet.intersection` core + intersected = [info | (sel,info) <- IntMap.toList sels, sel `IntSet.member` core] + rest = [info | (sel,info) <- IntMap.toList sels, sel `IntSet.notMember` core] mergedCore = foldl' coreUnion (coreNew torelax) intersected unrelaxed' = unrelaxed `IntSet.difference` torelax relaxed' = relaxed `IntSet.union` torelax cores' = mergedCore : rest if null intersected then do - C.logMessage cxt $ printf "BCD: found a new core of size %d" (IntSet.size torelax) + C.logMessage cxt $ printf "BCD: found a new core of size %d" (IntSet.size torelax) else do C.logMessage cxt $ printf "BCD: merging cores" SAT.addPBAtLeast solver (coreCostFun mergedCore) (coreLB mergedCore) -- redundant, but useful for direct search diff --git a/src/ToySolver/SAT/PBO/BCD2.hs b/src/ToySolver/SAT/PBO/BCD2.hs --- a/src/ToySolver/SAT/PBO/BCD2.hs +++ b/src/ToySolver/SAT/PBO/BCD2.hs @@ -1,14 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.PBO.BCD2 -- Copyright : (c) Masahiro Sakai 2014 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : portable +-- Portability : non-portable -- -- Reference: -- @@ -23,7 +24,7 @@ -- pp. 284-297. -- -- --- +-- ----------------------------------------------------------------------------- module ToySolver.SAT.PBO.BCD2 ( Options (..) @@ -137,7 +138,7 @@ fin <- atomically $ C.isFinished cxt unless fin $ do - + when (optEnableHardening opt) $ do deductedWeight <- readIORef deductedWeightRef hardened <- readIORef hardenedRef @@ -148,26 +149,26 @@ modifyIORef unrelaxedRef (`IntSet.difference` lits) modifyIORef relaxedRef (`IntSet.difference` lits) modifyIORef hardenedRef (`IntSet.union` lits) - - ub0 <- readIORef lastUBRef + + ub0 <- readIORef lastUBRef when (ub < ub0) $ do C.logMessage cxt $ printf "BCD2: updating upper bound: %d -> %d" ub0 ub SAT.addPBAtMost solver obj ub writeIORef lastUBRef ub - cores <- readIORef coresRef + cores <- readIORef coresRef unrelaxed <- readIORef unrelaxedRef relaxed <- readIORef relaxedRef hardened <- readIORef hardenedRef nsat <- readIORef nsatRef nunsat <- readIORef nunsatRef C.logMessage cxt $ printf "BCD2: %d <= obj <= %d" lb ub - C.logMessage cxt $ printf "BCD2: #cores=%d, #unrelaxed=%d, #relaxed=%d, #hardened=%d" + C.logMessage cxt $ printf "BCD2: #cores=%d, #unrelaxed=%d, #relaxed=%d, #hardened=%d" (length cores) (IntSet.size unrelaxed) (IntSet.size relaxed) (IntSet.size hardened) C.logMessage cxt $ printf "BCD2: #sat=%d #unsat=%d bias=%d/%d" nsat nunsat nunsat (nunsat + nsat) lastModel <- atomically $ C.getBestModel cxt - sels <- liftM IntMap.fromList $ forM cores $ \core -> do + sels <- liftM IntMap.fromList $ forM cores $ \core -> do coreLB <- getCoreLB core let coreUB = SAT.pbLinUpperBound (coreCostFun core) if coreUB < coreLB then do @@ -201,7 +202,7 @@ modifyIORef' nunsatRef (+1) failed <- SAT.getFailedAssumptions solver - case failed of + case IntSet.toList failed of [] -> C.setFinished cxt [sel] | Just (core,mid) <- IntMap.lookup sel sels -> do C.logMessage cxt $ printf "BCD2: updating lower bound of a core" @@ -214,10 +215,9 @@ updateLB lb core loop _ -> do - let failed' = IntSet.fromList failed - torelax = unrelaxed `IntSet.intersection` failed' - intersected = [(core,mid) | (sel,(core,mid)) <- IntMap.toList sels, sel `IntSet.member` failed'] - disjoint = [core | (sel,(core,_)) <- IntMap.toList sels, sel `IntSet.notMember` failed'] + let torelax = unrelaxed `IntSet.intersection` failed + intersected = [(core,mid) | (sel,(core,mid)) <- IntMap.toList sels, sel `IntSet.member` failed] + disjoint = [core | (sel,(core,_)) <- IntMap.toList sels, sel `IntSet.notMember` failed] modifyIORef unrelaxedRef (`IntSet.difference` torelax) modifyIORef relaxedRef (`IntSet.union` torelax) delta <- do @@ -239,7 +239,7 @@ else C.logMessage cxt $ printf "BCD2: relaxing %d and merging with %d cores into a new core of size %d: cost of the new core is >=%d" (IntSet.size torelax) (length intersected) (IntSet.size mergedCoreLits) mergedCoreLB' - when (mergedCoreLB /= mergedCoreLB') $ + when (mergedCoreLB /= mergedCoreLB') $ C.logMessage cxt $ printf "BCD2: refineLB: %d -> %d" mergedCoreLB mergedCoreLB' updateLB lb mergedCore loop diff --git a/src/ToySolver/SAT/PBO/Context.hs b/src/ToySolver/SAT/PBO/Context.hs --- a/src/ToySolver/SAT/PBO/Context.hs +++ b/src/ToySolver/SAT/PBO/Context.hs @@ -1,5 +1,17 @@ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.PBO.Context +-- Copyright : (c) Masahiro Sakai 2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.SAT.PBO.Context ( Context (..) , getBestValue @@ -119,7 +131,7 @@ join $ atomically $ do unsat <- isUnsat sc when unsat $ error "addSolution: already marked as unsatisfiable" -- FIXME: use throwSTM? - + sol0 <- getBestValue sc case sol0 of Just val0 | val0 <= val -> return $ return () @@ -212,7 +224,7 @@ addSolution cxt m = do addSolution (nBase cxt) m - + addLowerBound cxt lb = do addLowerBound (nBase cxt) (lb + nOffset cxt) diff --git a/src/ToySolver/SAT/PBO/MSU4.hs b/src/ToySolver/SAT/PBO/MSU4.hs --- a/src/ToySolver/SAT/PBO/MSU4.hs +++ b/src/ToySolver/SAT/PBO/MSU4.hs @@ -4,11 +4,11 @@ -- Module : ToySolver.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. @@ -50,7 +50,7 @@ weights :: SAT.LitMap Integer weights = IM.fromList sels - + loop :: (SAT.LitSet, SAT.LitSet) -> Integer -> IO () loop (unrelaxed, relaxed) lb = do ret <- SAT.solveWith solver (IS.toList unrelaxed) @@ -63,14 +63,14 @@ cont (unrelaxed, relaxed) lb else do core <- SAT.getFailedAssumptions solver - let ls = IS.fromList core `IS.intersection` unrelaxed + let ls = core `IS.intersection` unrelaxed if IS.null ls then do C.setFinished cxt else do - SAT.addClause solver [-l | l <- core] -- optional constraint but sometimes useful + SAT.addClause solver [-l | l <- IS.toList core] -- optional constraint but sometimes useful let min_weight = minimum [weights IM.! l | l <- IS.toList ls] lb' = lb + min_weight - C.logMessage cxt $ printf "MSU4: found a core: size = %d, minimal weight = %d" (length core) min_weight + C.logMessage cxt $ printf "MSU4: found a core: size = %d, minimal weight = %d" (IS.size core) min_weight C.addLowerBound cxt lb' cont (unrelaxed `IS.difference` ls, relaxed `IS.union` ls) lb' diff --git a/src/ToySolver/SAT/PBO/UnsatBased.hs b/src/ToySolver/SAT/PBO/UnsatBased.hs --- a/src/ToySolver/SAT/PBO/UnsatBased.hs +++ b/src/ToySolver/SAT/PBO/UnsatBased.hs @@ -1,15 +1,16 @@ {-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.PBO.UnsatBased -- Copyright : (c) Masahiro Sakai 2013 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional --- Portability : non-portable (BangPatterns) --- +-- Portability : non-portable +-- -- Reference: -- -- * Vasco Manquinho Ruben Martins Inês Lynce @@ -26,6 +27,7 @@ import Control.Monad import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.PBO.Context as C @@ -51,25 +53,25 @@ return () else do core <- SAT.getFailedAssumptions solver - case core of - [] -> C.setFinished cxt - _ -> do - let !min_c = minimum [sels IntMap.! sel | sel <- core] - !lb' = lb + min_c + if IntSet.null core then + C.setFinished cxt + else do + let !min_c = minimum [sels IntMap.! sel | sel <- IntSet.toList core] + !lb' = lb + min_c - xs <- forM core $ \sel -> do - r <- SAT.newVar solver - return (sel, r) - SAT.addExactly solver (map snd xs) 1 - SAT.addClause solver [-l | l <- core] -- optional constraint but sometimes useful + xs <- forM (IntSet.toList core) $ \sel -> do + r <- SAT.newVar solver + return (sel, r) + SAT.addExactly solver (map snd xs) 1 + SAT.addClause solver [-l | l <- IntSet.toList core] -- optional constraint but sometimes useful - ys <- liftM IntMap.unions $ forM xs $ \(sel, r) -> do - sel' <- SAT.newVar solver - SAT.addClause solver [-sel', r, sel] - let c = sels IntMap.! sel - if c > min_c - then return $ IntMap.fromList [(sel', min_c), (sel, c - min_c)] - else return $ IntMap.singleton sel' min_c - let sels' = IntMap.union ys (IntMap.difference sels (IntMap.fromList [(sel, ()) | sel <- core])) + ys <- liftM IntMap.unions $ forM xs $ \(sel, r) -> do + sel' <- SAT.newVar solver + SAT.addClause solver [-sel', r, sel] + let c = sels IntMap.! sel + if c > min_c + then return $ IntMap.fromList [(sel', min_c), (sel, c - min_c)] + else return $ IntMap.singleton sel' min_c + let sels' = IntMap.union ys (IntMap.difference sels (IntMap.fromSet (const ()) core)) - loop lb' sels' + loop lb' sels' diff --git a/src/ToySolver/SAT/Printer.hs b/src/ToySolver/SAT/Printer.hs --- a/src/ToySolver/SAT/Printer.hs +++ b/src/ToySolver/SAT/Printer.hs @@ -3,7 +3,7 @@ -- Module : ToySolver.SAT.Printer -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/SAT/SLS/ProbSAT.hs b/src/ToySolver/SAT/SLS/ProbSAT.hs deleted file mode 100644 --- a/src/ToySolver/SAT/SLS/ProbSAT.hs +++ /dev/null @@ -1,548 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall #-} ----------------------------------------------------------------------- --- | --- Module : ToySolver.SAT.SLS.ProbSAT --- Copyright : (c) Masahiro Sakai 2017 --- License : BSD-style --- --- Maintainer : masahiro.sakai@gmail.com --- Stability : provisional --- Portability : non-portable --- --- References: --- ----------------------------------------------------------------------- -module ToySolver.SAT.SLS.ProbSAT - ( Solver - , newSolver - , newSolverWeighted - , getNumVars - , getRandomGen - , setRandomGen - , getBestSolution - , getStatistics - - , Options (..) - , Callbacks (..) - , Statistics (..) - - , generateUniformRandomSolution - - , probsat - , walksat - ) where - -import Prelude hiding (break) - -import Control.Exception -import Control.Loop -import Control.Monad -import Control.Monad.Primitive -import Control.Monad.Trans -import Control.Monad.Trans.Except -import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt) -import Data.Array.IArray -import Data.Array.IO -import Data.Array.Unboxed -import Data.Array.Unsafe -import Data.Bits -import Data.Default.Class -import qualified Data.Foldable as F -import Data.Int -import Data.IORef -import Data.Maybe -import Data.Sequence ((|>)) -import qualified Data.Sequence as Seq -import Data.Typeable -import Data.Word -import System.Clock -import qualified System.Random.MWC as Rand -import qualified System.Random.MWC.Distributions as Rand -import qualified ToySolver.FileFormat.CNF as CNF -import ToySolver.Internal.Data.IOURef -import qualified ToySolver.Internal.Data.Vec as Vec -import qualified ToySolver.SAT.Types as SAT - --- ------------------------------------------------------------------- - -data Solver - = Solver - { svClauses :: !(Array ClauseId PackedClause) - , svClauseWeights :: !(Array ClauseId CNF.Weight) - , svClauseWeightsF :: !(UArray ClauseId Double) - , svClauseNumTrueLits :: !(IOUArray ClauseId Int32) - , svClauseUnsatClauseIndex :: !(IOUArray ClauseId Int) - , svUnsatClauses :: !(Vec.UVec ClauseId) - - , svVarOccurs :: !(Array SAT.Var (UArray Int ClauseId)) - , svVarOccursState :: !(Array SAT.Var (IOUArray Int Bool)) - , svSolution :: !(IOUArray SAT.Var Bool) - - , svObj :: !(IORef CNF.Weight) - - , svRandomGen :: !(IORef Rand.GenIO) - , svBestSolution :: !(IORef (CNF.Weight, SAT.Model)) - , svStatistics :: !(IORef Statistics) - } - -type ClauseId = Int - -type PackedClause = Array Int SAT.Lit - -newSolver :: CNF.CNF -> IO Solver -newSolver cnf = do - let wcnf = - CNF.WCNF - { CNF.wcnfNumVars = CNF.cnfNumVars cnf - , CNF.wcnfNumClauses = CNF.cnfNumClauses cnf - , CNF.wcnfTopCost = fromIntegral (CNF.cnfNumClauses cnf) + 1 - , CNF.wcnfClauses = [(1,c) | c <- CNF.cnfClauses cnf] - } - newSolverWeighted wcnf - -newSolverWeighted :: CNF.WCNF -> IO Solver -newSolverWeighted wcnf = do - let m :: SAT.Var -> Bool - m _ = False - nv = CNF.wcnfNumVars wcnf - - objRef <- newIORef (0::Integer) - - cs <- liftM catMaybes $ forM (CNF.wcnfClauses wcnf) $ \(w,pc) -> do - case SAT.normalizeClause (SAT.unpackClause pc) of - Nothing -> return Nothing - Just [] -> modifyIORef' objRef (w+) >> return Nothing - Just c -> do - let c' = listArray (0, length c - 1) c - seq c' $ return (Just (w,c')) - let len = length cs - clauses = listArray (0, len - 1) (map snd cs) - weights :: Array ClauseId CNF.Weight - weights = listArray (0, len - 1) (map fst cs) - weightsF :: UArray ClauseId Double - weightsF = listArray (0, len - 1) (map (fromIntegral . fst) cs) - - (varOccurs' :: IOArray SAT.Var (Seq.Seq (Int, Bool))) <- newArray (1, nv) Seq.empty - - clauseNumTrueLits <- newArray (bounds clauses) 0 - clauseUnsatClauseIndex <- newArray (bounds clauses) (-1) - unsatClauses <- Vec.new - - forAssocsM_ clauses $ \(c,clause) -> do - let n = sum [1 | lit <- elems clause, SAT.evalLit m lit] - writeArray clauseNumTrueLits c n - when (n == 0) $ do - i <- Vec.getSize unsatClauses - writeArray clauseUnsatClauseIndex c i - Vec.push unsatClauses c - modifyIORef objRef ((weights ! c) +) - forM_ (elems clause) $ \lit -> do - let v = SAT.litVar lit - let b = SAT.evalLit m lit - seq b $ modifyArray varOccurs' v (|> (c,b)) - - varOccurs <- do - (arr::IOArray SAT.Var (UArray Int ClauseId)) <- newArray_ (1, nv) - forM_ [1 .. nv] $ \v -> do - s <- readArray varOccurs' v - writeArray arr v $ listArray (0, Seq.length s - 1) (map fst (F.toList s)) - unsafeFreeze arr - - varOccursState <- do - (arr::IOArray SAT.Var (IOUArray Int Bool)) <- newArray_ (1, nv) - forM_ [1 .. nv] $ \v -> do - s <- readArray varOccurs' v - ss <- newArray_ (0, Seq.length s - 1) - forM_ (zip [0..] (F.toList s)) $ \(j,a) -> writeArray ss j (snd a) - writeArray arr v ss - unsafeFreeze arr - - solution <- newListArray (1, nv) $ [SAT.evalVar m v | v <- [1..nv]] - - bestObj <- readIORef objRef - bestSol <- freeze solution - bestSolution <- newIORef (bestObj, bestSol) - - randGen <- newIORef =<< Rand.create - - stat <- newIORef def - - return $ - Solver - { svClauses = clauses - , svClauseWeights = weights - , svClauseWeightsF = weightsF - , svClauseNumTrueLits = clauseNumTrueLits - , svClauseUnsatClauseIndex = clauseUnsatClauseIndex - , svUnsatClauses = unsatClauses - - , svVarOccurs = varOccurs - , svVarOccursState = varOccursState - , svSolution = solution - - , svObj = objRef - - , svRandomGen = randGen - , svBestSolution = bestSolution - , svStatistics = stat - } - - -flipVar :: Solver -> SAT.Var -> IO () -flipVar solver v = mask_ $ do - let occurs = svVarOccurs solver ! v - occursState = svVarOccursState solver ! v - seq occurs $ seq occursState $ return () - modifyArray (svSolution solver) v not - forAssocsM_ occurs $ \(j,!c) -> do - b <- unsafeRead occursState j - n <- unsafeRead (svClauseNumTrueLits solver) c - unsafeWrite occursState j (not b) - if b then do - unsafeWrite (svClauseNumTrueLits solver) c (n-1) - when (n==1) $ do - i <- Vec.getSize (svUnsatClauses solver) - Vec.push (svUnsatClauses solver) c - unsafeWrite (svClauseUnsatClauseIndex solver) c i - modifyIORef' (svObj solver) (+ unsafeAt (svClauseWeights solver) c) - else do - unsafeWrite (svClauseNumTrueLits solver) c (n+1) - when (n==0) $ do - s <- Vec.getSize (svUnsatClauses solver) - i <- unsafeRead (svClauseUnsatClauseIndex solver) c - unless (i == s-1) $ do - let i2 = s-1 - c2 <- Vec.unsafeRead (svUnsatClauses solver) i2 - Vec.unsafeWrite (svUnsatClauses solver) i2 c - Vec.unsafeWrite (svUnsatClauses solver) i c2 - unsafeWrite (svClauseUnsatClauseIndex solver) c2 i - _ <- Vec.unsafePop (svUnsatClauses solver) - modifyIORef' (svObj solver) (subtract (unsafeAt (svClauseWeights solver) c)) - return () - -setSolution :: SAT.IModel m => Solver -> m -> IO () -setSolution solver m = do - b <- getBounds (svSolution solver) - forM_ (range b) $ \v -> do - val <- readArray (svSolution solver) v - let val' = SAT.evalVar m v - unless (val == val') $ do - flipVar solver v - -getNumVars :: Solver -> IO Int -getNumVars solver = return $ rangeSize $ bounds (svVarOccurs solver) - -getRandomGen :: Solver -> IO Rand.GenIO -getRandomGen solver = readIORef (svRandomGen solver) - -setRandomGen :: Solver -> Rand.GenIO -> IO () -setRandomGen solver gen = writeIORef (svRandomGen solver) gen - -getBestSolution :: Solver -> IO (CNF.Weight, SAT.Model) -getBestSolution solver = readIORef (svBestSolution solver) - -getStatistics :: Solver -> IO Statistics -getStatistics solver = readIORef (svStatistics solver) - -{-# INLINE getMakeValue #-} -getMakeValue :: Solver -> SAT.Var -> IO Double -getMakeValue solver v = do - let occurs = svVarOccurs solver ! v - (lb,ub) = bounds occurs - seq occurs $ seq lb $ seq ub $ - numLoopState lb ub 0 $ \ !r !i -> do - let c = unsafeAt occurs i - n <- unsafeRead (svClauseNumTrueLits solver) c - return $! if n == 0 then (r + unsafeAt (svClauseWeightsF solver) c) else r - -{-# INLINE getBreakValue #-} -getBreakValue :: Solver -> SAT.Var -> IO Double -getBreakValue solver v = do - let occurs = svVarOccurs solver ! v - occursState = svVarOccursState solver ! v - (lb,ub) = bounds occurs - seq occurs $ seq occursState $ seq lb $ seq ub $ - numLoopState lb ub 0 $ \ !r !i -> do - b <- unsafeRead occursState i - if b then do - let c = unsafeAt occurs i - n <- unsafeRead (svClauseNumTrueLits solver) c - return $! if n==1 then (r + unsafeAt (svClauseWeightsF solver) c) else r - else - return r - --- ------------------------------------------------------------------- - -data Options - = Options - { optTarget :: !CNF.Weight - , optMaxTries :: !Int - , optMaxFlips :: !Int - , optPickClauseWeighted :: Bool - } - deriving (Eq, Show) - -instance Default Options where - def = - Options - { optTarget = 0 - , optMaxTries = 1 - , optMaxFlips = 100000 - , optPickClauseWeighted = False - } - -data Callbacks - = Callbacks - { cbGenerateInitialSolution :: Solver -> IO SAT.Model - , cbOnUpdateBestSolution :: Solver -> CNF.Weight -> SAT.Model -> IO () - } - -instance Default Callbacks where - def = - Callbacks - { cbGenerateInitialSolution = generateUniformRandomSolution - , cbOnUpdateBestSolution = \_ _ _ -> return () - } - -data Statistics - = Statistics - { statTotalCPUTime :: !TimeSpec - , statFlips :: !Int - , statFlipsPerSecond :: !Double - } - deriving (Eq, Show) - -instance Default Statistics where - def = - Statistics - { statTotalCPUTime = 0 - , statFlips = 0 - , statFlipsPerSecond = 0 - } - --- ------------------------------------------------------------------- - -generateUniformRandomSolution :: Solver -> IO SAT.Model -generateUniformRandomSolution solver = do - gen <- getRandomGen solver - n <- getNumVars solver - (a :: IOUArray Int Bool) <- newArray_ (1,n) - forM_ [1..n] $ \v -> do - b <- Rand.uniform gen - writeArray a v b - unsafeFreeze a - -checkCurrentSolution :: Solver -> Callbacks -> IO () -checkCurrentSolution solver cb = do - best <- readIORef (svBestSolution solver) - obj <- readIORef (svObj solver) - when (obj < fst best) $ do - sol <- freeze (svSolution solver) - writeIORef (svBestSolution solver) (obj, sol) - cbOnUpdateBestSolution cb solver obj sol - -pickClause :: Solver -> Options -> IO PackedClause -pickClause solver opt = do - gen <- getRandomGen solver - if optPickClauseWeighted opt then do - obj <- readIORef (svObj solver) - let f !j !x = do - c <- Vec.read (svUnsatClauses solver) j - let w = svClauseWeights solver ! c - if x < w then - return c - else - f (j + 1) (x - w) - x <- rand obj gen - c <- f 0 x - return $ (svClauses solver ! c) - else do - s <- Vec.getSize (svUnsatClauses solver) - j <- Rand.uniformR (0, s - 1) gen -- For integral types inclusive range is used - liftM (svClauses solver !) $ Vec.read (svUnsatClauses solver) j - -rand :: PrimMonad m => Integer -> Rand.Gen (PrimState m) -> m Integer -rand n gen - | n <= toInteger (maxBound :: Word32) = liftM toInteger $ Rand.uniformR (0, fromIntegral n - 1 :: Word32) gen - | otherwise = do - a <- rand (n `shiftR` 32) gen - (b::Word32) <- Rand.uniform gen - return $ (a `shiftL` 32) .|. toInteger b - -data Finished = Finished - deriving (Show, Typeable) - -instance Exception Finished - --- ------------------------------------------------------------------- - -probsat :: Solver -> Options -> Callbacks -> (Double -> Double -> Double) -> IO () -probsat solver opt cb f = do - gen <- getRandomGen solver - let maxClauseLen = - if rangeSize (bounds (svClauses solver)) == 0 - then 0 - else maximum $ map (rangeSize . bounds) $ elems (svClauses solver) - (wbuf :: IOUArray Int Double) <- newArray_ (0, maxClauseLen-1) - wsumRef <- newIOURef (0 :: Double) - - let pickVar :: PackedClause -> IO SAT.Var - pickVar c = do - writeIOURef wsumRef 0 - forAssocsM_ c $ \(k,lit) -> do - let v = SAT.litVar lit - m <- getMakeValue solver v - b <- getBreakValue solver v - let w = f m b - writeArray wbuf k w - modifyIOURef wsumRef (+w) - wsum <- readIOURef wsumRef - - let go :: Int -> Double -> IO Int - go !k !a = do - if not (inRange (bounds c) k) then do - return $! snd (bounds c) - else do - w <- readArray wbuf k - if a <= w then - return k - else - go (k + 1) (a - w) - k <- go 0 =<< Rand.uniformR (0, wsum) gen - return $! SAT.litVar (c ! k) - - startCPUTime <- getTime ProcessCPUTime - flipsRef <- newIOURef (0::Int) - - -- It's faster to use Control.Exception than using Control.Monad.Except - let body = do - replicateM_ (optMaxTries opt) $ do - sol <- cbGenerateInitialSolution cb solver - setSolution solver sol - checkCurrentSolution solver cb - replicateM_ (optMaxFlips opt) $ do - s <- Vec.getSize (svUnsatClauses solver) - when (s == 0) $ throw Finished - obj <- readIORef (svObj solver) - when (obj <= optTarget opt) $ throw Finished - c <- pickClause solver opt - v <- pickVar c - flipVar solver v - modifyIOURef flipsRef inc - checkCurrentSolution solver cb - body `catch` (\(_::Finished) -> return ()) - - endCPUTime <- getTime ProcessCPUTime - flips <- readIOURef flipsRef - let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime - totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int) - writeIORef (svStatistics solver) $ - Statistics - { statTotalCPUTime = totalCPUTime - , statFlips = flips - , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec - } - - return () - - - -walksat :: Solver -> Options -> Callbacks -> Double -> IO () -walksat solver opt cb p = do - gen <- getRandomGen solver - (buf :: Vec.UVec SAT.Var) <- Vec.new - - let pickVar :: PackedClause -> IO SAT.Var - pickVar c = do - Vec.clear buf - let (lb,ub) = bounds c - r <- runExceptT $ do - _ <- numLoopState lb ub (1.0/0.0) $ \ !b0 !i -> do - let v = SAT.litVar (c ! i) - b <- lift $ getBreakValue solver v - if b <= 0 then - throwE v -- freebie move - else if b < b0 then do - lift $ Vec.clear buf >> Vec.push buf v - return b - else if b == b0 then do - lift $ Vec.push buf v - return b0 - else do - return b0 - return () - case r of - Left v -> return v - Right _ -> do - flag <- Rand.bernoulli p gen - if flag then do - -- random walk move - i <- Rand.uniformR (lb,ub) gen - return $! SAT.litVar (c ! i) - else do - -- greedy move - s <- Vec.getSize buf - if s == 1 then - Vec.unsafeRead buf 0 - else do - i <- Rand.uniformR (0, s - 1) gen - Vec.unsafeRead buf i - - startCPUTime <- getTime ProcessCPUTime - flipsRef <- newIOURef (0::Int) - - -- It's faster to use Control.Exception than using Control.Monad.Except - let body = do - replicateM_ (optMaxTries opt) $ do - sol <- cbGenerateInitialSolution cb solver - setSolution solver sol - checkCurrentSolution solver cb - replicateM_ (optMaxFlips opt) $ do - s <- Vec.getSize (svUnsatClauses solver) - when (s == 0) $ throw Finished - obj <- readIORef (svObj solver) - when (obj <= optTarget opt) $ throw Finished - c <- pickClause solver opt - v <- pickVar c - flipVar solver v - modifyIOURef flipsRef inc - checkCurrentSolution solver cb - body `catch` (\(_::Finished) -> return ()) - - endCPUTime <- getTime ProcessCPUTime - flips <- readIOURef flipsRef - let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime - totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int) - writeIORef (svStatistics solver) $ - Statistics - { statTotalCPUTime = totalCPUTime - , statFlips = flips - , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec - } - - return () - --- ------------------------------------------------------------------- - -{-# INLINE modifyArray #-} -modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m () -modifyArray a i f = do - e <- readArray a i - writeArray a i (f e) - -{-# INLINE forAssocsM_ #-} -forAssocsM_ :: (IArray a e, Monad m) => a Int e -> ((Int,e) -> m ()) -> m () -forAssocsM_ a f = do - let (lb,ub) = bounds a - numLoop lb ub $ \i -> - f (i, unsafeAt a i) - -{-# INLINE inc #-} -inc :: Integral a => a -> a -inc a = a+1 - --- ------------------------------------------------------------------- diff --git a/src/ToySolver/SAT/Solver/CDCL.hs b/src/ToySolver/SAT/Solver/CDCL.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/CDCL.hs @@ -0,0 +1,3679 @@ +{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +#endif +#include "MachDeps.h" +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.CDCL +-- Copyright : (c) Masahiro Sakai 2012-2014 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- A CDCL SAT solver. +-- +-- It follows the design of MiniSat and SAT4J. +-- +-- See also: +-- +-- * +-- +-- * +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.Solver.CDCL + ( + -- * The @Solver@ type + Solver + , newSolver + , newSolverWithConfig + + -- * Basic data structures + , Var + , Lit + , literal + , litNot + , litVar + , litPolarity + , evalLit + + -- * Problem specification + , newVar + , newVars + , newVars_ + , resizeVarCapacity + -- ** Clauses + , AddClause (..) + , Clause + , evalClause + , PackedClause + , packClause + , unpackClause + -- ** Cardinality constraints + , AddCardinality (..) + , AtLeast + , Exactly + , evalAtLeast + , evalExactly + + -- ** (Linear) pseudo-boolean constraints + , AddPBLin (..) + , PBLinTerm + , PBLinSum + , PBLinAtLeast + , PBLinExactly + , evalPBLinSum + , evalPBLinAtLeast + , evalPBLinExactly + -- ** XOR clauses + , AddXORClause (..) + , XORClause + , evalXORClause + -- ** Theory + , setTheory + + -- * Solving + , solve + , solveWith + , BudgetExceeded (..) + , cancel + , Canceled (..) + + -- * Extract results + , IModel (..) + , Model + , getModel + , getFailedAssumptions + , getAssumptionsImplications + + -- * Solver configulation + , module ToySolver.SAT.Solver.CDCL.Config + , getConfig + , setConfig + , modifyConfig + , setVarPolarity + , setRandomGen + , getRandomGen + , setConfBudget + + -- * Callbacks + , setLogger + , clearLogger + , setTerminateCallback + , clearTerminateCallback + , setLearnCallback + , clearLearnCallback + + -- * Read state + , getNVars + , getNConstraints + , getNLearntConstraints + , getVarFixed + , getLitFixed + , getFixedLiterals + + -- * Internal API + , varBumpActivity + , varDecayActivity + ) where + +import Prelude hiding (log) +import Control.Loop +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Control.Exception +import Data.Array.IO +import Data.Array.Unsafe (unsafeFreeze) +import Data.Array.Base (unsafeRead, unsafeWrite) +import Data.Bits (xor) -- for defining 'combine' function +import Data.Coerce +import Data.Default.Class +import Data.Either +import Data.Function (on) +import Data.Hashable +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.IORef +import Data.Int +import Data.List +import Data.Maybe +import Data.Ord +import qualified Data.IntMap.Strict as IM +import qualified Data.IntSet as IS +import qualified Data.Set as Set +import ToySolver.Internal.Data.IOURef +import qualified ToySolver.Internal.Data.IndexedPriorityQueue as PQ +import qualified ToySolver.Internal.Data.Vec as Vec +import Data.Typeable +import System.Clock +import qualified System.Random.MWC as Rand +import Text.Printf + +#ifdef __GLASGOW_HASKELL__ +import GHC.Types (IO (..)) +import GHC.Exts hiding (Constraint) +#endif + +import ToySolver.Data.LBool +import ToySolver.SAT.Solver.CDCL.Config +import ToySolver.SAT.Types +import ToySolver.SAT.TheorySolver +import ToySolver.Internal.Util (revMapM) + +{-------------------------------------------------------------------- + LitArray +--------------------------------------------------------------------} + +newtype LitArray = LitArray (IOUArray Int PackedLit) deriving (Eq) + +newLitArray :: [Lit] -> IO LitArray +newLitArray lits = do + let size = length lits + liftM LitArray $ newListArray (0, size-1) (map packLit lits) + +readLitArray :: LitArray -> Int -> IO Lit +#if EXTRA_BOUNDS_CHECKING +readLitArray (LitArray a) i = liftM unpackLit $ readArray a i +#else +readLitArray (LitArray a) i = liftM unpackLit $ unsafeRead a i +#endif + +writeLitArray :: LitArray -> Int -> Lit -> IO () +#if EXTRA_BOUNDS_CHECKING +writeLitArray (LitArray a) i lit = writeArray a i (packLit lit) +#else +writeLitArray (LitArray a) i lit = unsafeWrite a i (packLit lit) +#endif + +getLits :: LitArray -> IO [Lit] +getLits (LitArray a) = liftM (map unpackLit) $ getElems a + +getLitArraySize :: LitArray -> IO Int +getLitArraySize (LitArray a) = do + (lb,ub) <- getBounds a + assert (lb == 0) $ return () + return $! ub-lb+1 + +{-------------------------------------------------------------------- + internal data structures +--------------------------------------------------------------------} + +type Level = Int + +levelRoot :: Level +levelRoot = 0 + +litIndex :: Lit -> Int +litIndex l = 2 * (litVar l - 1) + (if litPolarity l then 1 else 0) + +{-# INLINE varValue #-} +varValue :: Solver -> Var -> IO LBool +varValue solver v = liftM coerce $ Vec.unsafeRead (svVarValue solver) (v - 1) + +{-# INLINE litValue #-} +litValue :: Solver -> Lit -> IO LBool +litValue solver !l = do + -- litVar による heap allocation を避けるために、 + -- litPolarityによる分岐後にvarValueを呼ぶ。 + if litPolarity l then + varValue solver l + else do + m <- varValue solver (negate l) + return $! lnot m + +getVarFixed :: Solver -> Var -> IO LBool +getVarFixed solver !v = do + lv <- Vec.unsafeRead (svVarLevel solver) (v - 1) + if lv == levelRoot then + varValue solver v + else + return lUndef + +getLitFixed :: Solver -> Lit -> IO LBool +getLitFixed solver !l = do + -- litVar による heap allocation を避けるために、 + -- litPolarityによる分岐後にvarGetFixedを呼ぶ。 + if litPolarity l then + getVarFixed solver l + else do + m <- getVarFixed solver (negate l) + return $! lnot m + +getNFixed :: Solver -> IO Int +getNFixed solver = do + lv <- getDecisionLevel solver + if lv == levelRoot then + Vec.getSize (svTrail solver) + else + Vec.unsafeRead (svTrailLimit solver) 0 + +-- | it returns a set of literals that are fixed without any assumptions. +getFixedLiterals :: Solver -> IO [Lit] +getFixedLiterals solver = do + n <- getNFixed solver + revMapM (Vec.unsafeRead (svTrail solver)) [0..n-1] + +varLevel :: Solver -> Var -> IO Level +varLevel solver !v = do + val <- varValue solver v + when (val == lUndef) $ error ("ToySolver.SAT.varLevel: unassigned var " ++ show v) + Vec.unsafeRead (svVarLevel solver) (v - 1) + +litLevel :: Solver -> Lit -> IO Level +litLevel solver l = varLevel solver (litVar l) + +varReason :: Solver -> Var -> IO (Maybe SomeConstraintHandler) +varReason solver !v = do + val <- varValue solver v + when (val == lUndef) $ error ("ToySolver.SAT.varReason: unassigned var " ++ show v) + Vec.unsafeRead (svVarReason solver) (v - 1) + +varAssignNo :: Solver -> Var -> IO Int +varAssignNo solver !v = do + val <- varValue solver v + when (val == lUndef) $ error ("ToySolver.SAT.varAssignNo: unassigned var " ++ show v) + Vec.unsafeRead (svVarTrailIndex solver) (v - 1) + +-- | Solver instance +data Solver + = Solver + { svOk :: !(IORef Bool) + + , svVarQueue :: !PQ.PriorityQueue + , svTrail :: !(Vec.UVec Lit) + , svTrailLimit :: !(Vec.UVec Lit) + , svTrailNPropagated :: !(IOURef Int) + + -- variable information + , svVarValue :: !(Vec.UVec Int8) -- should be 'Vec.UVec LBool' but it's difficult to define MArray instance + , svVarPolarity :: !(Vec.UVec Bool) + , svVarActivity :: !(Vec.UVec VarActivity) + , svVarTrailIndex :: !(Vec.UVec Int) + , svVarLevel :: !(Vec.UVec Int) + -- | will be invoked once when the variable is assigned + , svVarWatches :: !(Vec.Vec [SomeConstraintHandler]) + , svVarOnUnassigned :: !(Vec.Vec [SomeConstraintHandler]) + , svVarReason :: !(Vec.Vec (Maybe SomeConstraintHandler)) + -- | exponential moving average estimate + , svVarEMAScaled :: !(Vec.UVec Double) + -- | When v was last assigned + , svVarWhenAssigned :: !(Vec.UVec Int) + -- | The number of learnt clauses v participated in generating since Assigned. + , svVarParticipated :: !(Vec.UVec Int) + -- | The number of learnt clauses v reasoned in generating since Assigned. + , svVarReasoned :: !(Vec.UVec Int) + + -- | will be invoked when this literal is falsified + , svLitWatches :: !(Vec.Vec [SomeConstraintHandler]) + , svLitOccurList :: !(Vec.Vec (HashSet SomeConstraintHandler)) + + , svConstrDB :: !(IORef [SomeConstraintHandler]) + , svLearntDB :: !(IORef (Int,[SomeConstraintHandler])) + + -- Theory + , svTheorySolver :: !(IORef (Maybe TheorySolver)) + , svTheoryChecked :: !(IOURef Int) + + -- Result + , svModel :: !(IORef (Maybe Model)) + , svFailedAssumptions :: !(IORef LitSet) + , svAssumptionsImplications :: !(IORef LitSet) + + -- Statistics + , svNDecision :: !(IOURef Int) + , svNRandomDecision :: !(IOURef Int) + , svNConflict :: !(IOURef Int) + , svNRestart :: !(IOURef Int) + , svNLearntGC :: !(IOURef Int) + , svNRemovedConstr :: !(IOURef Int) + + -- Configulation + , svConfig :: !(IORef Config) + , svRandomGen :: !(IORef Rand.GenIO) + , svConfBudget :: !(IOURef Int) + , svTerminateCallback :: !(IORef (Maybe (IO Bool))) + , svLearnCallback :: !(IORef (Maybe (Clause -> IO ()))) + + -- Logging + , svLogger :: !(IORef (Maybe (String -> IO ()))) + , svStartWC :: !(IORef TimeSpec) + , svLastStatWC :: !(IORef TimeSpec) + + -- Working spaces + , svCanceled :: !(IORef Bool) + , svAssumptions :: !(Vec.UVec Lit) + , svLearntLim :: !(IORef Int) + , svLearntLimAdjCnt :: !(IORef Int) + , svLearntLimSeq :: !(IORef [(Int,Int)]) + , svSeen :: !(Vec.UVec Bool) + , svPBLearnt :: !(IORef (Maybe PBLinAtLeast)) + + -- | Amount to bump next variable with. + , svVarInc :: !(IOURef Double) + + -- | Amount to bump next constraint with. + , svConstrInc :: !(IOURef Double) + + -- ERWA / LRB + + -- | step-size parameter α + , svERWAStepSize :: !(IOURef Double) + , svEMAScale :: !(IOURef Double) + , svLearntCounter :: !(IOURef Int) + } + +markBad :: Solver -> IO () +markBad solver = do + writeIORef (svOk solver) False + bcpClear solver + +bcpDequeue :: Solver -> IO (Maybe Lit) +bcpDequeue solver = do + n <- Vec.getSize (svTrail solver) + m <- readIOURef (svTrailNPropagated solver) + if m==n then + return Nothing + else do + -- m < n + lit <- Vec.unsafeRead (svTrail solver) m + modifyIOURef (svTrailNPropagated solver) (+1) + return (Just lit) + +bcpIsEmpty :: Solver -> IO Bool +bcpIsEmpty solver = do + p <- readIOURef (svTrailNPropagated solver) + n <- Vec.getSize (svTrail solver) + return $! n == p + +bcpCheckEmpty :: Solver -> IO () +bcpCheckEmpty solver = do + empty <- bcpIsEmpty solver + unless empty $ + error "BUG: BCP Queue should be empty at this point" + +bcpClear :: Solver -> IO () +bcpClear solver = do + m <- Vec.getSize (svTrail solver) + writeIOURef (svTrailNPropagated solver) m + +assignBy :: Solver -> Lit -> SomeConstraintHandler -> IO Bool +assignBy solver lit c = do + lv <- getDecisionLevel solver + let !c2 = if lv == levelRoot + then Nothing + else Just c + assign_ solver lit c2 + +assign :: Solver -> Lit -> IO Bool +assign solver lit = assign_ solver lit Nothing + +assign_ :: Solver -> Lit -> Maybe SomeConstraintHandler -> IO Bool +assign_ solver !lit reason = assert (validLit lit) $ do + let val = liftBool (litPolarity lit) + + val0 <- varValue solver (litVar lit) + if val0 /= lUndef then do + return $ val == val0 + else do + idx <- Vec.getSize (svTrail solver) + lv <- getDecisionLevel solver + + Vec.unsafeWrite (svVarValue solver) (litVar lit - 1) (coerce val) + Vec.unsafeWrite (svVarTrailIndex solver) (litVar lit - 1) idx + Vec.unsafeWrite (svVarLevel solver) (litVar lit - 1) lv + Vec.unsafeWrite (svVarReason solver) (litVar lit - 1) reason + Vec.unsafeWrite (svVarWhenAssigned solver) (litVar lit - 1) =<< readIOURef (svLearntCounter solver) + Vec.unsafeWrite (svVarParticipated solver) (litVar lit - 1) 0 + Vec.unsafeWrite (svVarReasoned solver) (litVar lit - 1) 0 + + Vec.push (svTrail solver) lit + + when debugMode $ logIO solver $ do + let r = case reason of + Nothing -> "" + Just _ -> " by propagation" + return $ printf "assign(level=%d): %d%s" lv lit r + + return True + +unassign :: Solver -> Var -> IO () +unassign solver !v = assert (validVar v) $ do + val <- varValue solver v + when (val == lUndef) $ error "unassign: should not happen" + + flag <- configEnablePhaseSaving <$> getConfig solver + when flag $ Vec.unsafeWrite (svVarPolarity solver) (v - 1) $! fromJust (unliftBool val) + + Vec.unsafeWrite (svVarValue solver) (v - 1) (coerce lUndef) + Vec.unsafeWrite (svVarTrailIndex solver) (v - 1) maxBound + Vec.unsafeWrite (svVarLevel solver) (v - 1) maxBound + Vec.unsafeWrite (svVarReason solver) (v - 1) Nothing + + -- ERWA / LRB computation + interval <- do + t2 <- readIOURef (svLearntCounter solver) + t1 <- Vec.unsafeRead (svVarWhenAssigned solver) (v - 1) + return (t2 - t1) + -- Interval = 0 is possible due to restarts. + when (interval > 0) $ do + participated <- Vec.unsafeRead (svVarParticipated solver) (v - 1) + reasoned <- Vec.unsafeRead (svVarReasoned solver) (v - 1) + alpha <- readIOURef (svERWAStepSize solver) + let learningRate = fromIntegral participated / fromIntegral interval + reasonSideRate = fromIntegral reasoned / fromIntegral interval + scale <- readIOURef (svEMAScale solver) + -- ema := (1 - α)ema + α*r + Vec.unsafeModify (svVarEMAScaled solver) (v - 1) (\orig -> (1 - alpha) * orig + alpha * scale * (learningRate + reasonSideRate)) + -- If v is assigned by random decision, it's possible that v is still in the queue. + PQ.update (svVarQueue solver) v + + let !l = if val == lTrue then v else -v + cs <- Vec.unsafeRead (svVarOnUnassigned solver) (v - 1) + Vec.unsafeWrite (svVarOnUnassigned solver) (v - 1) [] + forM_ cs $ \c -> + constrOnUnassigned solver c c l + + PQ.enqueue (svVarQueue solver) v + +addOnUnassigned :: Solver -> SomeConstraintHandler -> Lit -> IO () +addOnUnassigned solver constr !l = do + val <- varValue solver (litVar l) + when (val == lUndef) $ error "addOnUnassigned: should not happen" + Vec.unsafeModify (svVarOnUnassigned solver) (litVar l - 1) (constr :) + +-- | Register the constraint to be notified when the literal becames false. +watchLit :: Solver -> Lit -> SomeConstraintHandler -> IO () +watchLit solver !lit c = Vec.unsafeModify (svLitWatches solver) (litIndex lit) (c : ) + +-- | Register the constraint to be notified when the variable is assigned. +watchVar :: Solver -> Var -> SomeConstraintHandler -> IO () +watchVar solver !var c = Vec.unsafeModify (svVarWatches solver) (var - 1) (c :) + +unwatchLit :: Solver -> Lit -> SomeConstraintHandler -> IO () +unwatchLit solver !lit c = Vec.unsafeModify (svLitWatches solver) (litIndex lit) (delete c) + +unwatchVar :: Solver -> Lit -> SomeConstraintHandler -> IO () +unwatchVar solver !var c = Vec.unsafeModify (svVarWatches solver) (var - 1) (delete c) + +addToDB :: ConstraintHandler c => Solver -> c -> IO () +addToDB solver c = do + let c2 = toConstraintHandler c + modifyIORef (svConstrDB solver) (c2 : ) + when debugMode $ logIO solver $ do + str <- showConstraintHandler c + return $ printf "constraint %s is added" str + + b <- isPBRepresentable c + when b $ do + (lhs,_) <- toPBLinAtLeast c + forM_ lhs $ \(_,lit) -> do + Vec.unsafeModify (svLitOccurList solver) (litIndex lit) (HashSet.insert c2) + +addToLearntDB :: ConstraintHandler c => Solver -> c -> IO () +addToLearntDB solver c = do + modifyIORef (svLearntDB solver) $ \(n,xs) -> (n+1, toConstraintHandler c : xs) + when debugMode $ logIO solver $ do + str <- showConstraintHandler c + return $ printf "constraint %s is added" str + +reduceDB :: Solver -> IO () +reduceDB solver = do + (_,cs) <- readIORef (svLearntDB solver) + + xs <- forM cs $ \c -> do + p <- constrIsProtected solver c + w <- constrWeight solver c + actval <- constrReadActivity c + return (c, (p, w*actval)) + + -- Note that False <= True + let ys = sortBy (comparing snd) xs + (zs,ws) = splitAt (length ys `div` 2) ys + + let loop [] ret = return ret + loop ((c,(isShort,_)) : rest) ret = do + flag <- if isShort + then return True + else isLocked solver c + if flag then + loop rest (c:ret) + else do + detach solver c + loop rest ret + zs2 <- loop zs [] + + let cs2 = zs2 ++ map fst ws + n2 = length cs2 + + -- log solver $ printf "learnt constraints deletion: %d -> %d" n n2 + writeIORef (svLearntDB solver) (n2,cs2) + +type VarActivity = Double + +varActivity :: Solver -> Var -> IO VarActivity +varActivity solver v = Vec.unsafeRead (svVarActivity solver) (v - 1) + +varDecayActivity :: Solver -> IO () +varDecayActivity solver = do + d <- configVarDecay <$> getConfig solver + modifyIOURef (svVarInc solver) (d*) + +varBumpActivity :: Solver -> Var -> IO () +varBumpActivity solver !v = do + inc <- readIOURef (svVarInc solver) + Vec.unsafeModify (svVarActivity solver) (v - 1) (+inc) + conf <- getConfig solver + when (configBranchingStrategy conf == BranchingVSIDS) $ do + PQ.update (svVarQueue solver) v + aval <- Vec.unsafeRead (svVarActivity solver) (v - 1) + when (aval > 1e20) $ + -- Rescale + varRescaleAllActivity solver + +varRescaleAllActivity :: Solver -> IO () +varRescaleAllActivity solver = do + let a = svVarActivity solver + n <- getNVars solver + forLoop 0 ( + Vec.unsafeModify a i (* 1e-20) + modifyIOURef (svVarInc solver) (* 1e-20) + +varEMAScaled :: Solver -> Var -> IO Double +varEMAScaled solver v = Vec.unsafeRead (svVarEMAScaled solver) (v - 1) + +varIncrementParticipated :: Solver -> Var -> IO () +varIncrementParticipated solver v = Vec.unsafeModify (svVarParticipated solver) (v - 1) (+1) + +varIncrementReasoned :: Solver -> Var -> IO () +varIncrementReasoned solver v = Vec.unsafeModify (svVarReasoned solver) (v - 1) (+1) + +varEMADecay :: Solver -> IO () +varEMADecay solver = do + config <- getConfig solver + + alpha <- readIOURef (svERWAStepSize solver) + let alphaMin = configERWAStepSizeMin config + when (alpha > alphaMin) $ do + writeIOURef (svERWAStepSize solver) (max alphaMin (alpha - configERWAStepSizeDec config)) + + case configBranchingStrategy config of + BranchingLRB -> do + modifyIOURef (svEMAScale solver) (configEMADecay config *) + scale <- readIOURef (svEMAScale solver) + when (scale > 1e20) $ do + n <- getNVars solver + let a = svVarEMAScaled solver + forLoop 0 ( Vec.unsafeModify a i (/ scale) + writeIOURef (svEMAScale solver) 1.0 + _ -> return () + +variables :: Solver -> IO [Var] +variables solver = do + n <- getNVars solver + return [1 .. n] + +-- | number of variables of the problem. +getNVars :: Solver -> IO Int +getNVars solver = Vec.getSize (svVarValue solver) + +-- | number of assigned +getNAssigned :: Solver -> IO Int +getNAssigned solver = Vec.getSize (svTrail solver) + +-- | number of constraints. +getNConstraints :: Solver -> IO Int +getNConstraints solver = do + xs <- readIORef (svConstrDB solver) + return $ length xs + +-- | number of learnt constrints. +getNLearntConstraints :: Solver -> IO Int +getNLearntConstraints solver = do + (n,_) <- readIORef (svLearntDB solver) + return n + +learntConstraints :: Solver -> IO [SomeConstraintHandler] +learntConstraints solver = do + (_,cs) <- readIORef (svLearntDB solver) + return cs + +{-------------------------------------------------------------------- + Solver +--------------------------------------------------------------------} + +-- | Create a new 'Solver' instance. +newSolver :: IO Solver +newSolver = newSolverWithConfig def + +-- | Create a new 'Solver' instance with a given configulation. +newSolverWithConfig :: Config -> IO Solver +newSolverWithConfig config = do + rec + ok <- newIORef True + trail <- Vec.new + trail_lim <- Vec.new + trail_nprop <- newIOURef 0 + + varValue <- Vec.new + varPolarity <- Vec.new + varActivity <- Vec.new + varTrailIndex <- Vec.new + varLevel <- Vec.new + varWatches <- Vec.new + varOnUnassigned <- Vec.new + varReason <- Vec.new + varEMAScaled <- Vec.new + varWhenAssigned <- Vec.new + varParticipated <- Vec.new + varReasoned <- Vec.new + litWatches <- Vec.new + litOccurList <- Vec.new + + vqueue <- PQ.newPriorityQueueBy (ltVar solver) + db <- newIORef [] + db2 <- newIORef (0,[]) + as <- Vec.new + m <- newIORef Nothing + canceled <- newIORef False + ndecision <- newIOURef 0 + nranddec <- newIOURef 0 + nconflict <- newIOURef 0 + nrestart <- newIOURef 0 + nlearntgc <- newIOURef 0 + nremoved <- newIOURef 0 + + constrInc <- newIOURef 1 + varInc <- newIOURef 1 + + configRef <- newIORef config + + learntLim <- newIORef undefined + learntLimAdjCnt <- newIORef (-1) + learntLimSeq <- newIORef undefined + + logger <- newIORef Nothing + startWC <- newIORef undefined + lastStatWC <- newIORef undefined + + randgen <- newIORef =<< Rand.create + + failed <- newIORef IS.empty + implied <- newIORef IS.empty + + confBudget <- newIOURef (-1) + terminateCallback <- newIORef Nothing + learntCallback <- newIORef Nothing + + tsolver <- newIORef Nothing + tchecked <- newIOURef 0 + + seen <- Vec.new + pbLearnt <- newIORef Nothing + + alpha <- newIOURef 0.4 + emaScale <- newIOURef 1.0 + learntCounter <- newIOURef 0 + + let solver = + Solver + { svOk = ok + , svVarQueue = vqueue + , svTrail = trail + , svTrailLimit = trail_lim + , svTrailNPropagated = trail_nprop + + , svVarValue = varValue + , svVarPolarity = varPolarity + , svVarActivity = varActivity + , svVarTrailIndex = varTrailIndex + , svVarLevel = varLevel + , svVarWatches = varWatches + , svVarOnUnassigned = varOnUnassigned + , svVarReason = varReason + , svVarEMAScaled = varEMAScaled + , svVarWhenAssigned = varWhenAssigned + , svVarParticipated = varParticipated + , svVarReasoned = varReasoned + , svLitWatches = litWatches + , svLitOccurList = litOccurList + + , svConstrDB = db + , svLearntDB = db2 + + -- Theory + , svTheorySolver = tsolver + , svTheoryChecked = tchecked + + -- Result + , svModel = m + , svFailedAssumptions = failed + , svAssumptionsImplications = implied + + -- Statistics + , svNDecision = ndecision + , svNRandomDecision = nranddec + , svNConflict = nconflict + , svNRestart = nrestart + , svNLearntGC = nlearntgc + , svNRemovedConstr = nremoved + + -- Configulation + , svConfig = configRef + , svRandomGen = randgen + , svConfBudget = confBudget + , svTerminateCallback = terminateCallback + , svLearnCallback = learntCallback + + -- Logging + , svLogger = logger + , svStartWC = startWC + , svLastStatWC = lastStatWC + + -- Working space + , svCanceled = canceled + , svAssumptions = as + , svLearntLim = learntLim + , svLearntLimAdjCnt = learntLimAdjCnt + , svLearntLimSeq = learntLimSeq + , svVarInc = varInc + , svConstrInc = constrInc + , svSeen = seen + , svPBLearnt = pbLearnt + + , svERWAStepSize = alpha + , svEMAScale = emaScale + , svLearntCounter = learntCounter + } + return solver + +ltVar :: Solver -> Var -> Var -> IO Bool +ltVar solver !v1 !v2 = do + conf <- getConfig solver + case configBranchingStrategy conf of + BranchingVSIDS -> do + a1 <- varActivity solver v1 + a2 <- varActivity solver v2 + return $! a1 > a2 + _ -> do -- BranchingERWA and BranchingLRB + a1 <- varEMAScaled solver v1 + a2 <- varEMAScaled solver v1 + return $! a1 > a2 + +{-------------------------------------------------------------------- + Problem specification +--------------------------------------------------------------------} + +instance NewVar IO Solver where + newVar :: Solver -> IO Var + newVar solver = do + n <- Vec.getSize (svVarValue solver) +#if SIZEOF_HSINT > 4 + when (n == fromIntegral (maxBound :: PackedLit)) $ do + error "cannot allocate more variables" +#endif + let v = n + 1 + + Vec.push (svVarValue solver) (coerce lUndef) + Vec.push (svVarPolarity solver) True + Vec.push (svVarActivity solver) 0 + Vec.push (svVarTrailIndex solver) maxBound + Vec.push (svVarLevel solver) maxBound + Vec.push (svVarWatches solver) [] + Vec.push (svVarOnUnassigned solver) [] + Vec.push (svVarReason solver) Nothing + Vec.push (svVarEMAScaled solver) 0 + Vec.push (svVarWhenAssigned solver) (-1) + Vec.push (svVarParticipated solver) 0 + Vec.push (svVarReasoned solver) 0 + + Vec.push (svLitWatches solver) [] + Vec.push (svLitWatches solver) [] + Vec.push (svLitOccurList solver) HashSet.empty + Vec.push (svLitOccurList solver) HashSet.empty + + PQ.enqueue (svVarQueue solver) v + Vec.push (svSeen solver) False + return v + + newVars :: Solver -> Int -> IO [Var] + newVars solver n = do + nv <- getNVars solver +#if SIZEOF_HSINT > 4 + when (nv + n > fromIntegral (maxBound :: PackedLit)) $ do + error "cannot allocate more variables" +#endif + resizeVarCapacity solver (nv+n) + replicateM n (newVar solver) + + newVars_ :: Solver -> Int -> IO () + newVars_ solver n = do + nv <- getNVars solver +#if SIZEOF_HSINT > 4 + when (nv + n > fromIntegral (maxBound :: PackedLit)) $ do + error "cannot allocate more variables" +#endif + resizeVarCapacity solver (nv+n) + replicateM_ n (newVar solver) + +-- |Pre-allocate internal buffer for @n@ variables. +resizeVarCapacity :: Solver -> Int -> IO () +resizeVarCapacity solver n = do + Vec.resizeCapacity (svVarValue solver) n + Vec.resizeCapacity (svVarPolarity solver) n + Vec.resizeCapacity (svVarActivity solver) n + Vec.resizeCapacity (svVarTrailIndex solver) n + Vec.resizeCapacity (svVarLevel solver) n + Vec.resizeCapacity (svVarWatches solver) n + Vec.resizeCapacity (svVarOnUnassigned solver) n + Vec.resizeCapacity (svVarReason solver) n + Vec.resizeCapacity (svVarEMAScaled solver) n + Vec.resizeCapacity (svVarWhenAssigned solver) n + Vec.resizeCapacity (svVarParticipated solver) n + Vec.resizeCapacity (svVarReasoned solver) n + Vec.resizeCapacity (svLitWatches solver) (n*2) + Vec.resizeCapacity (svLitOccurList solver) (n*2) + Vec.resizeCapacity (svSeen solver) n + PQ.resizeHeapCapacity (svVarQueue solver) n + PQ.resizeTableCapacity (svVarQueue solver) (n+1) + +instance AddClause IO Solver where + addClause :: Solver -> Clause -> IO () + addClause solver lits = do + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + m <- instantiateClause (getLitFixed solver) lits + case normalizeClause =<< m of + Nothing -> return () + Just [] -> markBad solver + Just [lit] -> do + {- We do not call 'removeBackwardSubsumedBy' here, + because subsumed constraints will be removed by 'simplify'. -} + ret <- assign solver lit + assert ret $ return () + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + Just lits2 -> do + subsumed <- checkForwardSubsumption solver lits + unless subsumed $ do + removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits2], 1) + clause <- newClauseHandler lits2 False + addToDB solver clause + _ <- basicAttachClauseHandler solver clause + return () + +instance AddCardinality IO Solver where + addAtLeast :: Solver -> [Lit] -> Int -> IO () + addAtLeast solver lits n = do + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + (lits',n') <- liftM normalizeAtLeast $ instantiateAtLeast (getLitFixed solver) (lits,n) + let len = length lits' + + if n' <= 0 then return () + else if n' > len then markBad solver + else if n' == 1 then addClause solver lits' + else if n' == len then do + {- We do not call 'removeBackwardSubsumedBy' here, + because subsumed constraints will be removed by 'simplify'. -} + forM_ lits' $ \l -> do + ret <- assign solver l + assert ret $ return () + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + else do -- n' < len + removeBackwardSubsumedBy solver ([(1,lit) | lit <- lits'], fromIntegral n') + c <- newAtLeastHandler lits' n' False + addToDB solver c + _ <- basicAttachAtLeastHandler solver c + return () + +instance AddPBLin IO Solver where + addPBAtLeast :: Solver -> PBLinSum -> Integer -> IO () + addPBAtLeast solver ts n = do + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + (ts',n') <- liftM normalizePBLinAtLeast $ instantiatePBLinAtLeast (getLitFixed solver) (ts,n) + + case pbToAtLeast (ts',n') of + Just (lhs',rhs') -> addAtLeast solver lhs' rhs' + Nothing -> do + let cs = map fst ts' + slack = sum cs - n' + if n' <= 0 then return () + else if slack < 0 then markBad solver + else do + removeBackwardSubsumedBy solver (ts', n') + (ts'',n'') <- do + b <- configEnablePBSplitClausePart <$> getConfig solver + if b + then pbSplitClausePart solver (ts',n') + else return (ts',n') + + c <- newPBHandler solver ts'' n'' False + let constr = toConstraintHandler c + addToDB solver constr + ret <- attach solver constr + if not ret then do + markBad solver + else do + ret2 <- deduce solver + case ret2 of + Nothing -> return () + Just _ -> markBad solver + + addPBExactly :: Solver -> PBLinSum -> Integer -> IO () + addPBExactly solver ts n = do + (ts2,n2) <- liftM normalizePBLinExactly $ instantiatePBLinExactly (getLitFixed solver) (ts,n) + addPBAtLeast solver ts2 n2 + addPBAtMost solver ts2 n2 + + addPBAtLeastSoft :: Solver -> Lit -> PBLinSum -> Integer -> IO () + addPBAtLeastSoft solver sel lhs rhs = do + (lhs', rhs') <- liftM normalizePBLinAtLeast $ instantiatePBLinAtLeast (getLitFixed solver) (lhs,rhs) + addPBAtLeast solver ((rhs', litNot sel) : lhs') rhs' + + addPBExactlySoft :: Solver -> Lit -> PBLinSum -> Integer -> IO () + addPBExactlySoft solver sel lhs rhs = do + (lhs2, rhs2) <- liftM normalizePBLinExactly $ instantiatePBLinExactly (getLitFixed solver) (lhs,rhs) + addPBAtLeastSoft solver sel lhs2 rhs2 + addPBAtMostSoft solver sel lhs2 rhs2 + +-- | See documentation of 'setPBSplitClausePart'. +pbSplitClausePart :: Solver -> PBLinAtLeast -> IO PBLinAtLeast +pbSplitClausePart solver (lhs,rhs) = do + let (ts1,ts2) = partition (\(c,_) -> c >= rhs) lhs + if length ts1 < 2 then + return (lhs,rhs) + else do + sel <- newVar solver + addClause solver $ -sel : [l | (_,l) <- ts1] + return ((rhs,sel) : ts2, rhs) + +instance AddXORClause IO Solver where + addXORClause :: Solver -> [Lit] -> Bool -> IO () + addXORClause solver lits rhs = do + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + ok <- readIORef (svOk solver) + when ok $ do + xcl <- instantiateXORClause (getLitFixed solver) (lits,rhs) + case normalizeXORClause xcl of + ([], True) -> markBad solver + ([], False) -> return () + ([l], b) -> addClause solver [if b then l else litNot l] + (l:ls, b) -> do + c <- newXORClauseHandler ((if b then l else litNot l) : ls) False + addToDB solver c + _ <- basicAttachXORClauseHandler solver c + return () + +{-------------------------------------------------------------------- + Problem solving +--------------------------------------------------------------------} + +-- | Solve constraints. +-- Returns 'True' if the problem is SATISFIABLE. +-- Returns 'False' if the problem is UNSATISFIABLE. +solve :: Solver -> IO Bool +solve solver = do + Vec.clear (svAssumptions solver) + solve_ solver + +-- | Solve constraints under assuptions. +-- Returns 'True' if the problem is SATISFIABLE. +-- Returns 'False' if the problem is UNSATISFIABLE. +solveWith :: Solver + -> [Lit] -- ^ Assumptions + -> IO Bool +solveWith solver ls = do + Vec.clear (svAssumptions solver) + mapM_ (Vec.push (svAssumptions solver)) ls + solve_ solver + +solve_ :: Solver -> IO Bool +solve_ solver = do + config <- getConfig solver + writeIORef (svAssumptionsImplications solver) IS.empty + + log solver "Solving starts ..." + resetStat solver + writeIORef (svCanceled solver) False + writeIORef (svModel solver) Nothing + writeIORef (svFailedAssumptions solver) IS.empty + + ok <- readIORef (svOk solver) + if not ok then + return False + else do + when debugMode $ dumpVarActivity solver + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + nv <- getNVars solver + Vec.resizeCapacity (svTrail solver) nv + + unless (configRestartInc config > 1) $ error "RestartInc must be >1" + let restartSeq = + if configRestartFirst config > 0 + then mkRestartSeq (configRestartStrategy config) (configRestartFirst config) (configRestartInc config) + else repeat 0 + + let learntSizeAdj = do + (size,adj) <- shift (svLearntLimSeq solver) + writeIORef (svLearntLim solver) size + writeIORef (svLearntLimAdjCnt solver) adj + onConflict = do + cnt <- readIORef (svLearntLimAdjCnt solver) + if (cnt==0) + then learntSizeAdj + else writeIORef (svLearntLimAdjCnt solver) $! cnt-1 + + cnt <- readIORef (svLearntLimAdjCnt solver) + when (cnt == -1) $ do + unless (configLearntSizeInc config > 1) $ error "LearntSizeInc must be >1" + nc <- getNConstraints solver + let initialLearntLim = if configLearntSizeFirst config > 0 then configLearntSizeFirst config else max ((nc + nv) `div` 3) 16 + learntSizeSeq = iterate (ceiling . (configLearntSizeInc config *) . fromIntegral) initialLearntLim + learntSizeAdjSeq = iterate (\x -> (x * 3) `div` 2) (100::Int) + writeIORef (svLearntLimSeq solver) (zip learntSizeSeq learntSizeAdjSeq) + learntSizeAdj + + unless (0 <= configERWAStepSizeFirst config && configERWAStepSizeFirst config <= 1) $ + error "ERWAStepSizeFirst must be in [0..1]" + unless (0 <= configERWAStepSizeMin config && configERWAStepSizeFirst config <= 1) $ + error "ERWAStepSizeMin must be in [0..1]" + unless (0 <= configERWAStepSizeDec config) $ + error "ERWAStepSizeDec must be >=0" + writeIOURef (svERWAStepSize solver) (configERWAStepSizeFirst config) + + let loop [] = error "solve_: should not happen" + loop (conflict_lim:rs) = do + printStat solver True + ret <- search solver conflict_lim onConflict + case ret of + SRFinished x -> return $ Right x + SRBudgetExceeded -> return $ Left (throw BudgetExceeded) + SRCanceled -> return $ Left (throw Canceled) + SRRestart -> do + modifyIOURef (svNRestart solver) (+1) + backtrackTo solver levelRoot + loop rs + + printStatHeader solver + + startCPU <- getTime ProcessCPUTime + startWC <- getTime Monotonic + writeIORef (svStartWC solver) startWC + result <- loop restartSeq + endCPU <- getTime ProcessCPUTime + endWC <- getTime Monotonic + + case result of + Right True -> do + when (configCheckModel config) $ checkSatisfied solver + constructModel solver + mt <- getTheory solver + case mt of + Nothing -> return () + Just t -> thConstructModel t + _ -> return () + case result of + Right False -> return () + _ -> saveAssumptionsImplications solver + + backtrackTo solver levelRoot + + when debugMode $ dumpVarActivity solver + when debugMode $ dumpConstrActivity solver + printStat solver True + let durationSecs :: TimeSpec -> TimeSpec -> Double + durationSecs start end = fromIntegral (toNanoSecs (end `diffTimeSpec` start)) / 10^(9::Int) + (log solver . printf "#cpu_time = %.3fs") (durationSecs startCPU endCPU) + (log solver . printf "#wall_clock_time = %.3fs") (durationSecs startWC endWC) + (log solver . printf "#decision = %d") =<< readIOURef (svNDecision solver) + (log solver . printf "#random_decision = %d") =<< readIOURef (svNRandomDecision solver) + (log solver . printf "#conflict = %d") =<< readIOURef (svNConflict solver) + (log solver . printf "#restart = %d") =<< readIOURef (svNRestart solver) + + case result of + Right x -> return x + Left m -> m + +data BudgetExceeded = BudgetExceeded + deriving (Show, Typeable) + +instance Exception BudgetExceeded + +data Canceled = Canceled + deriving (Show, Typeable) + +instance Exception Canceled + +data SearchResult + = SRFinished Bool + | SRRestart + | SRBudgetExceeded + | SRCanceled + +search :: Solver -> Int -> IO () -> IO SearchResult +search solver !conflict_lim onConflict = do + conflictCounter <- newIORef 0 + let + loop :: IO SearchResult + loop = do + conflict <- deduce solver + case conflict of + Just constr -> do + ret <- handleConflict conflictCounter constr + case ret of + Just sr -> return sr + Nothing -> loop + Nothing -> do + lv <- getDecisionLevel solver + when (lv == levelRoot) $ simplify solver + checkGC + r <- pickAssumption + case r of + Nothing -> return (SRFinished False) + Just lit + | lit /= litUndef -> decide solver lit >> loop + | otherwise -> do + lit2 <- pickBranchLit solver + if lit2 == litUndef + then return (SRFinished True) + else decide solver lit2 >> loop + loop + + where + checkGC :: IO () + checkGC = do + n <- getNLearntConstraints solver + m <- getNAssigned solver + learnt_lim <- readIORef (svLearntLim solver) + when (learnt_lim >= 0 && n - m > learnt_lim) $ do + modifyIOURef (svNLearntGC solver) (+1) + reduceDB solver + + pickAssumption :: IO (Maybe Lit) + pickAssumption = do + s <- Vec.getSize (svAssumptions solver) + let go = do + d <- getDecisionLevel solver + if not (d < s) then + return (Just litUndef) + else do + l <- Vec.unsafeRead (svAssumptions solver) d + val <- litValue solver l + if val == lTrue then do + -- dummy decision level + pushDecisionLevel solver + go + else if val == lFalse then do + -- conflict with assumption + core <- analyzeFinal solver l + writeIORef (svFailedAssumptions solver) (IS.fromList core) + return Nothing + else + return (Just l) + go + + handleConflict :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) + handleConflict conflictCounter constr = do + varEMADecay solver + varDecayActivity solver + constrDecayActivity solver + onConflict + + modifyIOURef (svNConflict solver) (+1) + d <- getDecisionLevel solver + + when debugMode $ logIO solver $ do + str <- showConstraintHandler constr + return $ printf "conflict(level=%d): %s" d str + + modifyIORef' conflictCounter (+1) + c <- readIORef conflictCounter + + modifyIOURef (svConfBudget solver) $ \confBudget -> + if confBudget > 0 then confBudget - 1 else confBudget + confBudget <- readIOURef (svConfBudget solver) + + terminateCallback' <- readIORef (svTerminateCallback solver) + case terminateCallback' of + Nothing -> return () + Just terminateCallback -> do + ret <- terminateCallback + when ret $ writeIORef (svCanceled solver) True + canceled <- readIORef (svCanceled solver) + + when (c `mod` 100 == 0) $ do + printStat solver False + + if d == levelRoot then do + callLearnCallback solver [] + markBad solver + return $ Just (SRFinished False) + else if confBudget==0 then + return $ Just SRBudgetExceeded + else if canceled then + return $ Just SRCanceled + else if conflict_lim > 0 && c >= conflict_lim then + return $ Just SRRestart + else do + modifyIOURef (svLearntCounter solver) (+1) + config <- getConfig solver + case configLearningStrategy config of + LearningClause -> learnClause constr >> return Nothing + LearningHybrid -> learnHybrid conflictCounter constr + + learnClause :: SomeConstraintHandler -> IO () + learnClause constr = do + (learntClause, level) <- analyzeConflict solver constr + backtrackTo solver level + case learntClause of + [] -> error "search(LearningClause): should not happen" + [lit] -> do + ret <- assign solver lit + assert ret $ return () + return () + lit:_ -> do + cl <- newClauseHandler learntClause True + let constr2 = toConstraintHandler cl + addToLearntDB solver constr2 + basicAttachClauseHandler solver cl + assignBy solver lit constr2 + constrBumpActivity solver constr2 + + learnHybrid :: IORef Int -> SomeConstraintHandler -> IO (Maybe SearchResult) + learnHybrid conflictCounter constr = do + (learntClause, clauseLevel) <- analyzeConflict solver constr + (pb, minLevel) <- do + z <- readIORef (svPBLearnt solver) + case z of + Nothing -> return (z, clauseLevel) + Just pb -> do + pbLevel <- pbBacktrackLevel solver pb + return (z, min clauseLevel pbLevel) + backtrackTo solver minLevel + + case learntClause of + [] -> error "search(LearningHybrid): should not happen" + [lit] -> do + _ <- assign solver lit -- This should always succeed. + return () + lit:_ -> do + cl <- newClauseHandler learntClause True + let constr2 = toConstraintHandler cl + addToLearntDB solver constr2 + basicAttachClauseHandler solver cl + constrBumpActivity solver constr2 + when (minLevel == clauseLevel) $ do + _ <- assignBy solver lit constr2 -- This should always succeed. + return () + + ret <- deduce solver + case ret of + Just conflicted -> do + handleConflict conflictCounter conflicted + -- TODO: should also learn the PB constraint? + Nothing -> do + case pb of + Nothing -> return Nothing + Just (lhs,rhs) -> do + h <- newPBHandlerPromoted solver lhs rhs True + case h of + CHClause _ -> do + {- We don't want to add additional clause, + since it would be subsumed by already added one. -} + return Nothing + _ -> do + addToLearntDB solver h + ret2 <- attach solver h + constrBumpActivity solver h + if ret2 then + return Nothing + else + handleConflict conflictCounter h + +-- | Cancel exectution of 'solve' or 'solveWith'. +-- +-- This can be called from other threads. +cancel :: Solver -> IO () +cancel solver = writeIORef (svCanceled solver) True + +-- | After 'solve' returns True, it returns an satisfying assignment. +getModel :: Solver -> IO Model +getModel solver = do + m <- readIORef (svModel solver) + return (fromJust m) + +-- | After 'solveWith' returns False, it returns a set of assumptions +-- that leads to contradiction. In particular, if it returns an empty +-- set, the problem is unsatisiable without any assumptions. +getFailedAssumptions :: Solver -> IO LitSet +getFailedAssumptions solver = readIORef (svFailedAssumptions solver) + +-- | __EXPERIMENTAL API__: After 'solveWith' returns True or failed with 'BudgetExceeded' exception, +-- it returns a set of literals that are implied by assumptions. +getAssumptionsImplications :: Solver -> IO LitSet +getAssumptionsImplications solver = readIORef (svAssumptionsImplications solver) + +{-------------------------------------------------------------------- + Simplification +--------------------------------------------------------------------} + +-- | Simplify the constraint database according to the current top-level assigment. +simplify :: Solver -> IO () +simplify solver = do + let loop [] rs !n = return (rs,n) + loop (y:ys) rs !n = do + b1 <- isSatisfied solver y + b2 <- isLocked solver y + if b1 && not b2 then do + detach solver y + loop ys rs (n+1) + else loop ys (y:rs) n + + -- simplify original constraint DB + do + xs <- readIORef (svConstrDB solver) + (ys,n) <- loop xs [] (0::Int) + modifyIOURef (svNRemovedConstr solver) (+n) + writeIORef (svConstrDB solver) ys + + -- simplify learnt constraint DB + do + (m,xs) <- readIORef (svLearntDB solver) + (ys,n) <- loop xs [] (0::Int) + writeIORef (svLearntDB solver) (m-n, ys) + +{- +References: +L. Zhang, "On subsumption removal and On-the-Fly CNF simplification," +Theory and Applications of Satisfiability Testing (2005), pp. 482-489. +-} + +checkForwardSubsumption :: Solver -> Clause -> IO Bool +checkForwardSubsumption solver lits = do + flag <- configEnableForwardSubsumptionRemoval <$> getConfig solver + if not flag then + return False + else do + withEnablePhaseSaving False $ do + bracket_ + (pushDecisionLevel solver) + (backtrackTo solver levelRoot) $ do + b <- allM (\lit -> assign solver (litNot lit)) lits + if b then + liftM isJust (deduce solver) + else do + when debugMode $ log solver ("forward subsumption: " ++ show lits) + return True + where + withEnablePhaseSaving flag m = + bracket + (getConfig solver) + (\saved -> modifyConfig solver (\config -> config{ configEnablePhaseSaving = configEnablePhaseSaving saved })) + (\saved -> setConfig solver saved{ configEnablePhaseSaving = flag } >> m) + +removeBackwardSubsumedBy :: Solver -> PBLinAtLeast -> IO () +removeBackwardSubsumedBy solver pb = do + flag <- configEnableBackwardSubsumptionRemoval <$> getConfig solver + when flag $ do + xs <- backwardSubsumedBy solver pb + when debugMode $ do + forM_ (HashSet.toList xs) $ \c -> do + s <- showConstraintHandler c + log solver (printf "backward subsumption: %s is subsumed by %s\n" s (show pb)) + removeConstraintHandlers solver xs + +backwardSubsumedBy :: Solver -> PBLinAtLeast -> IO (HashSet SomeConstraintHandler) +backwardSubsumedBy solver pb@(lhs,_) = do + xs <- forM lhs $ \(_,lit) -> do + Vec.unsafeRead (svLitOccurList solver) (litIndex lit) + case xs of + [] -> return HashSet.empty + s:ss -> do + let p c = do + -- Note that @isPBRepresentable c@ is always True here, + -- because only such constraints are added to occur list. + -- See 'addToDB'. + pb2 <- instantiatePBLinAtLeast (getLitFixed solver) =<< toPBLinAtLeast c + return $ pbLinSubsume pb pb2 + liftM HashSet.fromList + $ filterM p + $ HashSet.toList + $ foldl' HashSet.intersection s ss + +removeConstraintHandlers :: Solver -> HashSet SomeConstraintHandler -> IO () +removeConstraintHandlers _ zs | HashSet.null zs = return () +removeConstraintHandlers solver zs = do + let loop [] rs !n = return (rs,n) + loop (c:cs) rs !n = do + if c `HashSet.member` zs then do + detach solver c + loop cs rs (n+1) + else loop cs (c:rs) n + xs <- readIORef (svConstrDB solver) + (ys,n) <- loop xs [] (0::Int) + modifyIOURef (svNRemovedConstr solver) (+n) + writeIORef (svConstrDB solver) ys + +{-------------------------------------------------------------------- + Parameter settings. +--------------------------------------------------------------------} + +{-------------------------------------------------------------------- + Configulation +--------------------------------------------------------------------} + +getConfig :: Solver -> IO Config +getConfig solver = readIORef $ svConfig solver + +setConfig :: Solver -> Config -> IO () +setConfig solver conf = do + orig <- getConfig solver + writeIORef (svConfig solver) conf + when (configBranchingStrategy orig /= configBranchingStrategy conf) $ do + PQ.rebuild (svVarQueue solver) + +modifyConfig :: Solver -> (Config -> Config) -> IO () +modifyConfig solver f = do + config <- getConfig solver + setConfig solver $ f config + +-- | The default polarity of a variable. +setVarPolarity :: Solver -> Var -> Bool -> IO () +setVarPolarity solver v val = Vec.unsafeWrite (svVarPolarity solver) (v - 1) val + +-- | Set random generator used by the random variable selection +setRandomGen :: Solver -> Rand.GenIO -> IO () +setRandomGen solver = writeIORef (svRandomGen solver) + +-- | Get random generator used by the random variable selection +getRandomGen :: Solver -> IO Rand.GenIO +getRandomGen solver = readIORef (svRandomGen solver) + +setConfBudget :: Solver -> Maybe Int -> IO () +setConfBudget solver (Just b) | b >= 0 = writeIOURef (svConfBudget solver) b +setConfBudget solver _ = writeIOURef (svConfBudget solver) (-1) + +-- | Set a callback function used to indicate a termination requirement to the solver. +-- +-- The solver will periodically call this function and check its return value during +-- the search. If the callback function returns `True` the solver terminates and throws +-- 'Canceled' exception. +-- +-- See also 'clearTerminateCallback' and +-- [IPASIR](https://github.com/biotomas/ipasir)'s @ipasir_set_terminate()@ function. +setTerminateCallback :: Solver -> IO Bool -> IO () +setTerminateCallback solver callback = writeIORef (svTerminateCallback solver) (Just callback) + +-- | Clear a callback function set by `setTerminateCallback` +clearTerminateCallback :: Solver -> IO () +clearTerminateCallback solver = writeIORef (svTerminateCallback solver) Nothing + +-- | Set a callback function used to extract learned clauses from the solver. +-- The solver will call this function for each learned clause. +-- +-- See also 'clearLearnCallback' and +-- [IPASIR](https://github.com/biotomas/ipasir)'s @ipasir_set_learn()@ function. +setLearnCallback :: Solver -> (Clause -> IO ()) -> IO () +setLearnCallback solver callback = writeIORef (svLearnCallback solver) (Just callback) + +-- | Clear a callback function set by `setLearnCallback` +clearLearnCallback :: Solver -> IO () +clearLearnCallback solver = writeIORef (svLearnCallback solver) Nothing + +{-------------------------------------------------------------------- + API for implementation of @solve@ +--------------------------------------------------------------------} + +pickBranchLit :: Solver -> IO Lit +pickBranchLit !solver = do + gen <- readIORef (svRandomGen solver) + let vqueue = svVarQueue solver + !randfreq <- configRandomFreq <$> getConfig solver + !size <- PQ.queueSize vqueue + -- System.Random.random produces [0,1), but System.Random.MWC.uniform produces (0,1] + !r <- liftM (1 -) $ Rand.uniform gen + var <- + if (r < randfreq && size >= 2) then do + a <- PQ.getHeapArray vqueue + i <- Rand.uniformR (0, size-1) gen + var <- readArray a i + val <- varValue solver var + if val == lUndef then do + modifyIOURef (svNRandomDecision solver) (1+) + return var + else return litUndef + else + return litUndef + + -- Activity based decision + let loop :: IO Var + loop = do + m <- PQ.dequeue vqueue + case m of + Nothing -> return litUndef + Just var2 -> do + val2 <- varValue solver var2 + if val2 /= lUndef + then loop + else return var2 + var2 <- + if var==litUndef + then loop + else return var + + if var2==litUndef then + return litUndef + else do + -- TODO: random polarity + p <- Vec.unsafeRead (svVarPolarity solver) (var2 - 1) + return $! literal var2 p + +decide :: Solver -> Lit -> IO () +decide solver !lit = do + modifyIOURef (svNDecision solver) (+1) + pushDecisionLevel solver + when debugMode $ do + val <- litValue solver lit + when (val /= lUndef) $ error "decide: should not happen" + assign solver lit + return () + +deduce :: Solver -> IO (Maybe SomeConstraintHandler) +deduce solver = liftM (either Just (const Nothing)) $ runExceptT $ do + let loop = do + deduceB solver + deduceT solver + empty <- liftIO $ bcpIsEmpty solver + unless empty $ loop + loop + +deduceB :: Solver -> ExceptT SomeConstraintHandler IO () +deduceB solver = loop + where + loop :: ExceptT SomeConstraintHandler IO () + loop = do + r <- liftIO $ bcpDequeue solver + case r of + Nothing -> return () + Just lit -> do + processLit lit + processVar lit + loop + + processLit :: Lit -> ExceptT SomeConstraintHandler IO () + processLit !lit = ExceptT $ liftM (maybe (Right ()) Left) $ do + let falsifiedLit = litNot lit + a = svLitWatches solver + idx = litIndex falsifiedLit + let loop2 [] = return Nothing + loop2 (w:ws) = do + ok <- propagate solver w falsifiedLit + if ok then + loop2 ws + else do + Vec.unsafeModify a idx (++ws) + return (Just w) + ws <- Vec.unsafeRead a idx + Vec.unsafeWrite a idx [] + loop2 ws + + processVar :: Lit -> ExceptT SomeConstraintHandler IO () + processVar !lit = ExceptT $ liftM (maybe (Right ()) Left) $ do + let falsifiedLit = litNot lit + idx = litVar lit - 1 + let loop2 [] = return Nothing + loop2 (w:ws) = do + ok <- propagate solver w falsifiedLit + if ok + then loop2 ws + else do + Vec.unsafeModify (svVarWatches solver) idx (++ws) + return (Just w) + ws <- Vec.unsafeRead (svVarWatches solver) idx + Vec.unsafeWrite (svVarWatches solver) idx [] + loop2 ws + +analyzeConflict :: ConstraintHandler c => Solver -> c -> IO (Clause, Level) +analyzeConflict solver constr = do + config <- getConfig solver + let isHybrid = configLearningStrategy config == LearningHybrid + + d <- getDecisionLevel solver + (out :: Vec.UVec Lit) <- Vec.new + Vec.push out 0 -- (leave room for the asserting literal) + (pathC :: IOURef Int) <- newIOURef 0 + + pbConstrRef <- newIORef undefined + + let f lits = do + forM_ lits $ \lit -> do + let !v = litVar lit + lv <- litLevel solver lit + b <- Vec.unsafeRead (svSeen solver) (v - 1) + when (not b && lv > levelRoot) $ do + varBumpActivity solver v + varIncrementParticipated solver v + if lv >= d then do + Vec.unsafeWrite (svSeen solver) (v - 1) True + modifyIOURef pathC (+1) + else do + Vec.push out lit + + processLitHybrid pb constr2 lit getLits = do + pb2 <- do + let clausePB = do + lits <- getLits + return $ clauseToPBLinAtLeast (lit : lits) + b <- isPBRepresentable constr2 + if not b then do + clausePB + else do + pb2 <- toPBLinAtLeast constr2 + o <- pbOverSAT solver pb2 + if o then do + clausePB + else + return pb2 + let pb3 = cutResolve pb pb2 (litVar lit) + ls = IS.fromList [l | (_,l) <- fst pb3] + seq ls $ writeIORef pbConstrRef (ls, pb3) + + popUnseen = do + l <- peekTrail solver + let !v = litVar l + b <- Vec.unsafeRead (svSeen solver) (v - 1) + if b then do + return () + else do + when isHybrid $ do + (ls, pb) <- readIORef pbConstrRef + when (litNot l `IS.member` ls) $ do + Just constr2 <- varReason solver v + processLitHybrid pb constr2 l (reasonOf solver constr2 (Just l)) + popTrail solver + popUnseen + + loop = do + popUnseen + l <- peekTrail solver + let !v = litVar l + Vec.unsafeWrite (svSeen solver) (v - 1) False + modifyIOURef pathC (subtract 1) + c <- readIOURef pathC + if c > 0 then do + Just constr2 <- varReason solver v + constrBumpActivity solver constr2 + lits <- reasonOf solver constr2 (Just l) + f lits + when isHybrid $ do + (ls, pb) <- readIORef pbConstrRef + when (litNot l `IS.member` ls) $ do + processLitHybrid pb constr2 l (return lits) + popTrail solver + loop + else do + Vec.unsafeWrite out 0 (litNot l) + + constrBumpActivity solver constr + falsifiedLits <- reasonOf solver constr Nothing + f falsifiedLits + when isHybrid $ do + pb <- do + b <- isPBRepresentable constr + if b then + toPBLinAtLeast constr + else + return (clauseToPBLinAtLeast falsifiedLits) + let ls = IS.fromList [l | (_,l) <- fst pb] + seq ls $ writeIORef pbConstrRef (ls, pb) + loop + lits <- liftM IS.fromList $ Vec.getElems out + + lits2 <- minimizeConflictClause solver lits + + incrementReasoned solver (IS.toList lits2) + + xs <- liftM (sortBy (flip (comparing snd))) $ + forM (IS.toList lits2) $ \l -> do + lv <- litLevel solver l + return (l,lv) + + when isHybrid $ do + (_, pb) <- readIORef pbConstrRef + case pbToClause pb of + Just _ -> writeIORef (svPBLearnt solver) Nothing + Nothing -> writeIORef (svPBLearnt solver) (Just pb) + + let level = case xs of + [] -> error "analyzeConflict: should not happen" + [_] -> levelRoot + _:(_,lv):_ -> lv + clause = map fst xs + callLearnCallback solver clause + return (clause, level) + +-- { p } ∪ { pにfalseを割り当てる原因のassumption } +analyzeFinal :: Solver -> Lit -> IO [Lit] +analyzeFinal solver p = do + let go :: Int -> VarSet -> [Lit] -> IO [Lit] + go i seen result + | i < 0 = return result + | otherwise = do + l <- Vec.unsafeRead (svTrail solver) i + lv <- litLevel solver l + if lv == levelRoot then + return result + else if litVar l `IS.member` seen then do + r <- varReason solver (litVar l) + case r of + Nothing -> do + let seen' = IS.delete (litVar l) seen + go (i-1) seen' (l : result) + Just constr -> do + c <- reasonOf solver constr (Just l) + let seen' = IS.delete (litVar l) seen `IS.union` IS.fromList [litVar l2 | l2 <- c] + go (i-1) seen' result + else + go (i-1) seen result + n <- Vec.getSize (svTrail solver) + go (n-1) (IS.singleton (litVar p)) [p] + +callLearnCallback :: Solver -> Clause -> IO () +callLearnCallback solver clause = do + cb <- readIORef (svLearnCallback solver) + case cb of + Nothing -> return () + Just callback -> callback clause + +pbBacktrackLevel :: Solver -> PBLinAtLeast -> IO Level +pbBacktrackLevel _ ([], rhs) = assert (rhs > 0) $ return levelRoot +pbBacktrackLevel solver (lhs, rhs) = do + levelToLiterals <- liftM (IM.unionsWith IM.union) $ forM lhs $ \(c,lit) -> do + val <- litValue solver lit + if val /= lUndef then do + level <- litLevel solver lit + return $ IM.singleton level (IM.singleton lit (c,val)) + else + return $ IM.singleton maxBound (IM.singleton lit (c,val)) + + let replay [] !_ = error "pbBacktrackLevel: should not happen" + replay ((lv,lv_lits) : lvs) !slack = do + let slack_lv = slack - sum [c | (_,(c,val)) <- IM.toList lv_lits, val == lFalse] + if slack_lv < 0 then + return lv -- CONFLICT + else if any (\(_, lits2) -> any (\(c,_) -> c > slack_lv) (IM.elems lits2)) lvs then + return lv -- UNIT + else + replay lvs slack_lv + + let initial_slack = sum [c | (c,_) <- lhs] - rhs + if any (\(c,_) -> c > initial_slack) lhs then + return 0 + else do + replay (IM.toList levelToLiterals) initial_slack + +minimizeConflictClause :: Solver -> LitSet -> IO LitSet +minimizeConflictClause solver lits = do + ccmin <- configCCMin <$> getConfig solver + if ccmin >= 2 then + minimizeConflictClauseRecursive solver lits + else if ccmin >= 1 then + minimizeConflictClauseLocal solver lits + else + return lits + +minimizeConflictClauseLocal :: Solver -> LitSet -> IO LitSet +minimizeConflictClauseLocal solver lits = do + let xs = IS.toAscList lits + ys <- filterM (liftM not . isRedundant) xs + when debugMode $ do + log solver "minimizeConflictClauseLocal:" + log solver $ show xs + log solver $ show ys + return $ IS.fromAscList $ ys + + where + isRedundant :: Lit -> IO Bool + isRedundant lit = do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls <- reasonOf solver c2 (Just (litNot lit)) + allM test ls + + test :: Lit -> IO Bool + test lit = do + lv <- litLevel solver lit + return $ lv == levelRoot || lit `IS.member` lits + +minimizeConflictClauseRecursive :: Solver -> LitSet -> IO LitSet +minimizeConflictClauseRecursive solver lits = do + let + isRedundant :: Lit -> IO Bool + isRedundant lit = do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls <- reasonOf solver c2 (Just (litNot lit)) + go ls IS.empty + + go :: [Lit] -> IS.IntSet -> IO Bool + go [] _ = return True + go (lit : ls) seen = do + lv <- litLevel solver lit + if lv == levelRoot || lit `IS.member` lits || lit `IS.member` seen then + go ls seen + else do + c <- varReason solver (litVar lit) + case c of + Nothing -> return False + Just c2 -> do + ls2 <- reasonOf solver c2 (Just (litNot lit)) + go (ls2 ++ ls) (IS.insert lit seen) + + let xs = IS.toAscList lits + ys <- filterM (liftM not . isRedundant) xs + when debugMode $ do + log solver "minimizeConflictClauseRecursive:" + log solver $ show xs + log solver $ show ys + return $ IS.fromAscList $ ys + +incrementReasoned :: Solver -> Clause -> IO () +incrementReasoned solver ls = do + let f reasonSided l = do + m <- varReason solver (litVar l) + case m of + Nothing -> return reasonSided + Just constr -> do + v <- litValue solver l + unless (v == lFalse) undefined + xs <- constrReasonOf solver constr (Just (litNot l)) + return $ reasonSided `IS.union` IS.fromList (map litVar xs) + reasonSided <- foldM f IS.empty ls + mapM_ (varIncrementReasoned solver) (IS.toList reasonSided) + +peekTrail :: Solver -> IO Lit +peekTrail solver = do + n <- Vec.getSize (svTrail solver) + Vec.unsafeRead (svTrail solver) (n-1) + +popTrail :: Solver -> IO Lit +popTrail solver = do + l <- Vec.unsafePop (svTrail solver) + unassign solver (litVar l) + return l + +getDecisionLevel ::Solver -> IO Int +getDecisionLevel solver = Vec.getSize (svTrailLimit solver) + +pushDecisionLevel :: Solver -> IO () +pushDecisionLevel solver = do + Vec.push (svTrailLimit solver) =<< Vec.getSize (svTrail solver) + mt <- getTheory solver + case mt of + Nothing -> return () + Just t -> thPushBacktrackPoint t + +popDecisionLevel :: Solver -> IO () +popDecisionLevel solver = do + n <- Vec.unsafePop (svTrailLimit solver) + let loop = do + m <- Vec.getSize (svTrail solver) + when (m > n) $ do + popTrail solver + loop + loop + mt <- getTheory solver + case mt of + Nothing -> return () + Just t -> thPopBacktrackPoint t + +-- | Revert to the state at given level +-- (keeping all assignment at @level@ but not beyond). +backtrackTo :: Solver -> Int -> IO () +backtrackTo solver level = do + when debugMode $ log solver $ printf "backtrackTo: %d" level + loop + bcpClear solver + mt <- getTheory solver + case mt of + Nothing -> return () + Just _ -> do + n <- Vec.getSize (svTrail solver) + writeIOURef (svTheoryChecked solver) n + where + loop :: IO () + loop = do + lv <- getDecisionLevel solver + when (lv > level) $ do + popDecisionLevel solver + loop + +constructModel :: Solver -> IO () +constructModel solver = do + n <- getNVars solver + (marr::IOUArray Var Bool) <- newArray_ (1,n) + forLoop 1 (<=n) (+1) $ \v -> do + val <- varValue solver v + writeArray marr v (fromJust (unliftBool val)) + m <- unsafeFreeze marr + writeIORef (svModel solver) (Just m) + +saveAssumptionsImplications :: Solver -> IO () +saveAssumptionsImplications solver = do + n <- Vec.getSize (svAssumptions solver) + lv <- getDecisionLevel solver + + lim_beg <- + if lv == 0 then + return 0 + else + Vec.read (svTrailLimit solver) 0 + lim_end <- + if lv > n then + Vec.read (svTrailLimit solver) n + else + Vec.getSize (svTrail solver) + + let ref = svAssumptionsImplications solver + forM_ [lim_beg .. lim_end-1] $ \i -> do + lit <- Vec.read (svTrail solver) i + modifyIORef' ref (IS.insert lit) + forM_ [0..n-1] $ \i -> do + lit <- Vec.read (svAssumptions solver) i + modifyIORef' ref (IS.delete lit) + +constrDecayActivity :: Solver -> IO () +constrDecayActivity solver = do + d <- configConstrDecay <$> getConfig solver + modifyIOURef (svConstrInc solver) (d*) + +constrBumpActivity :: ConstraintHandler a => Solver -> a -> IO () +constrBumpActivity solver this = do + aval <- constrReadActivity this + when (aval >= 0) $ do -- learnt clause + inc <- readIOURef (svConstrInc solver) + let aval2 = aval+inc + constrWriteActivity this $! aval2 + when (aval2 > 1e20) $ + -- Rescale + constrRescaleAllActivity solver + +constrRescaleAllActivity :: Solver -> IO () +constrRescaleAllActivity solver = do + xs <- learntConstraints solver + forM_ xs $ \c -> do + aval <- constrReadActivity c + when (aval >= 0) $ + constrWriteActivity c $! (aval * 1e-20) + modifyIOURef (svConstrInc solver) (* 1e-20) + +resetStat :: Solver -> IO () +resetStat solver = do + writeIOURef (svNDecision solver) 0 + writeIOURef (svNRandomDecision solver) 0 + writeIOURef (svNConflict solver) 0 + writeIOURef (svNRestart solver) 0 + writeIOURef (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 <- getTime Monotonic + b <- if force + then return True + else do + lastWC <- readIORef (svLastStatWC solver) + return $ sec (nowWC `diffTimeSpec` lastWC) > 1 + when b $ do + startWC <- readIORef (svStartWC solver) + let tm = showTimeDiff $ nowWC `diffTimeSpec` startWC + restart <- readIOURef (svNRestart solver) + dec <- readIOURef (svNDecision solver) + conflict <- readIOURef (svNConflict solver) + learntLim <- readIORef (svLearntLim solver) + learntGC <- readIOURef (svNLearntGC solver) + fixed <- getNFixed solver + removed <- readIOURef (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 :: TimeSpec -> String +showTimeDiff t + | 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 = fromIntegral (toNanoSecs t) / 10^(9::Int) + + si :: Integer + si = fromIntegral (sec t) + + m :: Rational + m = s / 60 + + mi :: Integer + mi = round m + + h :: Rational + h = m / 60 + + hi :: Integer + hi = round h + +{-------------------------------------------------------------------- + constraint implementation +--------------------------------------------------------------------} + +class (Eq a, Hashable a) => ConstraintHandler a where + toConstraintHandler :: a -> SomeConstraintHandler + + showConstraintHandler :: a -> IO String + + constrAttach :: Solver -> SomeConstraintHandler -> a -> IO Bool + + constrDetach :: Solver -> SomeConstraintHandler -> a -> IO () + + constrIsLocked :: Solver -> SomeConstraintHandler -> a -> IO Bool + + -- | invoked with the watched literal when the literal is falsified. + -- 'watch' で 'toConstraint' を呼び出して heap allocation が発生するのを + -- 避けるために、元の 'SomeConstraintHandler' も渡しておく。 + constrPropagate :: Solver -> SomeConstraintHandler -> a -> Lit -> IO Bool + + -- | deduce a clause C∨l from the constraint and return C. + -- C and l should be false and true respectively under the current + -- assignment. + constrReasonOf :: Solver -> a -> Maybe Lit -> IO Clause + + constrOnUnassigned :: Solver -> SomeConstraintHandler -> a -> Lit -> IO () + + isPBRepresentable :: a -> IO Bool + toPBLinAtLeast :: a -> IO PBLinAtLeast + + isSatisfied :: Solver -> a -> IO Bool + + constrIsProtected :: Solver -> a -> IO Bool + constrIsProtected _ _ = return False + + constrWeight :: Solver -> a -> IO Double + constrWeight _ _ = return 1.0 + + constrReadActivity :: a -> IO Double + + constrWriteActivity :: a -> Double -> IO () + +attach :: Solver -> SomeConstraintHandler -> IO Bool +attach solver c = constrAttach solver c c + +detach :: Solver -> SomeConstraintHandler -> IO () +detach solver c = do + constrDetach solver c c + b <- isPBRepresentable c + when b $ do + (lhs,_) <- toPBLinAtLeast c + forM_ lhs $ \(_,lit) -> do + Vec.unsafeModify (svLitOccurList solver) (litIndex lit) (HashSet.delete c) + +-- | invoked with the watched literal when the literal is falsified. +propagate :: Solver -> SomeConstraintHandler -> Lit -> IO Bool +propagate solver c l = constrPropagate solver c c l + +-- | deduce a clause C∨l from the constraint and return C. +-- C and l should be false and true respectively under the current +-- assignment. +reasonOf :: ConstraintHandler a => Solver -> a -> Maybe Lit -> IO Clause +reasonOf solver c x = do + when debugMode $ + case x of + Nothing -> return () + Just lit -> do + val <- litValue solver lit + unless (lTrue == val) $ do + str <- showConstraintHandler c + error (printf "reasonOf: value of literal %d should be True but %s (constrReasonOf %s %s)" lit (show val) str (show x)) + cl <- constrReasonOf solver c x + when debugMode $ do + forM_ cl $ \lit -> do + val <- litValue solver lit + unless (lFalse == val) $ do + str <- showConstraintHandler c + error (printf "reasonOf: value of literal %d should be False but %s (constrReasonOf %s %s)" lit (show val) str (show x)) + return cl + +isLocked :: Solver -> SomeConstraintHandler -> IO Bool +isLocked solver c = constrIsLocked solver c c + +data SomeConstraintHandler + = CHClause !ClauseHandler + | CHAtLeast !AtLeastHandler + | CHPBCounter !PBHandlerCounter + | CHPBPueblo !PBHandlerPueblo + | CHXORClause !XORClauseHandler + | CHTheory !TheoryHandler + deriving Eq + +instance Hashable SomeConstraintHandler where + hashWithSalt s (CHClause c) = s `hashWithSalt` (0::Int) `hashWithSalt` c + hashWithSalt s (CHAtLeast c) = s `hashWithSalt` (1::Int) `hashWithSalt` c + hashWithSalt s (CHPBCounter c) = s `hashWithSalt` (2::Int) `hashWithSalt` c + hashWithSalt s (CHPBPueblo c) = s `hashWithSalt` (3::Int) `hashWithSalt` c + hashWithSalt s (CHXORClause c) = s `hashWithSalt` (4::Int) `hashWithSalt` c + hashWithSalt s (CHTheory c) = s `hashWithSalt` (5::Int) `hashWithSalt` c + +instance ConstraintHandler SomeConstraintHandler where + toConstraintHandler = id + + showConstraintHandler (CHClause c) = showConstraintHandler c + showConstraintHandler (CHAtLeast c) = showConstraintHandler c + showConstraintHandler (CHPBCounter c) = showConstraintHandler c + showConstraintHandler (CHPBPueblo c) = showConstraintHandler c + showConstraintHandler (CHXORClause c) = showConstraintHandler c + showConstraintHandler (CHTheory c) = showConstraintHandler c + + constrAttach solver this (CHClause c) = constrAttach solver this c + constrAttach solver this (CHAtLeast c) = constrAttach solver this c + constrAttach solver this (CHPBCounter c) = constrAttach solver this c + constrAttach solver this (CHPBPueblo c) = constrAttach solver this c + constrAttach solver this (CHXORClause c) = constrAttach solver this c + constrAttach solver this (CHTheory c) = constrAttach solver this c + + constrDetach solver this (CHClause c) = constrDetach solver this c + constrDetach solver this (CHAtLeast c) = constrDetach solver this c + constrDetach solver this (CHPBCounter c) = constrDetach solver this c + constrDetach solver this (CHPBPueblo c) = constrDetach solver this c + constrDetach solver this (CHXORClause c) = constrDetach solver this c + constrDetach solver this (CHTheory c) = constrDetach solver this c + + constrIsLocked solver this (CHClause c) = constrIsLocked solver this c + constrIsLocked solver this (CHAtLeast c) = constrIsLocked solver this c + constrIsLocked solver this (CHPBCounter c) = constrIsLocked solver this c + constrIsLocked solver this (CHPBPueblo c) = constrIsLocked solver this c + constrIsLocked solver this (CHXORClause c) = constrIsLocked solver this c + constrIsLocked solver this (CHTheory c) = constrIsLocked solver this c + + constrPropagate solver this (CHClause c) lit = constrPropagate solver this c lit + constrPropagate solver this (CHAtLeast c) lit = constrPropagate solver this c lit + constrPropagate solver this (CHPBCounter c) lit = constrPropagate solver this c lit + constrPropagate solver this (CHPBPueblo c) lit = constrPropagate solver this c lit + constrPropagate solver this (CHXORClause c) lit = constrPropagate solver this c lit + constrPropagate solver this (CHTheory c) lit = constrPropagate solver this c lit + + constrReasonOf solver (CHClause c) l = constrReasonOf solver c l + constrReasonOf solver (CHAtLeast c) l = constrReasonOf solver c l + constrReasonOf solver (CHPBCounter c) l = constrReasonOf solver c l + constrReasonOf solver (CHPBPueblo c) l = constrReasonOf solver c l + constrReasonOf solver (CHXORClause c) l = constrReasonOf solver c l + constrReasonOf solver (CHTheory c) l = constrReasonOf solver c l + + constrOnUnassigned solver this (CHClause c) l = constrOnUnassigned solver this c l + constrOnUnassigned solver this (CHAtLeast c) l = constrOnUnassigned solver this c l + constrOnUnassigned solver this (CHPBCounter c) l = constrOnUnassigned solver this c l + constrOnUnassigned solver this (CHPBPueblo c) l = constrOnUnassigned solver this c l + constrOnUnassigned solver this (CHXORClause c) l = constrOnUnassigned solver this c l + constrOnUnassigned solver this (CHTheory c) l = constrOnUnassigned solver this c l + + isPBRepresentable (CHClause c) = isPBRepresentable c + isPBRepresentable (CHAtLeast c) = isPBRepresentable c + isPBRepresentable (CHPBCounter c) = isPBRepresentable c + isPBRepresentable (CHPBPueblo c) = isPBRepresentable c + isPBRepresentable (CHXORClause c) = isPBRepresentable c + isPBRepresentable (CHTheory c) = isPBRepresentable c + + toPBLinAtLeast (CHClause c) = toPBLinAtLeast c + toPBLinAtLeast (CHAtLeast c) = toPBLinAtLeast c + toPBLinAtLeast (CHPBCounter c) = toPBLinAtLeast c + toPBLinAtLeast (CHPBPueblo c) = toPBLinAtLeast c + toPBLinAtLeast (CHXORClause c) = toPBLinAtLeast c + toPBLinAtLeast (CHTheory c) = toPBLinAtLeast c + + isSatisfied solver (CHClause c) = isSatisfied solver c + isSatisfied solver (CHAtLeast c) = isSatisfied solver c + isSatisfied solver (CHPBCounter c) = isSatisfied solver c + isSatisfied solver (CHPBPueblo c) = isSatisfied solver c + isSatisfied solver (CHXORClause c) = isSatisfied solver c + isSatisfied solver (CHTheory c) = isSatisfied solver c + + constrIsProtected solver (CHClause c) = constrIsProtected solver c + constrIsProtected solver (CHAtLeast c) = constrIsProtected solver c + constrIsProtected solver (CHPBCounter c) = constrIsProtected solver c + constrIsProtected solver (CHPBPueblo c) = constrIsProtected solver c + constrIsProtected solver (CHXORClause c) = constrIsProtected solver c + constrIsProtected solver (CHTheory c) = constrIsProtected solver c + + constrReadActivity (CHClause c) = constrReadActivity c + constrReadActivity (CHAtLeast c) = constrReadActivity c + constrReadActivity (CHPBCounter c) = constrReadActivity c + constrReadActivity (CHPBPueblo c) = constrReadActivity c + constrReadActivity (CHXORClause c) = constrReadActivity c + constrReadActivity (CHTheory c) = constrReadActivity c + + constrWriteActivity (CHClause c) aval = constrWriteActivity c aval + constrWriteActivity (CHAtLeast c) aval = constrWriteActivity c aval + constrWriteActivity (CHPBCounter c) aval = constrWriteActivity c aval + constrWriteActivity (CHPBPueblo c) aval = constrWriteActivity c aval + constrWriteActivity (CHXORClause c) aval = constrWriteActivity c aval + constrWriteActivity (CHTheory c) aval = constrWriteActivity c aval + +isReasonOf :: Solver -> SomeConstraintHandler -> Lit -> IO Bool +isReasonOf solver c lit = do + val <- litValue solver lit + if val == lUndef then + return False + else do + m <- varReason solver (litVar lit) + case m of + Nothing -> return False + Just c2 -> return $! c == c2 + +-- To avoid heap-allocation Maybe value, it returns -1 when not found. +findForWatch :: Solver -> LitArray -> Int -> Int -> IO Int +#ifndef __GLASGOW_HASKELL__ +findForWatch solver a beg end = go beg end + where + go :: Int -> Int -> IO Int + go i end | i > end = return (-1) + go i end = do + val <- litValue s =<< readLitArray a i + if val /= lFalse + then return i + else go (i+1) end +#else +{- We performed worker-wrapper transfomation manually, since the worker + generated by GHC has type + "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", + not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". + We want latter one to avoid heap-allocating Int value. -} +findForWatch solver a (I# beg) (I# end) = IO $ \w -> + case go# beg end w of + (# w2, ret #) -> (# w2, I# ret #) + where + go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) + go# i end' w | isTrue# (i ># end') = (# w, -1# #) + go# i end' w = + case unIO (litValue solver =<< readLitArray a (I# i)) w of + (# w2, val #) -> + if val /= lFalse + then (# w2, i #) + else go# (i +# 1#) end' w2 + + unIO (IO f) = f +#endif + +-- To avoid heap-allocating Maybe value, it returns -1 when not found. +findForWatch2 :: Solver -> LitArray -> Int -> Int -> IO Int +#ifndef __GLASGOW_HASKELL__ +findForWatch2 solver a beg end = go beg end + where + go :: Int -> Int -> IO Int + go i end | i > end = return (-1) + go i end = do + val <- litValue s =<< readLitArray a i + if val == lUndef + then return i + else go (i+1) end +#else +{- We performed worker-wrapper transfomation manually, since the worker + generated by GHC has type + "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int #)", + not "Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #)". + We want latter one to avoid heap-allocating Int value. -} +findForWatch2 solver a (I# beg) (I# end) = IO $ \w -> + case go# beg end w of + (# w2, ret #) -> (# w2, I# ret #) + where + go# :: Int# -> Int# -> State# RealWorld -> (# State# RealWorld, Int# #) + go# i end w | isTrue# (i ># end) = (# w, -1# #) + go# i end w = + case unIO (litValue solver =<< readLitArray a (I# i)) w of + (# w2, val #) -> + if val == lUndef + then (# w2, i #) + else go# (i +# 1#) end w2 + + unIO (IO f) = f +#endif + +{-------------------------------------------------------------------- + Clause +--------------------------------------------------------------------} + +data ClauseHandler + = ClauseHandler + { claLits :: !LitArray + , claActivity :: !(IORef Double) + , claHash :: !Int + } + +claGetSize :: ClauseHandler -> IO Int +claGetSize cla = getLitArraySize (claLits cla) + +instance Eq ClauseHandler where + (==) = (==) `on` claLits + +instance Hashable ClauseHandler where + hash = claHash + hashWithSalt = defaultHashWithSalt + +newClauseHandler :: Clause -> Bool -> IO ClauseHandler +newClauseHandler ls learnt = do + a <- newLitArray ls + act <- newIORef $! (if learnt then 0 else -1) + return (ClauseHandler a act (hash ls)) + +instance ConstraintHandler ClauseHandler where + toConstraintHandler = CHClause + + showConstraintHandler this = do + lits <- getLits (claLits this) + return (show lits) + + constrAttach solver this this2 = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + size <- claGetSize this2 + if size == 0 then do + markBad solver + return False + else if size == 1 then do + lit0 <- readLitArray (claLits this2) 0 + assignBy solver lit0 this + else do + ref <- newIORef 1 + let f i = do + lit_i <- readLitArray (claLits this2) i + val_i <- litValue solver lit_i + if val_i /= lFalse then + return True + else do + j <- readIORef ref + k <- findForWatch solver (claLits this2) j (size - 1) + case k of + -1 -> do + return False + _ -> do + lit_k <- readLitArray (claLits this2) k + writeLitArray (claLits this2) i lit_k + writeLitArray (claLits this2) k lit_i + writeIORef ref $! (k+1) + return True + + b <- f 0 + if b then do + lit0 <- readLitArray (claLits this2) 0 + watchLit solver lit0 this + b2 <- f 1 + if b2 then do + lit1 <- readLitArray (claLits this2) 1 + watchLit solver lit1 this + return True + else do -- UNIT + -- We need to watch the most recently falsified literal + (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..size-1] $ \l -> do + lit <- readLitArray (claLits this2) l + lv <- litLevel solver lit + return (l,lv) + lit1 <- readLitArray (claLits this2) 1 + liti <- readLitArray (claLits this2) i + writeLitArray (claLits this2) 1 liti + writeLitArray (claLits this2) i lit1 + watchLit solver liti this + assignBy solver lit0 this -- should always succeed + else do -- CONFLICT + ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [0..size-1] $ \l -> do + lit <- readLitArray (claLits this2) l + lv <- litLevel solver lit + return (l,lv) + forM_ (zip [0..] ls) $ \(i,lit) -> do + writeLitArray (claLits this2) i lit + lit0 <- readLitArray (claLits this2) 0 + lit1 <- readLitArray (claLits this2) 1 + watchLit solver lit0 this + watchLit solver lit1 this + return False + + constrDetach solver this this2 = do + size <- claGetSize this2 + when (size >= 2) $ do + lit0 <- readLitArray (claLits this2) 0 + lit1 <- readLitArray (claLits this2) 1 + unwatchLit solver lit0 this + unwatchLit solver lit1 this + + constrIsLocked solver this this2 = do + size <- claGetSize this2 + if size < 2 then + return False + else do + lit <- readLitArray (claLits this2) 0 + isReasonOf solver this lit + + constrPropagate !solver this this2 !falsifiedLit = do + preprocess + + !lit0 <- readLitArray a 0 + !val0 <- litValue solver lit0 + if val0 == lTrue then do + watchLit solver falsifiedLit this + return True + else do + size <- claGetSize this2 + i <- findForWatch solver a 2 (size - 1) + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "constrPropagate: %s is unit" str + watchLit solver falsifiedLit this + assignBy solver lit0 this + _ -> do + !lit1 <- readLitArray a 1 + !liti <- readLitArray a i + writeLitArray a 1 liti + writeLitArray a i lit1 + watchLit solver liti this + return True + + where + a = claLits this2 + + preprocess :: IO () + preprocess = do + !l0 <- readLitArray a 0 + !l1 <- readLitArray a 1 + assert (l0==falsifiedLit || l1==falsifiedLit) $ return () + when (l0==falsifiedLit) $ do + writeLitArray a 0 l1 + writeLitArray a 1 l0 + + constrReasonOf _ this l = do + lits <- getLits (claLits this) + case l of + Nothing -> return lits + Just lit -> do + assert (lit == head lits) $ return () + return $ tail lits + + constrOnUnassigned _solver _this _this2 _lit = return () + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + lits <- getLits (claLits this) + return ([(1,l) | l <- lits], 1) + + isSatisfied solver this = do + n <- getLitArraySize (claLits this) + liftM isLeft $ runExceptT $ forLoop 0 ( do + v <- lift $ litValue solver =<< readLitArray (claLits this) i + when (v == lTrue) $ throwE () + + constrIsProtected _ this = do + size <- claGetSize this + return $! size <= 2 + + constrReadActivity this = readIORef (claActivity this) + + constrWriteActivity this aval = writeIORef (claActivity this) $! aval + +basicAttachClauseHandler :: Solver -> ClauseHandler -> IO Bool +basicAttachClauseHandler solver this = do + let constr = toConstraintHandler this + lits <- getLits (claLits this) + case lits of + [] -> do + markBad solver + return False + [l1] -> do + assignBy solver l1 constr + l1:l2:_ -> do + watchLit solver l1 constr + watchLit solver l2 constr + return True + +{-------------------------------------------------------------------- + Cardinality Constraint +--------------------------------------------------------------------} + +data AtLeastHandler + = AtLeastHandler + { atLeastLits :: !LitArray + , atLeastNum :: !Int + , atLeastActivity :: !(IORef Double) + , atLeastHash :: !Int + } + +instance Eq AtLeastHandler where + (==) = (==) `on` atLeastLits + +instance Hashable AtLeastHandler where + hash = atLeastHash + hashWithSalt = defaultHashWithSalt + +newAtLeastHandler :: [Lit] -> Int -> Bool -> IO AtLeastHandler +newAtLeastHandler ls n learnt = do + a <- newLitArray ls + act <- newIORef $! (if learnt then 0 else -1) + return (AtLeastHandler a n act (hash (ls,n))) + +instance ConstraintHandler AtLeastHandler where + toConstraintHandler = CHAtLeast + + showConstraintHandler this = do + lits <- getLits (atLeastLits this) + return $ show lits ++ " >= " ++ show (atLeastNum this) + + -- FIXME: simplify implementation + constrAttach solver this this2 = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + let a = atLeastLits this2 + m <- getLitArraySize a + let n = atLeastNum this2 + + if m < n then do + markBad solver + return False + else if m == n then do + let f i = do + lit <- readLitArray a i + assignBy solver lit this + allM f [0..n-1] + else do -- m > n + let f !i !j + | i == n = do + -- NOT VIOLATED: n literals (0 .. n-1) are watched + k <- findForWatch solver a j (m - 1) + if k /= -1 then do + -- NOT UNIT + lit_n <- readLitArray a n + lit_k <- readLitArray a k + writeLitArray a n lit_k + writeLitArray a k lit_n + watchLit solver lit_k this + -- n+1 literals (0 .. n) are watched. + else do + -- UNIT + forLoop 0 ( do + lit <- readLitArray a l + _ <- assignBy solver lit this -- should always succeed + return () + -- We need to watch the most recently falsified literal + (l,_) <- liftM (maximumBy (comparing snd)) $ forM [n..m-1] $ \l -> do + lit <- readLitArray a l + lv <- litLevel solver lit + when debugMode $ do + val <- litValue solver lit + unless (val == lFalse) $ error "AtLeastHandler.attach: should not happen" + return (l,lv) + lit_n <- readLitArray a n + lit_l <- readLitArray a l + writeLitArray a n lit_l + writeLitArray a l lit_n + watchLit solver lit_l this + -- n+1 literals (0 .. n) are watched. + return True + | otherwise = do + assert (i < n && n <= j) $ return () + lit_i <- readLitArray a i + val_i <- litValue solver lit_i + if val_i /= lFalse then do + watchLit solver lit_i this + f (i+1) j + else do + k <- findForWatch solver a j (m - 1) + if k /= -1 then do + lit_k <- readLitArray a k + writeLitArray a i lit_k + writeLitArray a k lit_i + watchLit solver lit_k this + f (i+1) (k+1) + else do + -- CONFLICT + -- We need to watch unassigned literals or most recently falsified literals. + do xs <- liftM (sortBy (flip (comparing snd))) $ forM [i..m-1] $ \l -> do + lit <- readLitArray a l + val <- litValue solver lit + if val == lFalse then do + lv <- litLevel solver lit + return (lit, lv) + else do + return (lit, maxBound) + forM_ (zip [i..m-1] xs) $ \(l,(lit,_lv)) -> do + writeLitArray a l lit + forLoop i (<=n) (+1) $ \l -> do + lit_l <- readLitArray a l + watchLit solver lit_l this + -- n+1 literals (0 .. n) are watched. + return False + f 0 n + + constrDetach solver this this2 = do + lits <- getLits (atLeastLits this2) + let n = atLeastNum this2 + when (length lits > n) $ do + forLoop 0 (<=n) (+1) $ \i -> do + lit <- readLitArray (atLeastLits this2) i + unwatchLit solver lit this + + constrIsLocked solver this this2 = do + size <- getLitArraySize (atLeastLits this2) + let n = atLeastNum this2 + loop i + | i > n = return False + | otherwise = do + l <- readLitArray (atLeastLits this2) i + b <- isReasonOf solver this l + if b then return True else loop (i+1) + if size >= n+1 then + loop 0 + else + return False + + constrPropagate solver this this2 falsifiedLit = do + preprocess + + when debugMode $ do + litn <- readLitArray a n + unless (litn == falsifiedLit) $ error "AtLeastHandler.constrPropagate: should not happen" + + m <- getLitArraySize a + i <- findForWatch solver a (n+1) (m-1) + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "constrPropagate: %s is unit" str + watchLit solver falsifiedLit this + let loop :: Int -> IO Bool + loop j + | j >= n = return True + | otherwise = do + litj <- readLitArray a j + ret2 <- assignBy solver litj this + if ret2 + then loop (j+1) + else return False + loop 0 + _ -> do + liti <- readLitArray a i + litn <- readLitArray a n + writeLitArray a i litn + writeLitArray a n liti + watchLit solver liti this + return True + + where + a = atLeastLits this2 + n = atLeastNum this2 + + preprocess :: IO () + preprocess = loop 0 + where + loop :: Int -> IO () + loop i + | i >= n = return () + | otherwise = do + li <- readLitArray a i + if (li /= falsifiedLit) then + loop (i+1) + else do + ln <- readLitArray a n + writeLitArray a n li + writeLitArray a i ln + + constrReasonOf solver this concl = do + m <- getLitArraySize (atLeastLits this) + let n = atLeastNum this + falsifiedLits <- mapM (readLitArray (atLeastLits this)) [n..m-1] -- drop first n elements + when debugMode $ do + forM_ falsifiedLits $ \lit -> do + val <- litValue solver lit + unless (val == lFalse) $ do + error $ printf "AtLeastHandler.constrReasonOf: %d is %s (lFalse expected)" lit (show val) + case concl of + Nothing -> do + let go :: Int -> IO Lit + go i + | i >= n = error $ printf "AtLeastHandler.constrReasonOf: cannot find falsified literal in first %d elements" n + | otherwise = do + lit <- readLitArray (atLeastLits this) i + val <- litValue solver lit + if val == lFalse + then return lit + else go (i+1) + lit <- go 0 + return $ lit : falsifiedLits + Just lit -> do + when debugMode $ do + es <- getLits (atLeastLits this) + unless (lit `elem` take n es) $ + error $ printf "AtLeastHandler.constrReasonOf: cannot find %d in first %d elements" n + return falsifiedLits + + constrOnUnassigned _solver _this _this2 _lit = return () + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + lits <- getLits (atLeastLits this) + return ([(1,l) | l <- lits], fromIntegral (atLeastNum this)) + + isSatisfied solver this = do + m <- getLitArraySize (atLeastLits this) + liftM isLeft $ runExceptT $ numLoopState 0 (m-1) 0 $ \(!n) i -> do + v <- lift $ litValue solver =<< readLitArray (atLeastLits this) i + if v /= lTrue then do + return n + else do + let n' = n + 1 + when (n' >= atLeastNum this) $ throwE () + return n' + + constrReadActivity this = readIORef (atLeastActivity this) + + constrWriteActivity this aval = writeIORef (atLeastActivity this) $! aval + +basicAttachAtLeastHandler :: Solver -> AtLeastHandler -> IO Bool +basicAttachAtLeastHandler solver this = do + lits <- getLits (atLeastLits this) + let m = length lits + n = atLeastNum this + constr = toConstraintHandler this + if m < n then do + markBad solver + return False + else if m == n then do + allM (\l -> assignBy solver l constr) lits + else do -- m > n + forM_ (take (n+1) lits) $ \l -> watchLit solver l constr + return True + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint +--------------------------------------------------------------------} + +newPBHandler :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler +newPBHandler solver ts degree learnt = do + config <- configPBHandlerType <$> getConfig solver + case config of + PBHandlerTypeCounter -> do + c <- newPBHandlerCounter ts degree learnt + return (toConstraintHandler c) + PBHandlerTypePueblo -> do + c <- newPBHandlerPueblo ts degree learnt + return (toConstraintHandler c) + +newPBHandlerPromoted :: Solver -> PBLinSum -> Integer -> Bool -> IO SomeConstraintHandler +newPBHandlerPromoted solver lhs rhs learnt = do + case pbToAtLeast (lhs,rhs) of + Nothing -> newPBHandler solver lhs rhs learnt + Just (lhs2, rhs2) -> do + if rhs2 /= 1 then do + h <- newAtLeastHandler lhs2 rhs2 learnt + return $ toConstraintHandler h + else do + h <- newClauseHandler lhs2 learnt + return $ toConstraintHandler h + +pbOverSAT :: Solver -> PBLinAtLeast -> IO Bool +pbOverSAT solver (lhs, rhs) = do + ss <- forM lhs $ \(c,l) -> do + v <- litValue solver l + if v /= lFalse + then return c + else return 0 + return $! sum ss > rhs + +pbToAtLeast :: PBLinAtLeast -> Maybe AtLeast +pbToAtLeast (lhs, rhs) = do + let cs = [c | (c,_) <- lhs] + guard $ Set.size (Set.fromList cs) == 1 + let c = head cs + return $ (map snd lhs, fromInteger ((rhs+c-1) `div` c)) + +pbToClause :: PBLinAtLeast -> Maybe Clause +pbToClause pb = do + (lhs, rhs) <- pbToAtLeast pb + guard $ rhs == 1 + return lhs + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint (Counter) +--------------------------------------------------------------------} + +data PBHandlerCounter + = PBHandlerCounter + { pbTerms :: !PBLinSum -- sorted in the decending order on coefficients. + , pbDegree :: !Integer + , pbCoeffMap :: !(LitMap Integer) + , pbMaxSlack :: !Integer + , pbSlack :: !(IORef Integer) + , pbActivity :: !(IORef Double) + , pbHash :: !Int + } + +instance Eq PBHandlerCounter where + (==) = (==) `on` pbSlack + +instance Hashable PBHandlerCounter where + hash = pbHash + hashWithSalt = defaultHashWithSalt + +newPBHandlerCounter :: PBLinSum -> Integer -> Bool -> IO PBHandlerCounter +newPBHandlerCounter ts degree learnt = do + let ts' = sortBy (flip compare `on` fst) ts + slack = sum (map fst ts) - degree + m = IM.fromList [(l,c) | (c,l) <- ts] + s <- newIORef slack + act <- newIORef $! (if learnt then 0 else -1) + return (PBHandlerCounter ts' degree m slack s act (hash (ts,degree))) + +instance ConstraintHandler PBHandlerCounter where + toConstraintHandler = CHPBCounter + + showConstraintHandler this = do + return $ show (pbTerms this) ++ " >= " ++ show (pbDegree this) + + constrAttach solver this this2 = do + -- BCP queue should be empty at this point. + -- It is important for calculating slack. + bcpCheckEmpty solver + s <- liftM sum $ forM (pbTerms this2) $ \(c,l) -> do + watchLit solver l this + val <- litValue solver l + if val == lFalse then do + addOnUnassigned solver this l + return 0 + else do + return c + let slack = s - pbDegree this2 + writeIORef (pbSlack this2) $! slack + if slack < 0 then + return False + else do + flip allM (pbTerms this2) $ \(c,l) -> do + val <- litValue solver l + if c > slack && val == lUndef then do + assignBy solver l this + else + return True + + constrDetach solver this this2 = do + forM_ (pbTerms this2) $ \(_,l) -> do + unwatchLit solver l this + + constrIsLocked solver this this2 = do + anyM (\(_,l) -> isReasonOf solver this l) (pbTerms this2) + + constrPropagate solver this this2 falsifiedLit = do + watchLit solver falsifiedLit this + let c = pbCoeffMap this2 IM.! falsifiedLit + modifyIORef' (pbSlack this2) (subtract c) + addOnUnassigned solver this falsifiedLit + s <- readIORef (pbSlack this2) + if s < 0 then + return False + else do + forM_ (takeWhile (\(c1,_) -> c1 > s) (pbTerms this2)) $ \(_,l1) -> do + v <- litValue solver l1 + when (v == lUndef) $ do + assignBy solver l1 this + return () + return True + + constrReasonOf solver this l = do + case l of + Nothing -> do + let p _ = return True + f p (pbMaxSlack this) (pbTerms this) + Just lit -> do + idx <- varAssignNo solver (litVar lit) + -- PB制約の場合には複数回unitになる可能性があり、 + -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 + let p lit2 =do + idx2 <- varAssignNo solver (litVar lit2) + return $ idx2 < idx + let c = pbCoeffMap this IM.! lit + f p (pbMaxSlack this - c) (pbTerms this) + where + {-# INLINE f #-} + f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] + f p s xs = go s xs [] + where + go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] + go s _ ret | s < 0 = return ret + go _ [] _ = error "PBHandlerCounter.constrReasonOf: should not happen" + go s ((c,lit):xs) ret = do + val <- litValue solver lit + if val == lFalse then do + b <- p lit + if b + then go (s - c) xs (lit:ret) + else go s xs ret + else do + go s xs ret + + constrOnUnassigned _solver _this this2 lit = do + let c = pbCoeffMap this2 IM.! (- lit) + modifyIORef' (pbSlack this2) (+ c) + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + return (pbTerms this, pbDegree this) + + isSatisfied solver this = do + xs <- forM (pbTerms this) $ \(c,l) -> do + v <- litValue solver l + if v == lTrue + then return c + else return 0 + return $ sum xs >= pbDegree this + + constrWeight _ _ = return 0.5 + + constrReadActivity this = readIORef (pbActivity this) + + constrWriteActivity this aval = writeIORef (pbActivity this) $! aval + +{-------------------------------------------------------------------- + Pseudo Boolean Constraint (Pueblo) +--------------------------------------------------------------------} + +data PBHandlerPueblo + = PBHandlerPueblo + { puebloTerms :: !PBLinSum + , puebloDegree :: !Integer + , puebloMaxSlack :: !Integer + , puebloWatches :: !(IORef LitSet) + , puebloWatchSum :: !(IORef Integer) + , puebloActivity :: !(IORef Double) + , puebloHash :: !Int + } + +instance Eq PBHandlerPueblo where + (==) = (==) `on` puebloWatchSum + +instance Hashable PBHandlerPueblo where + hash = puebloHash + hashWithSalt = defaultHashWithSalt + +puebloAMax :: PBHandlerPueblo -> Integer +puebloAMax this = + case puebloTerms this of + (c,_):_ -> c + [] -> 0 -- should not happen? + +newPBHandlerPueblo :: PBLinSum -> Integer -> Bool -> IO PBHandlerPueblo +newPBHandlerPueblo ts degree learnt = do + let ts' = sortBy (flip compare `on` fst) ts + slack = sum [c | (c,_) <- ts'] - degree + ws <- newIORef IS.empty + wsum <- newIORef 0 + act <- newIORef $! (if learnt then 0 else -1) + return $ PBHandlerPueblo ts' degree slack ws wsum act (hash (ts,degree)) + +puebloGetWatchSum :: PBHandlerPueblo -> IO Integer +puebloGetWatchSum pb = readIORef (puebloWatchSum pb) + +puebloWatch :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> PBLinTerm -> IO () +puebloWatch solver constr !pb (c, lit) = do + watchLit solver lit constr + modifyIORef' (puebloWatches pb) (IS.insert lit) + modifyIORef' (puebloWatchSum pb) (+c) + +puebloUnwatch :: Solver -> PBHandlerPueblo -> PBLinTerm -> IO () +puebloUnwatch _solver pb (c, lit) = do + modifyIORef' (puebloWatches pb) (IS.delete lit) + modifyIORef' (puebloWatchSum pb) (subtract c) + +instance ConstraintHandler PBHandlerPueblo where + toConstraintHandler = CHPBPueblo + + showConstraintHandler this = do + return $ show (puebloTerms this) ++ " >= " ++ show (puebloDegree this) + + constrAttach solver this this2 = do + bcpCheckEmpty solver + ret <- puebloPropagate solver this this2 + + -- register to watch recently falsified literals to recover + -- "WatchSum >= puebloDegree this + puebloAMax this" when backtrack is performed. + wsum <- puebloGetWatchSum this2 + unless (wsum >= puebloDegree this2 + puebloAMax this2) $ do + let f m tm@(_,lit) = do + val <- litValue solver lit + if val == lFalse then do + idx <- varAssignNo solver (litVar lit) + return (IM.insert idx tm m) + else + return m + xs <- liftM (map snd . IM.toDescList) $ foldM f IM.empty (puebloTerms this2) + let g !_ [] = return () + g !s ((c,l):ts) = do + addOnUnassigned solver this l + if s+c >= puebloDegree this2 + puebloAMax this2 then return () + else g (s+c) ts + g wsum xs + + return ret + + constrDetach solver this this2 = do + ws <- readIORef (puebloWatches this2) + forM_ (IS.toList ws) $ \l -> do + unwatchLit solver l this + + constrIsLocked solver this this2 = do + anyM (\(_,l) -> isReasonOf solver this l) (puebloTerms this2) + + constrPropagate solver this this2 falsifiedLit = do + let t = fromJust $ find (\(_,l) -> l==falsifiedLit) (puebloTerms this2) + puebloUnwatch solver this2 t + ret <- puebloPropagate solver this this2 + wsum <- puebloGetWatchSum this2 + unless (wsum >= puebloDegree this2 + puebloAMax this2) $ + addOnUnassigned solver this falsifiedLit + return ret + + constrReasonOf solver this l = do + case l of + Nothing -> do + let p _ = return True + f p (puebloMaxSlack this) (puebloTerms this) + Just lit -> do + idx <- varAssignNo solver (litVar lit) + -- PB制約の場合には複数回unitになる可能性があり、 + -- litへの伝播以降に割り当てられたリテラルを含まないよう注意が必要 + let p lit2 =do + idx2 <- varAssignNo solver (litVar lit2) + return $ idx2 < idx + let c = fst $ fromJust $ find (\(_,l) -> l == lit) (puebloTerms this) + f p (puebloMaxSlack this - c) (puebloTerms this) + where + {-# INLINE f #-} + f :: (Lit -> IO Bool) -> Integer -> PBLinSum -> IO [Lit] + f p s xs = go s xs [] + where + go :: Integer -> PBLinSum -> [Lit] -> IO [Lit] + go s _ ret | s < 0 = return ret + go _ [] _ = error "PBHandlerPueblo.constrReasonOf: should not happen" + go s ((c,lit):xs) ret = do + val <- litValue solver lit + if val == lFalse then do + b <- p lit + if b + then go (s - c) xs (lit:ret) + else go s xs ret + else do + go s xs ret + + constrOnUnassigned solver this this2 lit = do + let t = fromJust $ find (\(_,l) -> l == - lit) (puebloTerms this2) + puebloWatch solver this this2 t + + isPBRepresentable _ = return True + + toPBLinAtLeast this = do + return (puebloTerms this, puebloDegree this) + + isSatisfied solver this = do + xs <- forM (puebloTerms this) $ \(c,l) -> do + v <- litValue solver l + if v == lTrue + then return c + else return 0 + return $ sum xs >= puebloDegree this + + constrWeight _ _ = return 0.5 + + constrReadActivity this = readIORef (puebloActivity this) + + constrWriteActivity this aval = writeIORef (puebloActivity this) $! aval + +puebloPropagate :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO Bool +puebloPropagate solver constr this = do + puebloUpdateWatchSum solver constr this + watchsum <- puebloGetWatchSum this + if puebloDegree this + puebloAMax this <= watchsum then + return True + else if watchsum < puebloDegree this then do + -- CONFLICT + return False + else do -- puebloDegree this <= watchsum < puebloDegree this + puebloAMax this + -- UNIT PROPAGATION + let f [] = return True + f ((c,lit) : ts) = do + watchsum' <- puebloGetWatchSum this + if watchsum' - c >= puebloDegree this then + return True + else do + val <- litValue solver lit + when (val == lUndef) $ do + b <- assignBy solver lit constr + assert b $ return () + f ts + f $ puebloTerms this + +puebloUpdateWatchSum :: Solver -> SomeConstraintHandler -> PBHandlerPueblo -> IO () +puebloUpdateWatchSum solver constr this = do + let f [] = return () + f (t@(_,lit):ts) = do + watchSum <- puebloGetWatchSum this + if watchSum >= puebloDegree this + puebloAMax this then + return () + else do + val <- litValue solver lit + watched <- liftM (lit `IS.member`) $ readIORef (puebloWatches this) + when (val /= lFalse && not watched) $ do + puebloWatch solver constr this t + f ts + f (puebloTerms this) + +{-------------------------------------------------------------------- + XOR Clause +--------------------------------------------------------------------} + +data XORClauseHandler + = XORClauseHandler + { xorLits :: !LitArray + , xorActivity :: !(IORef Double) + , xorHash :: !Int + } + +instance Eq XORClauseHandler where + (==) = (==) `on` xorLits + +instance Hashable XORClauseHandler where + hash = xorHash + hashWithSalt = defaultHashWithSalt + +newXORClauseHandler :: [Lit] -> Bool -> IO XORClauseHandler +newXORClauseHandler ls learnt = do + a <- newLitArray ls + act <- newIORef $! (if learnt then 0 else -1) + return (XORClauseHandler a act (hash ls)) + +instance ConstraintHandler XORClauseHandler where + toConstraintHandler = CHXORClause + + showConstraintHandler this = do + lits <- getLits (xorLits this) + return ("XOR " ++ show lits) + + constrAttach solver this this2 = do + -- BCP Queue should be empty at this point. + -- If not, duplicated propagation happens. + bcpCheckEmpty solver + + let a = xorLits this2 + size <- getLitArraySize a + + if size == 0 then do + markBad solver + return False + else if size == 1 then do + lit0 <- readLitArray a 0 + assignBy solver lit0 this + else do + ref <- newIORef 1 + let f i = do + lit_i <- readLitArray a i + val_i <- litValue solver lit_i + if val_i == lUndef then + return True + else do + j <- readIORef ref + k <- findForWatch2 solver a j (size - 1) + case k of + -1 -> do + return False + _ -> do + lit_k <- readLitArray a k + writeLitArray a i lit_k + writeLitArray a k lit_i + writeIORef ref $! (k+1) + return True + + b <- f 0 + if b then do + lit0 <- readLitArray a 0 + watchVar solver (litVar lit0) this + b2 <- f 1 + if b2 then do + lit1 <- readLitArray a 1 + watchVar solver (litVar lit1) this + return True + else do -- UNIT + -- We need to watch the most recently falsified literal + (i,_) <- liftM (maximumBy (comparing snd)) $ forM [1..size-1] $ \l -> do + lit <- readLitArray a l + lv <- litLevel solver lit + return (l,lv) + lit1 <- readLitArray a 1 + liti <- readLitArray a i + writeLitArray a 1 liti + writeLitArray a i lit1 + watchVar solver (litVar liti) this + -- lit0 ⊕ y + y <- do + ref' <- newIORef False + forLoop 1 ( do + lit_j <- readLitArray a j + val_j <- litValue solver lit_j + modifyIORef' ref' (/= fromJust (unliftBool val_j)) + readIORef ref' + assignBy solver (if y then litNot lit0 else lit0) this -- should always succeed + else do + ls <- liftM (map fst . sortBy (flip (comparing snd))) $ forM [0..size-1] $ \l -> do + lit <- readLitArray a l + lv <- litLevel solver lit + return (l,lv) + forM_ (zip [0..] ls) $ \(i,lit) -> do + writeLitArray a i lit + lit0 <- readLitArray a 0 + lit1 <- readLitArray a 1 + watchVar solver (litVar lit0) this + watchVar solver (litVar lit1) this + isSatisfied solver this2 + + constrDetach solver this this2 = do + size <- getLitArraySize (xorLits this2) + when (size >= 2) $ do + lit0 <- readLitArray (xorLits this2) 0 + lit1 <- readLitArray (xorLits this2) 1 + unwatchVar solver (litVar lit0) this + unwatchVar solver (litVar lit1) this + + constrIsLocked solver this this2 = do + lit0 <- readLitArray (xorLits this2) 0 + lit1 <- readLitArray (xorLits this2) 1 + b0 <- isReasonOf solver this lit0 + b1 <- isReasonOf solver this lit1 + return $ b0 || b1 + + constrPropagate !solver this this2 !falsifiedLit = do + b <- constrIsLocked solver this this2 + if b then + return True + else do + preprocess + + !lit0 <- readLitArray a 0 + !size <- getLitArraySize (xorLits this2) + i <- findForWatch2 solver a 2 (size - 1) + case i of + -1 -> do + when debugMode $ logIO solver $ do + str <- showConstraintHandler this + return $ printf "constrPropagate: %s is unit" str + watchVar solver v this + -- lit0 ⊕ y + y <- do + ref <- newIORef False + forLoop 1 ( do + lit_j <- readLitArray a j + val_j <- litValue solver lit_j + modifyIORef' ref (/= fromJust (unliftBool val_j)) + readIORef ref + assignBy solver (if y then litNot lit0 else lit0) this + _ -> do + !lit1 <- readLitArray a 1 + !liti <- readLitArray a i + writeLitArray a 1 liti + writeLitArray a i lit1 + watchVar solver (litVar liti) this + return True + + where + v = litVar falsifiedLit + a = xorLits this2 + + preprocess :: IO () + preprocess = do + !l0 <- readLitArray a 0 + !l1 <- readLitArray a 1 + assert (litVar l0 == v || litVar l1 == v) $ return () + when (litVar l0 == v) $ do + writeLitArray a 0 l1 + writeLitArray a 1 l0 + + constrReasonOf solver this l = do + lits <- getLits (xorLits this) + xs <- + case l of + Nothing -> mapM f lits + Just lit -> do + case lits of + l1:ls -> do + assert (litVar lit == litVar l1) $ return () + mapM f ls + _ -> error "XORClauseHandler.constrReasonOf: should not happen" + return xs + where + f :: Lit -> IO Lit + f lit = do + let v = litVar lit + val <- varValue solver v + return $ literal v (not (fromJust (unliftBool val))) + + constrOnUnassigned _solver _this _this2 _lit = return () + + isPBRepresentable _ = return False + + toPBLinAtLeast _ = error "XORClauseHandler does not support toPBLinAtLeast" + + isSatisfied solver this = do + lits <- getLits (xorLits this) + vals <- mapM (litValue solver) lits + let f x y + | x == lUndef || y == lUndef = lUndef + | otherwise = liftBool (x /= y) + return $ foldl' f lFalse vals == lTrue + + constrIsProtected _ this = do + size <- getLitArraySize (xorLits this) + return $! size <= 2 + + constrReadActivity this = readIORef (xorActivity this) + + constrWriteActivity this aval = writeIORef (xorActivity this) $! aval + +basicAttachXORClauseHandler :: Solver -> XORClauseHandler -> IO Bool +basicAttachXORClauseHandler solver this = do + lits <- getLits (xorLits this) + let constr = toConstraintHandler this + case lits of + [] -> do + markBad solver + return False + [l1] -> do + assignBy solver l1 constr + l1:l2:_ -> do + watchVar solver (litVar l1) constr + watchVar solver (litVar l2) constr + return True + +{-------------------------------------------------------------------- + Arbitrary Boolean Theory +--------------------------------------------------------------------} + +setTheory :: Solver -> TheorySolver -> IO () +setTheory solver tsolver = do + d <- getDecisionLevel solver + assert (d == levelRoot) $ return () + + m <- readIORef (svTheorySolver solver) + case m of + Just _ -> do + error $ "ToySolver.SAT.setTheory: cannot replace TheorySolver" + Nothing -> do + writeIORef (svTheorySolver solver) (Just tsolver) + ret <- deduce solver + case ret of + Nothing -> return () + Just _ -> markBad solver + +getTheory :: Solver -> IO (Maybe TheorySolver) +getTheory solver = readIORef (svTheorySolver solver) + +deduceT :: Solver -> ExceptT SomeConstraintHandler IO () +deduceT solver = do + mt <- liftIO $ readIORef (svTheorySolver solver) + case mt of + Nothing -> return () + Just t -> do + n <- liftIO $ Vec.getSize (svTrail solver) + let h = CHTheory TheoryHandler + callback l = assignBy solver l h + loop i = do + when (i < n) $ do + l <- liftIO $ Vec.unsafeRead (svTrail solver) i + ok <- liftIO $ thAssertLit t callback l + if ok then + loop (i+1) + else + throwE h + loop =<< liftIO (readIOURef (svTheoryChecked solver)) + b2 <- liftIO $ thCheck t callback + if b2 then do + liftIO $ writeIOURef (svTheoryChecked solver) n + else + throwE h + +data TheoryHandler = TheoryHandler deriving (Eq) + +instance Hashable TheoryHandler where + hash _ = hash () + hashWithSalt = defaultHashWithSalt + +instance ConstraintHandler TheoryHandler where + toConstraintHandler = CHTheory + + showConstraintHandler _this = return "TheoryHandler" + + constrAttach _solver _this _this2 = error "TheoryHandler.constrAttach" + + constrDetach _solver _this _this2 = return () + + constrIsLocked _solver _this _this2 = return True + + constrPropagate _solver _this _this2 _falsifiedLit = error "TheoryHandler.constrPropagate" + + constrReasonOf solver _this l = do + Just t <- readIORef (svTheorySolver solver) + lits <- thExplain t l + return $ [-lit | lit <- lits] + + constrOnUnassigned _solver _this _this2 _lit = return () + + isPBRepresentable _this = return False + + toPBLinAtLeast _this = error "TheoryHandler.toPBLinAtLeast" + + isSatisfied _solver _this = error "TheoryHandler.isSatisfied" + + constrIsProtected _solver _this = error "TheoryHandler.constrIsProtected" + + constrReadActivity _this = return 0 + + constrWriteActivity _this _aval = return () + +{-------------------------------------------------------------------- + Restart strategy +--------------------------------------------------------------------} + +mkRestartSeq :: RestartStrategy -> Int -> Double -> [Int] +mkRestartSeq MiniSATRestarts = miniSatRestartSeq +mkRestartSeq ArminRestarts = arminRestartSeq +mkRestartSeq LubyRestarts = lubyRestartSeq + +miniSatRestartSeq :: Int -> Double -> [Int] +miniSatRestartSeq start inc = iterate (ceiling . (inc *) . fromIntegral) start + +{- +miniSatRestartSeq :: Int -> Double -> [Int] +miniSatRestartSeq start inc = map round $ iterate (inc*) (fromIntegral start) +-} + +arminRestartSeq :: Int -> Double -> [Int] +arminRestartSeq start inc = go (fromIntegral start) (fromIntegral start) + where + go !inner !outer = round inner : go inner' outer' + where + (inner',outer') = + if inner >= outer + then (fromIntegral start, outer * inc) + else (inner * inc, outer) + +lubyRestartSeq :: Int -> Double -> [Int] +lubyRestartSeq start inc = map (ceiling . (fromIntegral start *) . luby inc) [0..] + +{- + Finite subsequences of the Luby-sequence: + + 0: 1 + 1: 1 1 2 + 2: 1 1 2 1 1 2 4 + 3: 1 1 2 1 1 2 4 1 1 2 1 1 2 4 8 + ... + + +-} +luby :: Double -> Integer -> Double +luby y x = go2 size1 sequ1 x + where + -- Find the finite subsequence that contains index 'x', and the + -- size of that subsequence: + (size1, sequ1) = go 1 0 + + go :: Integer -> Integer -> (Integer, Integer) + go size sequ + | size < x+1 = go (2*size+1) (sequ+1) + | otherwise = (size, sequ) + + go2 :: Integer -> Integer -> Integer -> Double + go2 size sequ x2 + | size-1 /= x2 = let size' = (size-1) `div` 2 in go2 size' (sequ - 1) (x2 `mod` size') + | otherwise = y ^ sequ + + +{-------------------------------------------------------------------- + utility +--------------------------------------------------------------------} + +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM p = go + where + go [] = return True + go (x:xs) = do + b <- p x + if b + then go xs + else return False + +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM p = go + where + go [] = return False + go (x:xs) = do + b <- p x + if b + then return True + else go xs + +shift :: IORef [a] -> IO a +shift ref = do + (x:xs) <- readIORef ref + writeIORef ref xs + return x + +defaultHashWithSalt :: Hashable a => Int -> a -> Int +defaultHashWithSalt salt x = salt `combine` hash x + where + combine :: Int -> Int -> Int + combine h1 h2 = (h1 * 16777619) `xor` h2 + +{-------------------------------------------------------------------- + debug +--------------------------------------------------------------------} + +debugMode :: Bool +debugMode = False + +checkSatisfied :: Solver -> IO () +checkSatisfied solver = do + cls <- readIORef (svConstrDB solver) + forM_ cls $ \c -> do + b <- isSatisfied solver c + unless b $ do + s <- showConstraintHandler c + log solver $ "BUG: " ++ s ++ " is violated" + +dumpVarActivity :: Solver -> IO () +dumpVarActivity solver = do + log solver "Variable activity:" + vs <- variables solver + forM_ vs $ \v -> do + activity <- varActivity solver v + log solver $ printf "activity(%d) = %d" v activity + +dumpConstrActivity :: Solver -> IO () +dumpConstrActivity solver = do + log solver "Learnt constraints activity:" + xs <- learntConstraints solver + forM_ xs $ \c -> do + s <- showConstraintHandler c + aval <- constrReadActivity c + log solver $ printf "activity(%s) = %f" s aval + +-- | set callback function for receiving messages. +setLogger :: Solver -> (String -> IO ()) -> IO () +setLogger solver logger = do + writeIORef (svLogger solver) (Just logger) + +-- | Clear logger function set by 'setLogger'. +clearLogger :: Solver -> IO () +clearLogger solver = do + writeIORef (svLogger solver) Nothing + +log :: Solver -> String -> IO () +log solver msg = logIO solver (return msg) + +logIO :: Solver -> IO String -> IO () +logIO solver action = do + m <- readIORef (svLogger solver) + case m of + Nothing -> return () + Just logger -> action >>= logger diff --git a/src/ToySolver/SAT/Solver/CDCL/Config.hs b/src/ToySolver/SAT/Solver/CDCL/Config.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/CDCL/Config.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.CDCL.Config +-- Copyright : (c) Masahiro Sakai 2017 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.Solver.CDCL.Config + ( -- * Solver configulation + Config (..) + , RestartStrategy (..) + , showRestartStrategy + , parseRestartStrategy + , LearningStrategy (..) + , showLearningStrategy + , parseLearningStrategy + , BranchingStrategy (..) + , showBranchingStrategy + , parseBranchingStrategy + , PBHandlerType (..) + , showPBHandlerType + , parsePBHandlerType + ) where + +import Data.Char +import Data.Default.Class + +data Config + = Config + { configRestartStrategy :: !RestartStrategy + , configRestartFirst :: !Int + -- ^ The initial restart limit. (default 100) + -- Zero and negative values are used to disable restart. + , configRestartInc :: !Double + -- ^ The factor with which the restart limit is multiplied in each restart. (default 1.5) + -- This must be @>1@. + , configLearningStrategy :: !LearningStrategy + , configLearntSizeFirst :: !Int + -- ^ The initial limit for learnt constraints. + -- Negative value means computing default value from problem instance. + , configLearntSizeInc :: !Double + -- ^ The limit for learnt constraints is multiplied with this factor periodically. (default 1.1) + -- This must be @>1@. + , configCCMin :: !Int + -- ^ Controls conflict constraint minimization (0=none, 1=local, 2=recursive) + , configBranchingStrategy :: !BranchingStrategy + , configERWAStepSizeFirst :: !Double + -- ^ step-size α in ERWA and LRB branching heuristic is initialized with this value. (default 0.4) + , configERWAStepSizeDec :: !Double + -- ^ step-size α in ERWA and LRB branching heuristic is decreased by this value after each conflict. (default 0.06) + , configERWAStepSizeMin :: !Double + -- ^ step-size α in ERWA and LRB branching heuristic is decreased until it reach the value. (default 0.06) + , configEMADecay :: !Double + -- ^ inverse of the variable EMA decay factor used by LRB branching heuristic. (default 1 / 0.95) + , configEnablePhaseSaving :: !Bool + , configEnableForwardSubsumptionRemoval :: !Bool + , configEnableBackwardSubsumptionRemoval :: !Bool + , configRandomFreq :: !Double + -- ^ The frequency with which the decision heuristic tries to choose a random variable + , configPBHandlerType :: !PBHandlerType + , configEnablePBSplitClausePart :: !Bool + -- ^ Split PB-constraints into a PB part and a clause part. + -- + -- Example from minisat+ paper: + -- + -- * 4 x1 + 4 x2 + 4 x3 + 4 x4 + 2y1 + y2 + y3 ≥ 4 + -- + -- would be split into + -- + -- * x1 + x2 + x3 + x4 + ¬z ≥ 1 (clause part) + -- + -- * 2 y1 + y2 + y3 + 4 z ≥ 4 (PB part) + -- + -- where z is a newly introduced variable, not present in any other constraint. + -- + -- Reference: + -- + -- * N . Eéen and N. Sörensson. Translating Pseudo-Boolean Constraints into SAT. JSAT 2:1–26, 2006. + -- + , configCheckModel :: !Bool + , configVarDecay :: !Double + -- ^ Inverse of the variable activity decay factor. (default 1 / 0.95) + , configConstrDecay :: !Double + -- ^ Inverse of the constraint activity decay factor. (1 / 0.999) + } deriving (Show, Eq, Ord) + +instance Default Config where + def = + Config + { configRestartStrategy = def + , configRestartFirst = 100 + , configRestartInc = 1.5 + , configLearningStrategy = def + , configLearntSizeFirst = -1 + , configLearntSizeInc = 1.1 + , configCCMin = 2 + , configBranchingStrategy = def + , configERWAStepSizeFirst = 0.4 + , configERWAStepSizeDec = 10**(-6) + , configERWAStepSizeMin = 0.06 + , configEMADecay = 1 / 0.95 + , configEnablePhaseSaving = True + , configEnableForwardSubsumptionRemoval = False + , configEnableBackwardSubsumptionRemoval = False + , configRandomFreq = 0.005 + , configPBHandlerType = def + , configEnablePBSplitClausePart = False + , configCheckModel = False + , configVarDecay = 1 / 0.95 + , configConstrDecay = 1 / 0.999 + } + +-- | Restart strategy. +-- +-- The default value can be obtained by 'def'. +data RestartStrategy = MiniSATRestarts | ArminRestarts | LubyRestarts + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Default RestartStrategy where + def = MiniSATRestarts + +showRestartStrategy :: RestartStrategy -> String +showRestartStrategy MiniSATRestarts = "minisat" +showRestartStrategy ArminRestarts = "armin" +showRestartStrategy LubyRestarts = "luby" + +parseRestartStrategy :: String -> Maybe RestartStrategy +parseRestartStrategy s = + case map toLower s of + "minisat" -> Just MiniSATRestarts + "armin" -> Just ArminRestarts + "luby" -> Just LubyRestarts + _ -> Nothing + +-- | Learning strategy. +-- +-- The default value can be obtained by 'def'. +data LearningStrategy + = LearningClause + | LearningHybrid + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Default LearningStrategy where + def = LearningClause + +showLearningStrategy :: LearningStrategy -> String +showLearningStrategy LearningClause = "clause" +showLearningStrategy LearningHybrid = "hybrid" + +parseLearningStrategy :: String -> Maybe LearningStrategy +parseLearningStrategy s = + case map toLower s of + "clause" -> Just LearningClause + "hybrid" -> Just LearningHybrid + _ -> Nothing + +-- | Branching strategy. +-- +-- The default value can be obtained by 'def'. +-- +-- 'BranchingERWA' and 'BranchingLRB' is based on [Liang et al 2016]. +-- +-- * J. Liang, V. Ganesh, P. Poupart, and K. Czarnecki, "Learning rate based branching heuristic for SAT solvers," +-- in Proceedings of Theory and Applications of Satisfiability Testing (SAT 2016), pp. 123-140. +-- +-- +data BranchingStrategy + = BranchingVSIDS + -- ^ VSIDS (Variable State Independent Decaying Sum) branching heuristic + | BranchingERWA + -- ^ ERWA (Exponential Recency Weighted Average) branching heuristic + | BranchingLRB + -- ^ LRB (Learning Rate Branching) heuristic + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Default BranchingStrategy where + def = BranchingVSIDS + +showBranchingStrategy :: BranchingStrategy -> String +showBranchingStrategy BranchingVSIDS = "vsids" +showBranchingStrategy BranchingERWA = "erwa" +showBranchingStrategy BranchingLRB = "lrb" + +parseBranchingStrategy :: String -> Maybe BranchingStrategy +parseBranchingStrategy s = + case map toLower s of + "vsids" -> Just BranchingVSIDS + "erwa" -> Just BranchingERWA + "lrb" -> Just BranchingLRB + _ -> Nothing + +-- | Pseudo boolean constraint handler implimentation. +-- +-- The default value can be obtained by 'def'. +data PBHandlerType = PBHandlerTypeCounter | PBHandlerTypePueblo + deriving (Show, Eq, Ord, Enum, Bounded) + +instance Default PBHandlerType where + def = PBHandlerTypeCounter + +showPBHandlerType :: PBHandlerType -> String +showPBHandlerType PBHandlerTypeCounter = "counter" +showPBHandlerType PBHandlerTypePueblo = "pueblo" + +parsePBHandlerType :: String -> Maybe PBHandlerType +parsePBHandlerType s = + case map toLower s of + "counter" -> Just PBHandlerTypeCounter + "pueblo" -> Just PBHandlerTypePueblo + _ -> Nothing diff --git a/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation.hs b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation.hs @@ -0,0 +1,471 @@ +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.MessagePassing.SurveyPropagation +-- Copyright : (c) Masahiro Sakai 2016 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- References: +-- +-- * Alfredo Braunstein, Marc Mézard and Riccardo Zecchina. +-- Survey Propagation: An Algorithm for Satisfiability, +-- +-- +-- * Corrie Scalisi. Visualizing Survey Propagation in 3-SAT Factor Graphs, +-- . +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.Solver.MessagePassing.SurveyPropagation + ( + -- * The Solver type + Solver + , newSolver + , deleteSolver + + -- * Problem information + , getNVars + , getNConstraints + + -- * Parameters + , getTolerance + , setTolerance + , getIterationLimit + , setIterationLimit + , getNThreads + , setNThreads + + -- * Computing marginal distributions + , initializeRandom + , initializeRandomDirichlet + , propagate + , getVarProb + + -- * Solving + , fixLit + , unfixLit + + -- * Debugging + , printInfo + ) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Loop +import Control.Monad +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import Data.IORef +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Unboxed.Mutable as VUM +import Data.Vector.Generic ((!)) +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import Numeric +import qualified Numeric.Log as L +import qualified System.Random.MWC as Rand +import qualified System.Random.MWC.Distributions as Rand + +import qualified ToySolver.SAT.Types as SAT + +infixr 8 ^* + +(^*) :: Num a => L.Log a -> a -> L.Log a +L.Exp a ^* b = L.Exp (a*b) + +comp :: RealFloat a => L.Log a -> L.Log a +comp (L.Exp a) = L.Exp $ log1p $ max (-1) $ negate (exp a) + +type ClauseIndex = Int +type EdgeIndex = Int + +data Solver + = Solver + { svVarEdges :: !(V.Vector (VU.Vector EdgeIndex)) + , svVarProbT :: !(VUM.IOVector (L.Log Double)) + , svVarProbF :: !(VUM.IOVector (L.Log Double)) + , svVarFixed :: !(VM.IOVector (Maybe Bool)) + + , svClauseEdges :: !(V.Vector (VU.Vector EdgeIndex)) + , svClauseWeight :: !(VU.Vector Double) + + , svEdgeLit :: !(VU.Vector SAT.Lit) -- i + , svEdgeClause :: !(VU.Vector ClauseIndex) -- a + , svEdgeSurvey :: !(VUM.IOVector (L.Log Double)) -- η_{a → i} + , svEdgeProbU :: !(VUM.IOVector (L.Log Double)) -- Π^u_{i → a} / (Π^u_{i → a} + Π^s_{i → a} + Π^0_{i → a}) + + , svTolRef :: !(IORef Double) + , svIterLimRef :: !(IORef (Maybe Int)) + , svNThreadsRef :: !(IORef Int) + } + +newSolver :: Int -> [(Double, SAT.PackedClause)] -> IO Solver +newSolver nv clauses = do + let num_clauses = length clauses + num_edges = sum [VG.length c | (_,c) <- clauses] + + varEdgesRef <- newIORef IntMap.empty + clauseEdgesM <- VGM.new num_clauses + + (edgeLitM :: VUM.IOVector SAT.Lit) <- VGM.new num_edges + (edgeClauseM :: VUM.IOVector ClauseIndex) <- VGM.new num_edges + + ref <- newIORef 0 + forM_ (zip [0..] clauses) $ \(i,(_,c)) -> do + es <- forM (SAT.unpackClause c) $ \lit -> do + e <- readIORef ref + modifyIORef' ref (+1) + modifyIORef' varEdgesRef (IntMap.insertWith IntSet.union (abs lit) (IntSet.singleton e)) + VGM.unsafeWrite edgeLitM e lit + VGM.unsafeWrite edgeClauseM e i + return e + VGM.unsafeWrite clauseEdgesM i (VG.fromList es) + + varEdges <- readIORef varEdgesRef + clauseEdges <- VG.unsafeFreeze clauseEdgesM + + edgeLit <- VG.unsafeFreeze edgeLitM + edgeClause <- VG.unsafeFreeze edgeClauseM + + -- Initialize all surveys with non-zero values. + -- If we initialize to zero, following trivial solution exists: + -- + -- η_{a→i} = 0 for all i and a. + -- + -- Π^0_{i→a} = 1, Π^u_{i→a} = Π^s_{i→a} = 0 for all i and a, + -- + -- \^{Π}^{0}_i = 1, \^{Π}^{+}_i = \^{Π}^{-}_i = 0 + -- + edgeSurvey <- VGM.replicate num_edges 0.5 + edgeProbU <- VGM.new num_edges + + varFixed <- VGM.replicate nv Nothing + varProbT <- VGM.new nv + varProbF <- VGM.new nv + + tolRef <- newIORef 0.01 + maxIterRef <- newIORef (Just 1000) + nthreadsRef <- newIORef 1 + + let solver = Solver + { svVarEdges = VG.generate nv $ \i -> + case IntMap.lookup (i+1) varEdges of + Nothing -> VG.empty + Just es -> VG.fromListN (IntSet.size es) (IntSet.toList es) + , svVarProbT = varProbT + , svVarProbF = varProbF + , svVarFixed = varFixed + + , svClauseEdges = clauseEdges + , svClauseWeight = VG.fromListN (VG.length clauseEdges) (map fst clauses) + + , svEdgeLit = edgeLit + , svEdgeClause = edgeClause + , svEdgeSurvey = edgeSurvey + , svEdgeProbU = edgeProbU + + , svTolRef = tolRef + , svIterLimRef = maxIterRef + , svNThreadsRef = nthreadsRef + } + + return solver + +deleteSolver :: Solver -> IO () +deleteSolver _solver = return () + +initializeRandom :: Solver -> Rand.GenIO -> IO () +initializeRandom solver gen = do + VG.forM_ (svClauseEdges solver) $ \es -> do + case VG.length es of + 0 -> return () + 1 -> VGM.unsafeWrite (svEdgeSurvey solver) (es ! 0) 1 + n -> do + let p :: Double + p = 1 / fromIntegral n + VG.forM_ es $ \e -> do + d <- Rand.uniformR (p*0.5, p*1.5) gen + VGM.unsafeWrite (svEdgeSurvey solver) e (realToFrac d) + +initializeRandomDirichlet :: Solver -> Rand.GenIO -> IO () +initializeRandomDirichlet solver gen = do + VG.forM_ (svClauseEdges solver) $ \es -> do + case VG.length es of + 0 -> return () + 1 -> VGM.unsafeWrite (svEdgeSurvey solver) (es ! 0) 1 + len -> do + (ps :: V.Vector Double) <- Rand.dirichlet (VG.replicate len 1) gen + numLoop 0 (len-1) $ \i -> do + VGM.unsafeWrite (svEdgeSurvey solver) (es ! i) (realToFrac (ps ! i)) + +-- | number of variables of the problem. +getNVars :: Solver -> IO Int +getNVars solver = return $ VG.length (svVarEdges solver) + +-- | number of constraints of the problem. +getNConstraints :: Solver -> IO Int +getNConstraints solver = return $ VG.length (svClauseEdges solver) + +-- | number of edges of the factor graph +getNEdges :: Solver -> IO Int +getNEdges solver = return $ VG.length (svEdgeLit solver) + +getTolerance :: Solver -> IO Double +getTolerance solver = readIORef (svTolRef solver) + +setTolerance :: Solver -> Double -> IO () +setTolerance solver !tol = writeIORef (svTolRef solver) tol + +getIterationLimit :: Solver -> IO (Maybe Int) +getIterationLimit solver = readIORef (svIterLimRef solver) + +setIterationLimit :: Solver -> Maybe Int -> IO () +setIterationLimit solver val = writeIORef (svIterLimRef solver) val + +getNThreads :: Solver -> IO Int +getNThreads solver = readIORef (svNThreadsRef solver) + +setNThreads :: Solver -> Int -> IO () +setNThreads solver val = writeIORef (svNThreadsRef solver) val + +propagate :: Solver -> IO Bool +propagate solver = do + nthreads <- getNThreads solver + if nthreads > 1 then + propagateMT solver nthreads + else + propagateST solver + +propagateST :: Solver -> IO Bool +propagateST solver = do + tol <- getTolerance solver + lim <- getIterationLimit solver + nv <- getNVars solver + nc <- getNConstraints solver + let max_v_len = VG.maximum $ VG.map VG.length $ svVarEdges solver + max_c_len = VG.maximum $ VG.map VG.length $ svClauseEdges solver + tmp <- VGM.new (max (max_v_len * 2) max_c_len) + let loop !i + | Just l <- lim, i >= l = return False + | otherwise = do + numLoop 1 nv $ \v -> updateEdgeProb solver v tmp + let f maxDelta c = max maxDelta <$> updateEdgeSurvey solver c tmp + delta <- foldM f 0 [0 .. nc-1] + if delta <= tol then do + numLoop 1 nv $ \v -> computeVarProb solver v + return True + else + loop (i+1) + loop 0 + +data WorkerCommand + = WCUpdateEdgeProb + | WCUpdateSurvey + | WCComputeVarProb + | WCTerminate + +propagateMT :: Solver -> Int -> IO Bool +propagateMT solver nthreads = do + tol <- getTolerance solver + lim <- getIterationLimit solver + nv <- getNVars solver + nc <- getNConstraints solver + + mask $ \restore -> do + ex <- newEmptyTMVarIO + let wait :: STM a -> IO a + wait m = join $ atomically $ liftM return m `orElse` liftM throwIO (takeTMVar ex) + + workers <- do + let mV = (nv + nthreads - 1) `div` nthreads + mC = (nc + nthreads - 1) `div` nthreads + forM [0..nthreads-1] $ \i -> do + let lbV = mV * i + 1 -- inclusive + ubV = min (lbV + mV) (nv + 1) -- exclusive + lbC = mC * i -- exclusive + ubC = min (lbC + mC) nc -- exclusive + let max_v_len = VG.maximum $ VG.map VG.length $ VG.slice (lbV - 1) (ubV - lbV) (svVarEdges solver) + max_c_len = VG.maximum $ VG.map VG.length $ VG.slice lbC (ubC - lbC) (svClauseEdges solver) + tmp <- VGM.new (max (max_v_len*2) max_c_len) + reqVar <- newEmptyMVar + respVar <- newEmptyTMVarIO + respVar2 <- newEmptyTMVarIO + th <- forkIO $ do + let loop = do + cmd <- takeMVar reqVar + case cmd of + WCTerminate -> return () + WCUpdateEdgeProb -> do + numLoop lbV (ubV-1) $ \v -> updateEdgeProb solver v tmp + atomically $ putTMVar respVar () + loop + WCUpdateSurvey -> do + let f maxDelta c = max maxDelta <$> updateEdgeSurvey solver c tmp + delta <- foldM f 0 [lbC .. ubC-1] + atomically $ putTMVar respVar2 delta + loop + WCComputeVarProb -> do + numLoop lbV (ubV-1) $ \v -> computeVarProb solver v + atomically $ putTMVar respVar () + loop + restore loop `catch` \(e :: SomeException) -> atomically (tryPutTMVar ex e >> return ()) + return (th, reqVar, respVar, respVar2) + + let loop !i + | Just l <- lim, i >= l = return False + | otherwise = do + mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCUpdateEdgeProb) workers + mapM_ (\(_,_,respVar,_) -> wait (takeTMVar respVar)) workers + mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCUpdateSurvey) workers + delta <- foldM (\delta (_,_,_,respVar2) -> max delta <$> wait (takeTMVar respVar2)) 0 workers + if delta <= tol then do + mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCComputeVarProb) workers + mapM_ (\(_,_,respVar,_) -> wait (takeTMVar respVar)) workers + mapM_ (\(_,reqVar,_,_) -> putMVar reqVar WCTerminate) workers + return True + else + loop (i+1) + + ret <- try $ restore $ loop 0 + case ret of + Right b -> return b + Left (e :: SomeException) -> do + mapM_ (\(th,_,_,_) -> killThread th) workers + throwIO e + +-- tmp1 must have at least @VG.length (svVarEdges solver ! (v - 1)) * 2@ elements +updateEdgeProb :: Solver -> SAT.Var -> VUM.IOVector (L.Log Double) -> IO () +updateEdgeProb solver v tmp = do + let i = v - 1 + edges = svVarEdges solver ! i + m <- VGM.unsafeRead (svVarFixed solver) i + case m of + Just val -> do + VG.forM_ edges $ \e -> do + let lit = svEdgeLit solver ! e + flag = (lit > 0) == val + VGM.unsafeWrite (svEdgeProbU solver) e (if flag then 0 else 1) + Nothing -> do + let f !k !val1_pre !val2_pre + | k >= VG.length edges = return () + | otherwise = do + let e = edges ! k + a = svEdgeClause solver ! e + VGM.unsafeWrite tmp (k*2) val1_pre + VGM.unsafeWrite tmp (k*2+1) val2_pre + eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e -- η_{a→i} + let w = svClauseWeight solver ! a + lit2 = svEdgeLit solver ! e + val1_pre' = if lit2 > 0 then val1_pre * comp eta_ai ^* w else val1_pre + val2_pre' = if lit2 > 0 then val2_pre else val2_pre * comp eta_ai ^* w + f (k+1) val1_pre' val2_pre' + f 0 1 1 + -- tmp ! (k*2) == Π_{a∈edges[0..k-1], a∈V^{+}(i)} (1 - eta_ai)^{w_i} + -- tmp ! (k*2+1) == Π_{a∈edges[0..k-1], a∈V^{-}(i)} (1 - eta_ai)^{w_i} + + let g !k !val1_post !val2_post + | k < 0 = return () + | otherwise = do + let e = edges ! k + a = svEdgeClause solver ! e + lit2 = svEdgeLit solver ! e + val1_pre <- VGM.unsafeRead tmp (k*2) + val2_pre <- VGM.unsafeRead tmp (k*2+1) + let val1 = val1_pre * val1_post -- val1 == Π_{b∈edges, b∈V^{+}(i), a≠b} (1 - eta_bi)^{w_i} + val2 = val2_pre * val2_post -- val2 == Π_{b∈edges, b∈V^{-}(i), a≠b} (1 - eta_bi)^{w_i} + eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e -- η_{a→i} + let w = svClauseWeight solver ! a + val1_post' = if lit2 > 0 then val1_post * comp eta_ai ^* w else val1_post + val2_post' = if lit2 > 0 then val2_post else val2_post * comp eta_ai ^* w + let pi_0 = val1 * val2 -- Π^0_{i→a} + pi_u = if lit2 > 0 then comp val2 * val1 else comp val1 * val2 -- Π^u_{i→a} + pi_s = if lit2 > 0 then comp val1 * val2 else comp val2 * val1 -- Π^s_{i→a} + VGM.unsafeWrite (svEdgeProbU solver) e (pi_u / L.sum [pi_0, pi_u, pi_s]) + g (k-1) val1_post' val2_post' + g (VG.length edges - 1) 1 1 + +-- tmp must have at least @VG.length (svClauseEdges solver ! a)@ elements +updateEdgeSurvey :: Solver -> ClauseIndex -> VUM.IOVector (L.Log Double) -> IO Double +updateEdgeSurvey solver a tmp = do + let edges = svClauseEdges solver ! a + let f !k !p_pre + | k >= VG.length edges = return () + | otherwise = do + let e = edges ! k + VGM.unsafeWrite tmp k p_pre + p <- VGM.unsafeRead (svEdgeProbU solver) e + -- p is the probability of lit being false, if the edge does not exist. + f (k+1) (p_pre * p) + let g !k !p_post !maxDelta + | k < 0 = return maxDelta + | otherwise = do + let e = edges ! k + -- p_post == Π_{e∈edges[k+1..]} p_e + p_pre <- VGM.unsafeRead tmp k -- Π_{e∈edges[0..k-1]} p_e + p <- VGM.unsafeRead (svEdgeProbU solver) e + eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e + let eta_ai' = p_pre * p_post -- Π_{e∈edges[0,..,k-1,k+1,..]} p_e + VGM.unsafeWrite (svEdgeSurvey solver) e eta_ai' + let delta = abs (realToFrac eta_ai' - realToFrac eta_ai) + g (k-1) (p_post * p) (max delta maxDelta) + f 0 1 + -- tmp ! k == Π_{e∈edges[0..k-1]} p_e + g (VG.length edges - 1) 1 0 + +computeVarProb :: Solver -> SAT.Var -> IO () +computeVarProb solver v = do + let i = v - 1 + f (val1,val2) e = do + let lit = svEdgeLit solver ! e + a = svEdgeClause solver ! e + w = svClauseWeight solver ! a + eta_ai <- VGM.unsafeRead (svEdgeSurvey solver) e + let val1' = if lit > 0 then val1 * comp eta_ai ^* w else val1 + val2' = if lit < 0 then val2 * comp eta_ai ^* w else val2 + return (val1',val2') + (val1,val2) <- VG.foldM' f (1,1) (svVarEdges solver ! i) + let p0 = val1 * val2 -- \^{Π}^{0}_i + pp = comp val1 * val2 -- \^{Π}^{+}_i + pn = comp val2 * val1 -- \^{Π}^{-}_i + let wp = pp / (pp + pn + p0) + wn = pn / (pp + pn + p0) + VGM.unsafeWrite (svVarProbT solver) i wp -- W^{(+)}_i + VGM.unsafeWrite (svVarProbF solver) i wn -- W^{(-)}_i + +-- | Get the marginal probability of the variable to be @True@, @False@ and unspecified respectively. +getVarProb :: Solver -> SAT.Var -> IO (Double, Double, Double) +getVarProb solver v = do + pt <- realToFrac <$> VGM.unsafeRead (svVarProbT solver) (v - 1) + pf <- realToFrac <$> VGM.unsafeRead (svVarProbF solver) (v - 1) + return (pt, pf, 1 - (pt + pf)) + +fixLit :: Solver -> SAT.Lit -> IO () +fixLit solver lit = do + VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) (if lit > 0 then Just True else Just False) + +unfixLit :: Solver -> SAT.Lit -> IO () +unfixLit solver lit = do + VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) Nothing + +printInfo :: Solver -> IO () +printInfo solver = do + (surveys :: VU.Vector (L.Log Double)) <- VG.freeze (svEdgeSurvey solver) + (u :: VU.Vector (L.Log Double)) <- VG.freeze (svEdgeProbU solver) + let xs = [(clause, lit, eta, u ! e) | (e, eta) <- zip [0..] (VG.toList surveys), let lit = svEdgeLit solver ! e, let clause = svEdgeClause solver ! e] + putStrLn $ "edges: " ++ show xs + + (pt :: VU.Vector (L.Log Double)) <- VG.freeze (svVarProbT solver) + (pf :: VU.Vector (L.Log Double)) <- VG.freeze (svVarProbF solver) + nv <- getNVars solver + let xs2 = [(v, realToFrac (pt ! i) :: Double, realToFrac (pf ! i) :: Double, realToFrac (pt ! i) - realToFrac (pf ! i) :: Double) | v <- [1..nv], let i = v - 1] + putStrLn $ "vars: " ++ show xs2 diff --git a/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/OpenCL.hs b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/OpenCL.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/OpenCL.hs @@ -0,0 +1,457 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL +-- Copyright : (c) Masahiro Sakai 2016 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- References: +-- +-- * Alfredo Braunstein, Marc Mézard and Riccardo Zecchina. +-- Survey Propagation: An Algorithm for Satisfiability, +-- +-- +-- * Corrie Scalisi. Visualizing Survey Propagation in 3-SAT Factor Graphs, +-- . +-- +----------------------------------------------------------------------------- +module ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL + ( + -- * The Solver type + Solver + , newSolver + , deleteSolver + + -- * Problem information + , getNVars + , getNConstraints + + -- * Parameters + , getTolerance + , setTolerance + , getIterationLimit + , setIterationLimit + + -- * Computing marginal distributions + , initializeRandom + , initializeRandomDirichlet + , propagate + , getVarProb + + -- * Solving + , fixLit + , unfixLit + ) where + +import Control.Exception +import Control.Loop +import Control.Monad +import Control.Parallel.OpenCL +import Data.Bits +import Data.Int +import Data.IORef +import qualified Data.Vector as V +import qualified Data.Vector.Mutable as VM +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as VSM +import Data.Vector.Generic ((!)) +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Generic.Mutable as VGM +import Foreign( castPtr, nullPtr, sizeOf ) +import Foreign.C.Types( CFloat ) +import Language.Haskell.TH (runIO, litE, stringL) +import Language.Haskell.TH.Syntax (addDependentFile) +import qualified Numeric.Log as L +import System.IO +import qualified System.Random.MWC as Rand +import qualified System.Random.MWC.Distributions as Rand +import Text.Printf + +import qualified ToySolver.SAT.Types as SAT + +data Solver + = Solver + { svOutputMessage :: !(String -> IO ()) + + , svContext :: !CLContext + , svDevice :: !CLDeviceID + , svQueue :: !CLCommandQueue + , svUpdateEdgeProb :: !CLKernel + , svUpdateEdgeSurvey :: !CLKernel + , svComputeVarProb :: !CLKernel + + , svVarEdges :: !(VSM.IOVector CLint) + , svVarEdgesWeight :: !(VSM.IOVector CFloat) + , svVarOffset :: !(VSM.IOVector CLint) + , svVarLength :: !(VSM.IOVector CLint) + , svVarFixed :: !(VSM.IOVector Int8) + , svVarProb :: !(VSM.IOVector (L.Log CFloat)) + , svClauseOffset :: !(VSM.IOVector CLint) + , svClauseLength :: !(VSM.IOVector CLint) + , svEdgeSurvey :: !(VSM.IOVector (L.Log CFloat)) -- η_{a → i} + , svEdgeProbU :: !(VSM.IOVector (L.Log CFloat)) -- Π^u_{i → a} / (Π^u_{i → a} + Π^s_{i → a} + Π^0_{i → a}) + + , svTolRef :: !(IORef Double) + , svIterLimRef :: !(IORef (Maybe Int)) + } + +newSolver :: (String -> IO ()) -> CLContext -> CLDeviceID -> Int -> [(Double, SAT.PackedClause)] -> IO Solver +newSolver outputMessage context dev nv clauses = do + _ <- clRetainContext context + queue <- clCreateCommandQueue context dev [] + + let num_clauses = length clauses + num_edges = sum [VG.length c | (_,c) <- clauses] + + (varEdgesTmp :: VM.IOVector [(Int,Bool,Double)]) <- VGM.replicate nv [] + clauseOffset <- VGM.new num_clauses + clauseLength <- VGM.new num_clauses + + ref <- newIORef 0 + forM_ (zip [0..] clauses) $ \(i,(w,c)) -> do + VGM.write clauseOffset i =<< liftM fromIntegral (readIORef ref) + VGM.write clauseLength i (fromIntegral (VG.length c)) + forM_ (SAT.unpackClause c) $ \lit -> do + e <- readIORef ref + modifyIORef' ref (+1) + VGM.modify varEdgesTmp ((e,lit>0,w) :) (abs lit - 1) + + varOffset <- VGM.new nv + varLength <- VGM.new nv + varFixed <- VGM.new nv + varEdges <- VGM.new num_edges + varEdgesWeight <- VGM.new num_edges + let loop !i !offset + | i >= nv = return () + | otherwise = do + xs <- VGM.read (varEdgesTmp) i + let len = length xs + VGM.write varOffset i (fromIntegral offset) + VGM.write varLength i (fromIntegral len) + VGM.write varFixed i 0 + forM_ (zip [offset..] (reverse xs)) $ \(j, (e,polarity,w)) -> do + VGM.write varEdges j $ (fromIntegral e `shiftL` 1) .|. (if polarity then 1 else 0) + VGM.write varEdgesWeight j (realToFrac w) + loop (i+1) (offset + len) + loop 0 0 + + -- Initialize all surveys with non-zero values. + -- If we initialize to zero, following trivial solution exists: + -- + -- η_{a→i} = 0 for all i and a. + -- + -- Π^0_{i→a} = 1, Π^u_{i→a} = Π^s_{i→a} = 0 for all i and a, + -- + -- \^{Π}^{0}_i = 1, \^{Π}^{+}_i = \^{Π}^{-}_i = 0 + -- + edgeSurvey <- VGM.replicate num_edges (L.Exp (log 0.5)) + edgeProbU <- VGM.new num_edges + + varProb <- VGM.new (nv*2) + + tolRef <- newIORef 0.01 + maxIterRef <- newIORef (Just 1000) + + -- Compile + let byteSize :: forall a. VSM.Storable a => VSM.IOVector a -> Int + byteSize v = VGM.length v * sizeOf (undefined :: a) + (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev + let reqConstantBufferSize = + byteSize varEdges + byteSize varEdgesWeight + + byteSize varOffset + byteSize varLength + + byteSize clauseOffset + byteSize clauseLength + let flags = + ["-DUSE_CONSTANT_BUFFER" | maxConstantBufferSize >= reqConstantBufferSize] + -- programSource <- openBinaryFile "sp.cl" ReadMode >>= hGetContents + let programSource = $(runIO (do{ h <- openFile "src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl" ReadMode; hSetEncoding h utf8; hGetContents h }) >>= \s -> addDependentFile "src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl" >> litE (stringL s)) + outputMessage $ "Compiling kernels with options: " ++ unwords flags + program <- clCreateProgramWithSource context programSource + finally (clBuildProgram program [dev] (unwords flags)) + (outputMessage =<< clGetProgramBuildLog program dev) + update_edge_prob <- clCreateKernel program "update_edge_prob" + update_edge_survey <- clCreateKernel program "update_edge_survey" + compute_var_prob <- clCreateKernel program "compute_var_prob" + + return $ + Solver + { svOutputMessage = outputMessage + + , svContext = context + , svDevice = dev + , svQueue = queue + , svUpdateEdgeProb = update_edge_prob + , svUpdateEdgeSurvey = update_edge_survey + , svComputeVarProb = compute_var_prob + + , svVarEdges = varEdges + , svVarEdgesWeight = varEdgesWeight + , svVarOffset = varOffset + , svVarLength = varLength + , svVarFixed = varFixed + , svVarProb = varProb + , svClauseOffset = clauseOffset + , svClauseLength = clauseLength + , svEdgeSurvey = edgeSurvey + , svEdgeProbU = edgeProbU + + , svTolRef = tolRef + , svIterLimRef = maxIterRef + } + +deleteSolver :: Solver -> IO () +deleteSolver solver = do + _ <- clReleaseKernel (svUpdateEdgeProb solver) + _ <- clReleaseKernel (svUpdateEdgeSurvey solver) + _ <- clReleaseKernel (svComputeVarProb solver) + _ <- clReleaseCommandQueue (svQueue solver) + _ <- clReleaseContext (svContext solver) + return () + +initializeRandom :: Solver -> Rand.GenIO -> IO () +initializeRandom solver gen = do + n <- getNConstraints solver + numLoop 0 (n-1) $ \i -> do + off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i + len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i + case len of + 0 -> return () + 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0) + _ -> do + let p :: Double + p = 1 / fromIntegral len + numLoop 0 (len-1) $ \i -> do + d <- Rand.uniformR (p*0.5, p*1.5) gen + VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log d))) + +initializeRandomDirichlet :: Solver -> Rand.GenIO -> IO () +initializeRandomDirichlet solver gen = do + n <- getNConstraints solver + numLoop 0 (n-1) $ \i -> do + off <- fromIntegral <$> VGM.unsafeRead (svClauseOffset solver) i + len <- fromIntegral <$> VGM.unsafeRead (svClauseLength solver) i + case len of + 0 -> return () + 1 -> VGM.unsafeWrite (svEdgeSurvey solver) off (L.Exp 0) + _ -> do + (ps :: V.Vector Double) <- Rand.dirichlet (VG.replicate len 1) gen + numLoop 0 (len-1) $ \i -> do + VGM.unsafeWrite (svEdgeSurvey solver) (off+i) (L.Exp (realToFrac (log (ps ! i)))) + +-- | number of variables of the problem. +getNVars :: Solver -> IO Int +getNVars solver = return $ VGM.length (svVarOffset solver) + +-- | number of constraints of the problem. +getNConstraints :: Solver -> IO Int +getNConstraints solver = return $ VGM.length (svClauseOffset solver) + +-- | number of edges of the factor graph +getNEdges :: Solver -> IO Int +getNEdges solver = return $ VGM.length (svEdgeSurvey solver) + +getTolerance :: Solver -> IO Double +getTolerance solver = readIORef (svTolRef solver) + +setTolerance :: Solver -> Double -> IO () +setTolerance solver !tol = writeIORef (svTolRef solver) tol + +getIterationLimit :: Solver -> IO (Maybe Int) +getIterationLimit solver = readIORef (svIterLimRef solver) + +setIterationLimit :: Solver -> Maybe Int -> IO () +setIterationLimit solver val = writeIORef (svIterLimRef solver) val + +-- | Get the marginal probability of the variable to be @True@, @False@ and unspecified respectively. +getVarProb :: Solver -> SAT.Var -> IO (Double, Double, Double) +getVarProb solver v = do + let i = v - 1 + pt <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2) + pf <- (exp . realToFrac . L.ln) <$> VGM.read (svVarProb solver) (i*2+1) + return (pt, pf, 1 - (pt + pf)) + +propagate :: Solver -> IO Bool +propagate solver = do + tol <- getTolerance solver + lim <- getIterationLimit solver + nv <- getNVars solver + nc <- getNConstraints solver + let ne = VGM.length (svEdgeSurvey solver) + + let context = svContext solver + dev = svDevice solver + queue = svQueue solver + platform <- clGetDevicePlatform dev + + let infos = [CL_PLATFORM_PROFILE, CL_PLATFORM_VERSION, CL_PLATFORM_NAME, CL_PLATFORM_VENDOR, CL_PLATFORM_EXTENSIONS] + forM_ infos $ \info -> do + s <- clGetPlatformInfo platform info + svOutputMessage solver $ show info ++ " = " ++ s + devname <- clGetDeviceName dev + svOutputMessage solver $ "DEVICE = " ++ devname + + (maxComputeUnits :: Int) <- fromIntegral <$> clGetDeviceMaxComputeUnits dev + (maxWorkGroupSize :: Int) <- fromIntegral <$> clGetDeviceMaxWorkGroupSize dev + maxWorkItemSizes@(maxWorkItemSize:_) <- fmap fromIntegral <$> clGetDeviceMaxWorkItemSizes dev + svOutputMessage solver $ "MAX_COMPUTE_UNITS = " ++ show maxComputeUnits + svOutputMessage solver $ "MAX_WORK_GROUP_SIZE = " ++ show maxWorkGroupSize + svOutputMessage solver $ "MAX_WORK_ITEM_SIZES = " ++ show maxWorkItemSizes + (globalMemSize :: Int) <- fromIntegral <$> clGetDeviceGlobalMemSize dev + (localMemSize :: Int) <- fromIntegral <$> clGetDeviceLocalMemSize dev + (maxConstantBufferSize :: Int) <- fromIntegral <$> clGetDeviceMaxConstantBufferSize dev + (maxConstantArgs :: Int) <- fromIntegral <$> clGetDeviceMaxConstantArgs dev + svOutputMessage solver $ "GLOBAL_MEM_SIZE = " ++ show globalMemSize + svOutputMessage solver $ "LOCAL_MEM_SIZE = " ++ show localMemSize + svOutputMessage solver $ "MAX_CONSTANT_BUFFER_SIZE = " ++ show maxConstantBufferSize + svOutputMessage solver $ "MAX_CONSTANT_ARGS = " ++ show maxConstantArgs + + let defaultNumGroups = maxComputeUnits * 4 + + (updateEdgeProb_kernel_workgroup_size :: Int) + <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeProb solver) dev + let updateEdgeProb_local_size = min 32 updateEdgeProb_kernel_workgroup_size + updateEdgeProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeProb_local_size) + updateEdgeProb_global_size = updateEdgeProb_num_groups * updateEdgeProb_local_size + svOutputMessage solver $ + printf "update_edge_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" + updateEdgeProb_kernel_workgroup_size updateEdgeProb_local_size updateEdgeProb_num_groups updateEdgeProb_global_size + + (updateEdgeSurvey_kernel_workgroup_size :: Int) + <- fromIntegral <$> clGetKernelWorkGroupSize (svUpdateEdgeSurvey solver) dev + let updateEdgeSurvey_local_size = min 32 updateEdgeSurvey_kernel_workgroup_size + updateEdgeSurvey_num_groups = min defaultNumGroups (maxWorkItemSize `div` updateEdgeSurvey_local_size) + updateEdgeSurvey_global_size = updateEdgeSurvey_num_groups * updateEdgeSurvey_local_size + svOutputMessage solver $ + printf "update_edge_survey kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" + updateEdgeSurvey_kernel_workgroup_size updateEdgeSurvey_local_size updateEdgeSurvey_num_groups updateEdgeSurvey_global_size + + (computeVarProb_kernel_workgroup_size :: Int) + <- fromIntegral <$> clGetKernelWorkGroupSize (svComputeVarProb solver) dev + let computeVarProb_local_size = min 32 computeVarProb_kernel_workgroup_size + computeVarProb_num_groups = min defaultNumGroups (maxWorkItemSize `div` computeVarProb_local_size) + computeVarProb_global_size = computeVarProb_num_groups * computeVarProb_local_size + svOutputMessage solver $ + printf "compute_var_prob kernel: CL_KERNEL_WORK_GROUP_SIZE=%d -> groupSize=%d numGroups=%d globalSize=%d" + computeVarProb_kernel_workgroup_size computeVarProb_local_size computeVarProb_num_groups computeVarProb_global_size + + let createBufferFromVector :: forall a. VSM.Storable a => [CLMemFlag] -> VSM.IOVector a -> IO CLMem + createBufferFromVector flags v = do + VSM.unsafeWith v $ \ptr -> + clCreateBuffer context (CL_MEM_COPY_HOST_PTR : flags) + (VGM.length v * sizeOf (undefined :: a), castPtr ptr) + + readBufferToVectorAsync :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO CLEvent + readBufferToVectorAsync mem vec = do + VSM.unsafeWith vec $ \ptr -> do + clEnqueueReadBuffer queue mem False + 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) [] + + readBufferToVector :: forall a. VSM.Storable a => CLMem -> VSM.IOVector a -> IO () + readBufferToVector mem vec = do + VSM.unsafeWith vec $ \ptr -> do + ev <- clEnqueueReadBuffer queue mem True + 0 (VSM.length vec * sizeOf (undefined :: a)) (castPtr ptr) [] + _ <- clReleaseEvent ev + return () + + var_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarOffset solver + var_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarLength solver + var_fixed <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarFixed solver + var_edges <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdges solver + var_edges_weight <- createBufferFromVector [CL_MEM_READ_ONLY] $ svVarEdgesWeight solver + clause_offset <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseOffset solver + clause_degree <- createBufferFromVector [CL_MEM_READ_ONLY] $ svClauseLength solver + edge_survey <- createBufferFromVector [CL_MEM_READ_WRITE] $ svEdgeSurvey solver + edge_prob_u <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}] + (ne * sizeOf (undefined :: CFloat), nullPtr) + + global_buf <- clCreateBuffer context [CL_MEM_READ_WRITE {-, CL_MEM_HOST_NOACCESS -}] + (ne * sizeOf (undefined :: CFloat) * 2, nullPtr) + var_prob <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}] + (nv * sizeOf (undefined :: CFloat) * 2, nullPtr) + group_max_delta <- clCreateBuffer context [CL_MEM_WRITE_ONLY {-, CL_MEM_HOST_READONLY -}] + (updateEdgeSurvey_num_groups * sizeOf (undefined :: CFloat), nullPtr) + + clSetKernelArgSto (svUpdateEdgeProb solver) 0 (fromIntegral nv :: CLint) + clSetKernelArgSto (svUpdateEdgeProb solver) 1 var_offset + clSetKernelArgSto (svUpdateEdgeProb solver) 2 var_degree + clSetKernelArgSto (svUpdateEdgeProb solver) 3 var_fixed + clSetKernelArgSto (svUpdateEdgeProb solver) 4 var_edges + clSetKernelArgSto (svUpdateEdgeProb solver) 5 var_edges_weight + clSetKernelArgSto (svUpdateEdgeProb solver) 6 global_buf + clSetKernelArgSto (svUpdateEdgeProb solver) 7 edge_survey + clSetKernelArgSto (svUpdateEdgeProb solver) 8 edge_prob_u + + clSetKernelArgSto (svUpdateEdgeSurvey solver) 0 (fromIntegral nc :: CLint) + clSetKernelArgSto (svUpdateEdgeSurvey solver) 1 clause_offset + clSetKernelArgSto (svUpdateEdgeSurvey solver) 2 clause_degree + clSetKernelArgSto (svUpdateEdgeSurvey solver) 3 edge_survey + clSetKernelArgSto (svUpdateEdgeSurvey solver) 4 edge_prob_u + clSetKernelArgSto (svUpdateEdgeSurvey solver) 5 global_buf + clSetKernelArgSto (svUpdateEdgeSurvey solver) 6 group_max_delta + clSetKernelArg (svUpdateEdgeSurvey solver) 7 (updateEdgeSurvey_local_size * sizeOf (undefined :: CFloat)) nullPtr -- reduce_buf + + clSetKernelArgSto (svComputeVarProb solver) 0 (fromIntegral nv :: CLint) + clSetKernelArgSto (svComputeVarProb solver) 1 var_offset + clSetKernelArgSto (svComputeVarProb solver) 2 var_degree + clSetKernelArgSto (svComputeVarProb solver) 3 var_prob + clSetKernelArgSto (svComputeVarProb solver) 4 var_edges + clSetKernelArgSto (svComputeVarProb solver) 5 var_edges_weight + clSetKernelArgSto (svComputeVarProb solver) 6 edge_survey + + (group_max_delta_vec :: VSM.IOVector CFloat) <- VGM.new updateEdgeSurvey_num_groups + + let loop !i + | Just l <- lim, i >= l = return (False,i) + | otherwise = do + _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeProb solver) + [updateEdgeProb_global_size] [updateEdgeProb_local_size] [] + _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svUpdateEdgeSurvey solver) + [updateEdgeSurvey_global_size] [updateEdgeSurvey_local_size] [] + readBufferToVector group_max_delta group_max_delta_vec + !delta <- VG.maximum <$> VS.unsafeFreeze group_max_delta_vec + if realToFrac delta <= tol then do + return (True,i) + else + loop (i+1) + + (b,_steps) <- loop 0 + + _ <- clReleaseEvent =<< readBufferToVectorAsync edge_survey (svEdgeSurvey solver) + when b $ do + _ <- clReleaseEvent =<< clEnqueueNDRangeKernel queue (svComputeVarProb solver) + [computeVarProb_global_size] [computeVarProb_local_size] [] + _ <- clReleaseEvent =<< readBufferToVectorAsync var_prob (svVarProb solver) + return () + + _ <- clFinish queue + + _ <- clReleaseMemObject var_offset + _ <- clReleaseMemObject var_degree + _ <- clReleaseMemObject var_edges + _ <- clReleaseMemObject var_edges_weight + _ <- clReleaseMemObject clause_offset + _ <- clReleaseMemObject clause_degree + _ <- clReleaseMemObject edge_survey + _ <- clReleaseMemObject edge_prob_u + _ <- clReleaseMemObject global_buf + _ <- clReleaseMemObject var_prob + _ <- clReleaseMemObject group_max_delta + + return b + +fixLit :: Solver -> SAT.Lit -> IO () +fixLit solver lit = do + VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) (if lit > 0 then 1 else -1) + +unfixLit :: Solver -> SAT.Lit -> IO () +unfixLit solver lit = do + VGM.unsafeWrite (svVarFixed solver) (abs lit - 1) 0 diff --git a/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl @@ -0,0 +1,193 @@ +/* -*- mode: c -*- */ + +#ifdef USE_CONSTANT_BUFFER +#define CONSTANT __constant +#else +#define CONSTANT __global +#endif + +typedef float logfloat; +typedef float2 logfloat2; + +static inline logfloat comp(logfloat x) { + return log1p(fmax(-1.0f, -exp(x))); +} + +__kernel void +update_edge_prob( + int n_vars, + CONSTANT int *var_offset, // int[n_vars] + CONSTANT int *var_degree, // int[n_vars] + CONSTANT char *var_fixed, // char[n_vars] + CONSTANT int *var_edges, // int[M] + CONSTANT float *var_edges_weight, // float[M] + __global logfloat2 *var_edges_buf,// logfloat2[M] + __global logfloat *edge_survey, // logfloat[n_edges] + __global logfloat *edge_prob_u // logfloat[n_edges] + ) +{ + int global_size = get_global_size(0); + for (int i = get_global_id(0); i < n_vars; i += global_size) { + int offset = var_offset[i]; + int degree = var_degree[i]; + int fixed = var_fixed[i]; + + if (fixed != 0) { + for (int j = 0; j < degree; j++) { + int tmp = var_edges[offset+j]; + int e = tmp >> 1; + bool polarity = tmp & 1; + if (polarity == (bool)(tmp > 0)) + edge_prob_u[e] = log(0.0f); + else + edge_prob_u[e] = log(1.0f); + } + } + + logfloat val1_pre = log(1.0f); + logfloat val2_pre = log(1.0f); + for (int j = 0; j < degree; j++) { + var_edges_buf[offset+j] = (float2)(val1_pre, val2_pre); + + int tmp = var_edges[offset+j]; + int e = tmp >> 1; + bool polarity = tmp & 1; + logfloat eta_ai = edge_survey[e]; + logfloat w = var_edges_weight[offset+j]; + + if (polarity) { + val1_pre += comp(eta_ai) * w; + } else { + val2_pre += comp(eta_ai) * w; + } + } + + logfloat val1_post = log(1.0f); + logfloat val2_post = log(1.0f); + for (int j = degree - 1; j >= 0; j--) { + int tmp = var_edges[offset+j]; + int e = tmp >> 1; + bool polarity = tmp & 1; + logfloat eta_ai = edge_survey[e]; + float w = var_edges_weight[offset+j]; + + logfloat2 pre = var_edges_buf[offset+j]; + logfloat val1 = pre.x + val1_post; // probability that other edges do not depends on v=1. + logfloat val2 = pre.y + val2_post; // probability that other edges do not depends on v=0. + logfloat pi_0 = val1 + val2; // Π^0_{i→a} + logfloat pi_u; // Π^u_{i→a} + logfloat pi_s; // Π^s_{i→a} + if (polarity) { + pi_u = comp(val2) + val1; + pi_s = comp(val1) + val2; + val1_post += comp(eta_ai) * w; + } else { + pi_u = comp(val1) + val2; + pi_s = comp(val2) + val1; + val2_post += comp(eta_ai) * w; + } + float psum = exp(pi_0) + exp(pi_u) + exp(pi_s); + if (psum > 0) { + edge_prob_u[e] = pi_u - log(psum); + } else { + edge_prob_u[e] = log(0.0f); // is that ok? + } + } + } +} + + +__kernel void +update_edge_survey( + int n_clauses, + CONSTANT int *clause_offset, // int[n_clauses] + CONSTANT int *clause_degree, // int[n_clauses] + __global logfloat *edge_survey, // logfloat[n_edges] + __global logfloat *edge_prob_u, // logfloat[n_edges] + __global logfloat *edge_buf, // logfloat[n_edges] + __global float *group_max_delta, // float[get_num_groups(0)] + __local float *reduce_buf // float[get_local_size(0)] + ) +{ + float max_delta = 0; + + int global_size = get_global_size(0); + for (int a = get_global_id(0); a < n_clauses; a += global_size) { + int len = clause_degree[a]; + int offset = clause_offset[a]; + + logfloat pre = log(1.0f); + for (int j = 0; j < len; j++) { + int e = offset+j; + edge_buf[e] = pre; + pre += edge_prob_u[e]; + } + + logfloat post = log(1.0f); + for (int j = len-1; j >=0; j--) { + int e = offset+j; + logfloat pre = edge_buf[e]; + logfloat eta_ai_orig = edge_survey[e]; + logfloat eta_ai_new = pre + post; + edge_survey[e] = eta_ai_new; + max_delta = fmax(max_delta, fabs(exp(eta_ai_new) - exp(eta_ai_orig))); + post += edge_prob_u[e]; + } + } + + // reduction + int local_id = get_local_id(0); + int local_size = get_local_size(0); + barrier(CLK_LOCAL_MEM_FENCE); + reduce_buf[local_id] = max_delta; + for (int stride = local_size / 2; stride > 0; stride /= 2) { + barrier(CLK_LOCAL_MEM_FENCE); + if (local_id < stride) { + reduce_buf[local_id] = fmax(reduce_buf[local_id], reduce_buf[local_id + stride]); + } + } + if (local_id==0) + group_max_delta[get_group_id(0)] = reduce_buf[0]; +} + +__kernel void +compute_var_prob( + int n_vars, + CONSTANT int *var_offset, // int[n_vars] + CONSTANT int *var_degree, // int[n_vars] + __global logfloat2 *var_prob, // logfloat2[n_vars] + CONSTANT int *var_edges, // int[M] + CONSTANT logfloat *var_edges_weight, // logfloat[M] + __global logfloat *edge_survey // logfloat[E] + ) +{ + int global_size = get_global_size(0); + + for (int i = get_global_id(0); i < n_vars; i += global_size) { + int offset = var_offset[i]; + int degree = var_degree[i]; + + logfloat val1 = log(1.0f); + logfloat val2 = log(1.0f); + for (int j = 0; j < degree; j++) { + int tmp = var_edges[offset+j]; + int e = tmp >> 1; + bool polarity = tmp & 1; + float eta_ai = edge_survey[e]; + float w = var_edges_weight[offset+j]; + + if (polarity) { + val1 += comp(eta_ai) * w; + } else { + val2 += comp(eta_ai) * w; + } + } + + float p0 = val1 + val2; // \^{Π}^{0}_i + float pp = comp(val1) + val2; // \^{Π}^{+}_i + float pn = comp(val2) + val1; // \^{Π}^{-}_i + float wp = pp - log(exp(pp) + exp(pn) + exp(p0)); // W^{(+)}_i + float wn = pn - log(exp(pp) + exp(pn) + exp(p0)); // W^{(-)}_i + var_prob[i] = (float2)(wp, wn); + } +} diff --git a/src/ToySolver/SAT/Solver/SLS/ProbSAT.hs b/src/ToySolver/SAT/Solver/SLS/ProbSAT.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/SLS/ProbSAT.hs @@ -0,0 +1,549 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +---------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.SLS.ProbSAT +-- Copyright : (c) Masahiro Sakai 2017 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- References: +-- +---------------------------------------------------------------------- +module ToySolver.SAT.Solver.SLS.ProbSAT + ( Solver + , newSolver + , newSolverWeighted + , getNumVars + , getRandomGen + , setRandomGen + , getBestSolution + , getStatistics + + , Options (..) + , Callbacks (..) + , Statistics (..) + + , generateUniformRandomSolution + + , probsat + , walksat + ) where + +import Prelude hiding (break) + +import Control.Exception +import Control.Loop +import Control.Monad +import Control.Monad.Primitive +import Control.Monad.Trans +import Control.Monad.Trans.Except +import Data.Array.Base (unsafeRead, unsafeWrite, unsafeAt) +import Data.Array.IArray +import Data.Array.IO +import Data.Array.Unboxed +import Data.Array.Unsafe +import Data.Bits +import Data.Default.Class +import qualified Data.Foldable as F +import Data.Int +import Data.IORef +import Data.Maybe +import Data.Sequence ((|>)) +import qualified Data.Sequence as Seq +import Data.Typeable +import Data.Word +import System.Clock +import qualified System.Random.MWC as Rand +import qualified System.Random.MWC.Distributions as Rand +import qualified ToySolver.FileFormat.CNF as CNF +import ToySolver.Internal.Data.IOURef +import qualified ToySolver.Internal.Data.Vec as Vec +import qualified ToySolver.SAT.Types as SAT + +-- ------------------------------------------------------------------- + +data Solver + = Solver + { svClauses :: !(Array ClauseId PackedClause) + , svClauseWeights :: !(Array ClauseId CNF.Weight) + , svClauseWeightsF :: !(UArray ClauseId Double) + , svClauseNumTrueLits :: !(IOUArray ClauseId Int32) + , svClauseUnsatClauseIndex :: !(IOUArray ClauseId Int) + , svUnsatClauses :: !(Vec.UVec ClauseId) + + , svVarOccurs :: !(Array SAT.Var (UArray Int ClauseId)) + , svVarOccursState :: !(Array SAT.Var (IOUArray Int Bool)) + , svSolution :: !(IOUArray SAT.Var Bool) + + , svObj :: !(IORef CNF.Weight) + + , svRandomGen :: !(IORef Rand.GenIO) + , svBestSolution :: !(IORef (CNF.Weight, SAT.Model)) + , svStatistics :: !(IORef Statistics) + } + +type ClauseId = Int + +type PackedClause = Array Int SAT.Lit + +newSolver :: CNF.CNF -> IO Solver +newSolver cnf = do + let wcnf = + CNF.WCNF + { CNF.wcnfNumVars = CNF.cnfNumVars cnf + , CNF.wcnfNumClauses = CNF.cnfNumClauses cnf + , CNF.wcnfTopCost = fromIntegral (CNF.cnfNumClauses cnf) + 1 + , CNF.wcnfClauses = [(1,c) | c <- CNF.cnfClauses cnf] + } + newSolverWeighted wcnf + +newSolverWeighted :: CNF.WCNF -> IO Solver +newSolverWeighted wcnf = do + let m :: SAT.Var -> Bool + m _ = False + nv = CNF.wcnfNumVars wcnf + + objRef <- newIORef (0::Integer) + + cs <- liftM catMaybes $ forM (CNF.wcnfClauses wcnf) $ \(w,pc) -> do + case SAT.normalizeClause (SAT.unpackClause pc) of + Nothing -> return Nothing + Just [] -> modifyIORef' objRef (w+) >> return Nothing + Just c -> do + let c' = listArray (0, length c - 1) c + seq c' $ return (Just (w,c')) + let len = length cs + clauses = listArray (0, len - 1) (map snd cs) + weights :: Array ClauseId CNF.Weight + weights = listArray (0, len - 1) (map fst cs) + weightsF :: UArray ClauseId Double + weightsF = listArray (0, len - 1) (map (fromIntegral . fst) cs) + + (varOccurs' :: IOArray SAT.Var (Seq.Seq (Int, Bool))) <- newArray (1, nv) Seq.empty + + clauseNumTrueLits <- newArray (bounds clauses) 0 + clauseUnsatClauseIndex <- newArray (bounds clauses) (-1) + unsatClauses <- Vec.new + + forAssocsM_ clauses $ \(c,clause) -> do + let n = sum [1 | lit <- elems clause, SAT.evalLit m lit] + writeArray clauseNumTrueLits c n + when (n == 0) $ do + i <- Vec.getSize unsatClauses + writeArray clauseUnsatClauseIndex c i + Vec.push unsatClauses c + modifyIORef objRef ((weights ! c) +) + forM_ (elems clause) $ \lit -> do + let v = SAT.litVar lit + let b = SAT.evalLit m lit + seq b $ modifyArray varOccurs' v (|> (c,b)) + + varOccurs <- do + (arr::IOArray SAT.Var (UArray Int ClauseId)) <- newArray_ (1, nv) + forM_ [1 .. nv] $ \v -> do + s <- readArray varOccurs' v + writeArray arr v $ listArray (0, Seq.length s - 1) (map fst (F.toList s)) + unsafeFreeze arr + + varOccursState <- do + (arr::IOArray SAT.Var (IOUArray Int Bool)) <- newArray_ (1, nv) + forM_ [1 .. nv] $ \v -> do + s <- readArray varOccurs' v + ss <- newArray_ (0, Seq.length s - 1) + forM_ (zip [0..] (F.toList s)) $ \(j,a) -> writeArray ss j (snd a) + writeArray arr v ss + unsafeFreeze arr + + solution <- newListArray (1, nv) $ [SAT.evalVar m v | v <- [1..nv]] + + bestObj <- readIORef objRef + bestSol <- freeze solution + bestSolution <- newIORef (bestObj, bestSol) + + randGen <- newIORef =<< Rand.create + + stat <- newIORef def + + return $ + Solver + { svClauses = clauses + , svClauseWeights = weights + , svClauseWeightsF = weightsF + , svClauseNumTrueLits = clauseNumTrueLits + , svClauseUnsatClauseIndex = clauseUnsatClauseIndex + , svUnsatClauses = unsatClauses + + , svVarOccurs = varOccurs + , svVarOccursState = varOccursState + , svSolution = solution + + , svObj = objRef + + , svRandomGen = randGen + , svBestSolution = bestSolution + , svStatistics = stat + } + + +flipVar :: Solver -> SAT.Var -> IO () +flipVar solver v = mask_ $ do + let occurs = svVarOccurs solver ! v + occursState = svVarOccursState solver ! v + seq occurs $ seq occursState $ return () + modifyArray (svSolution solver) v not + forAssocsM_ occurs $ \(j,!c) -> do + b <- unsafeRead occursState j + n <- unsafeRead (svClauseNumTrueLits solver) c + unsafeWrite occursState j (not b) + if b then do + unsafeWrite (svClauseNumTrueLits solver) c (n-1) + when (n==1) $ do + i <- Vec.getSize (svUnsatClauses solver) + Vec.push (svUnsatClauses solver) c + unsafeWrite (svClauseUnsatClauseIndex solver) c i + modifyIORef' (svObj solver) (+ unsafeAt (svClauseWeights solver) c) + else do + unsafeWrite (svClauseNumTrueLits solver) c (n+1) + when (n==0) $ do + s <- Vec.getSize (svUnsatClauses solver) + i <- unsafeRead (svClauseUnsatClauseIndex solver) c + unless (i == s-1) $ do + let i2 = s-1 + c2 <- Vec.unsafeRead (svUnsatClauses solver) i2 + Vec.unsafeWrite (svUnsatClauses solver) i2 c + Vec.unsafeWrite (svUnsatClauses solver) i c2 + unsafeWrite (svClauseUnsatClauseIndex solver) c2 i + _ <- Vec.unsafePop (svUnsatClauses solver) + modifyIORef' (svObj solver) (subtract (unsafeAt (svClauseWeights solver) c)) + return () + +setSolution :: SAT.IModel m => Solver -> m -> IO () +setSolution solver m = do + b <- getBounds (svSolution solver) + forM_ (range b) $ \v -> do + val <- readArray (svSolution solver) v + let val' = SAT.evalVar m v + unless (val == val') $ do + flipVar solver v + +getNumVars :: Solver -> IO Int +getNumVars solver = return $ rangeSize $ bounds (svVarOccurs solver) + +getRandomGen :: Solver -> IO Rand.GenIO +getRandomGen solver = readIORef (svRandomGen solver) + +setRandomGen :: Solver -> Rand.GenIO -> IO () +setRandomGen solver gen = writeIORef (svRandomGen solver) gen + +getBestSolution :: Solver -> IO (CNF.Weight, SAT.Model) +getBestSolution solver = readIORef (svBestSolution solver) + +getStatistics :: Solver -> IO Statistics +getStatistics solver = readIORef (svStatistics solver) + +{-# INLINE getMakeValue #-} +getMakeValue :: Solver -> SAT.Var -> IO Double +getMakeValue solver v = do + let occurs = svVarOccurs solver ! v + (lb,ub) = bounds occurs + seq occurs $ seq lb $ seq ub $ + numLoopState lb ub 0 $ \ !r !i -> do + let c = unsafeAt occurs i + n <- unsafeRead (svClauseNumTrueLits solver) c + return $! if n == 0 then (r + unsafeAt (svClauseWeightsF solver) c) else r + +{-# INLINE getBreakValue #-} +getBreakValue :: Solver -> SAT.Var -> IO Double +getBreakValue solver v = do + let occurs = svVarOccurs solver ! v + occursState = svVarOccursState solver ! v + (lb,ub) = bounds occurs + seq occurs $ seq occursState $ seq lb $ seq ub $ + numLoopState lb ub 0 $ \ !r !i -> do + b <- unsafeRead occursState i + if b then do + let c = unsafeAt occurs i + n <- unsafeRead (svClauseNumTrueLits solver) c + return $! if n==1 then (r + unsafeAt (svClauseWeightsF solver) c) else r + else + return r + +-- ------------------------------------------------------------------- + +data Options + = Options + { optTarget :: !CNF.Weight + , optMaxTries :: !Int + , optMaxFlips :: !Int + , optPickClauseWeighted :: Bool + } + deriving (Eq, Show) + +instance Default Options where + def = + Options + { optTarget = 0 + , optMaxTries = 1 + , optMaxFlips = 100000 + , optPickClauseWeighted = False + } + +data Callbacks + = Callbacks + { cbGenerateInitialSolution :: Solver -> IO SAT.Model + , cbOnUpdateBestSolution :: Solver -> CNF.Weight -> SAT.Model -> IO () + } + +instance Default Callbacks where + def = + Callbacks + { cbGenerateInitialSolution = generateUniformRandomSolution + , cbOnUpdateBestSolution = \_ _ _ -> return () + } + +data Statistics + = Statistics + { statTotalCPUTime :: !TimeSpec + , statFlips :: !Int + , statFlipsPerSecond :: !Double + } + deriving (Eq, Show) + +instance Default Statistics where + def = + Statistics + { statTotalCPUTime = 0 + , statFlips = 0 + , statFlipsPerSecond = 0 + } + +-- ------------------------------------------------------------------- + +generateUniformRandomSolution :: Solver -> IO SAT.Model +generateUniformRandomSolution solver = do + gen <- getRandomGen solver + n <- getNumVars solver + (a :: IOUArray Int Bool) <- newArray_ (1,n) + forM_ [1..n] $ \v -> do + b <- Rand.uniform gen + writeArray a v b + unsafeFreeze a + +checkCurrentSolution :: Solver -> Callbacks -> IO () +checkCurrentSolution solver cb = do + best <- readIORef (svBestSolution solver) + obj <- readIORef (svObj solver) + when (obj < fst best) $ do + sol <- freeze (svSolution solver) + writeIORef (svBestSolution solver) (obj, sol) + cbOnUpdateBestSolution cb solver obj sol + +pickClause :: Solver -> Options -> IO PackedClause +pickClause solver opt = do + gen <- getRandomGen solver + if optPickClauseWeighted opt then do + obj <- readIORef (svObj solver) + let f !j !x = do + c <- Vec.read (svUnsatClauses solver) j + let w = svClauseWeights solver ! c + if x < w then + return c + else + f (j + 1) (x - w) + x <- rand obj gen + c <- f 0 x + return $ (svClauses solver ! c) + else do + s <- Vec.getSize (svUnsatClauses solver) + j <- Rand.uniformR (0, s - 1) gen -- For integral types inclusive range is used + liftM (svClauses solver !) $ Vec.read (svUnsatClauses solver) j + +rand :: PrimMonad m => Integer -> Rand.Gen (PrimState m) -> m Integer +rand n gen + | n <= toInteger (maxBound :: Word32) = liftM toInteger $ Rand.uniformR (0, fromIntegral n - 1 :: Word32) gen + | otherwise = do + a <- rand (n `shiftR` 32) gen + (b::Word32) <- Rand.uniform gen + return $ (a `shiftL` 32) .|. toInteger b + +data Finished = Finished + deriving (Show, Typeable) + +instance Exception Finished + +-- ------------------------------------------------------------------- + +probsat :: Solver -> Options -> Callbacks -> (Double -> Double -> Double) -> IO () +probsat solver opt cb f = do + gen <- getRandomGen solver + let maxClauseLen = + if rangeSize (bounds (svClauses solver)) == 0 + then 0 + else maximum $ map (rangeSize . bounds) $ elems (svClauses solver) + (wbuf :: IOUArray Int Double) <- newArray_ (0, maxClauseLen-1) + wsumRef <- newIOURef (0 :: Double) + + let pickVar :: PackedClause -> IO SAT.Var + pickVar c = do + writeIOURef wsumRef 0 + forAssocsM_ c $ \(k,lit) -> do + let v = SAT.litVar lit + m <- getMakeValue solver v + b <- getBreakValue solver v + let w = f m b + writeArray wbuf k w + modifyIOURef wsumRef (+w) + wsum <- readIOURef wsumRef + + let go :: Int -> Double -> IO Int + go !k !a = do + if not (inRange (bounds c) k) then do + return $! snd (bounds c) + else do + w <- readArray wbuf k + if a <= w then + return k + else + go (k + 1) (a - w) + k <- go 0 =<< Rand.uniformR (0, wsum) gen + return $! SAT.litVar (c ! k) + + startCPUTime <- getTime ProcessCPUTime + flipsRef <- newIOURef (0::Int) + + -- It's faster to use Control.Exception than using Control.Monad.Except + let body = do + replicateM_ (optMaxTries opt) $ do + sol <- cbGenerateInitialSolution cb solver + setSolution solver sol + checkCurrentSolution solver cb + replicateM_ (optMaxFlips opt) $ do + s <- Vec.getSize (svUnsatClauses solver) + when (s == 0) $ throw Finished + obj <- readIORef (svObj solver) + when (obj <= optTarget opt) $ throw Finished + c <- pickClause solver opt + v <- pickVar c + flipVar solver v + modifyIOURef flipsRef inc + checkCurrentSolution solver cb + body `catch` (\(_::Finished) -> return ()) + + endCPUTime <- getTime ProcessCPUTime + flips <- readIOURef flipsRef + let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime + totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int) + writeIORef (svStatistics solver) $ + Statistics + { statTotalCPUTime = totalCPUTime + , statFlips = flips + , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec + } + + return () + + + +walksat :: Solver -> Options -> Callbacks -> Double -> IO () +walksat solver opt cb p = do + gen <- getRandomGen solver + (buf :: Vec.UVec SAT.Var) <- Vec.new + + let pickVar :: PackedClause -> IO SAT.Var + pickVar c = do + Vec.clear buf + let (lb,ub) = bounds c + r <- runExceptT $ do + _ <- numLoopState lb ub (1.0/0.0) $ \ !b0 !i -> do + let v = SAT.litVar (c ! i) + b <- lift $ getBreakValue solver v + if b <= 0 then + throwE v -- freebie move + else if b < b0 then do + lift $ Vec.clear buf >> Vec.push buf v + return b + else if b == b0 then do + lift $ Vec.push buf v + return b0 + else do + return b0 + return () + case r of + Left v -> return v + Right _ -> do + flag <- Rand.bernoulli p gen + if flag then do + -- random walk move + i <- Rand.uniformR (lb,ub) gen + return $! SAT.litVar (c ! i) + else do + -- greedy move + s <- Vec.getSize buf + if s == 1 then + Vec.unsafeRead buf 0 + else do + i <- Rand.uniformR (0, s - 1) gen + Vec.unsafeRead buf i + + startCPUTime <- getTime ProcessCPUTime + flipsRef <- newIOURef (0::Int) + + -- It's faster to use Control.Exception than using Control.Monad.Except + let body = do + replicateM_ (optMaxTries opt) $ do + sol <- cbGenerateInitialSolution cb solver + setSolution solver sol + checkCurrentSolution solver cb + replicateM_ (optMaxFlips opt) $ do + s <- Vec.getSize (svUnsatClauses solver) + when (s == 0) $ throw Finished + obj <- readIORef (svObj solver) + when (obj <= optTarget opt) $ throw Finished + c <- pickClause solver opt + v <- pickVar c + flipVar solver v + modifyIOURef flipsRef inc + checkCurrentSolution solver cb + body `catch` (\(_::Finished) -> return ()) + + endCPUTime <- getTime ProcessCPUTime + flips <- readIOURef flipsRef + let totalCPUTime = endCPUTime `diffTimeSpec` startCPUTime + totalCPUTimeSec = fromIntegral (toNanoSecs totalCPUTime) / 10^(9::Int) + writeIORef (svStatistics solver) $ + Statistics + { statTotalCPUTime = totalCPUTime + , statFlips = flips + , statFlipsPerSecond = fromIntegral flips / totalCPUTimeSec + } + + return () + +-- ------------------------------------------------------------------- + +{-# INLINE modifyArray #-} +modifyArray :: (MArray a e m, Ix i) => a i e -> i -> (e -> e) -> m () +modifyArray a i f = do + e <- readArray a i + writeArray a i (f e) + +{-# INLINE forAssocsM_ #-} +forAssocsM_ :: (IArray a e, Monad m) => a Int e -> ((Int,e) -> m ()) -> m () +forAssocsM_ a f = do + let (lb,ub) = bounds a + numLoop lb ub $ \i -> + f (i, unsafeAt a i) + +{-# INLINE inc #-} +inc :: Integral a => a -> a +inc a = a+1 + +-- ------------------------------------------------------------------- diff --git a/src/ToySolver/SAT/Solver/SLS/UBCSAT.hs b/src/ToySolver/SAT/Solver/SLS/UBCSAT.hs new file mode 100644 --- /dev/null +++ b/src/ToySolver/SAT/Solver/SLS/UBCSAT.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +---------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Solver.SLS.UBCSAT +-- Copyright : (c) Masahiro Sakai 2017 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +-- References: +-- +---------------------------------------------------------------------- +module ToySolver.SAT.Solver.SLS.UBCSAT + ( ubcsatBest + , ubcsatBestFeasible + , ubcsatMany + , Options (..) + ) where + +import Control.Exception +import Control.Monad +import Data.Array.IArray +import Data.Char +import Data.Default +import Data.Either +import Data.Function +import Data.List +#if MIN_VERSION_megaparsec(6,0,0) +import Data.Void +#endif +import System.Directory +import System.IO +import System.IO.Temp +import System.Process +import Text.Megaparsec hiding (try) +#if MIN_VERSION_megaparsec(6,0,0) +import Text.Megaparsec.Char +#else +import Text.Megaparsec.String +#endif + +import qualified ToySolver.FileFormat.CNF as CNF +import qualified ToySolver.SAT.Types as SAT + +data Options + = Options + { optCommand :: FilePath + , optTempDir :: Maybe FilePath + , optProblem :: CNF.WCNF + , optProblemFile :: Maybe FilePath + , optVarInit :: [SAT.Lit] + } + +instance Default Options where + def = Options + { optCommand = "ubcsat" + , optTempDir = Nothing + , optProblem = + CNF.WCNF + { CNF.wcnfNumVars = 0 + , CNF.wcnfNumClauses = 0 + , CNF.wcnfTopCost = 1 + , CNF.wcnfClauses = [] + } + , optProblemFile = Nothing + , optVarInit = [] + } + +ubcsatBestFeasible :: Options -> IO (Maybe (Integer, SAT.Model)) +ubcsatBestFeasible opt = do + ret <- ubcsatBest opt + case ret of + Nothing -> return Nothing + Just (obj,_) -> + if obj < CNF.wcnfTopCost (optProblem opt) then + return ret + else + return Nothing + +ubcsatBest :: Options -> IO (Maybe (Integer, SAT.Model)) +ubcsatBest opt = do + sols <- ubcsatMany opt + case sols of + [] -> return Nothing + _ -> return $ Just $ minimumBy (compare `on` fst) sols + +ubcsatMany :: Options -> IO [(Integer, SAT.Model)] +ubcsatMany opt = do + dir <- case optTempDir opt of + Just dir -> return dir + Nothing -> getTemporaryDirectory + + let f fname + | null (optVarInit opt) = ubcsat' opt fname Nothing + | otherwise = do + withTempFile dir ".txt" $ \varInitFile h -> do + hSetBinaryMode h True + hSetBuffering h (BlockBuffering Nothing) + forM_ (split 10 (optVarInit opt)) $ \xs -> do + hPutStrLn h $ unwords (map show xs) + hClose h + ubcsat' opt fname (Just varInitFile) + + case optProblemFile opt of + Just fname -> f fname + Nothing -> do + withTempFile dir ".wcnf" $ \fname h -> do + hClose h + CNF.writeFile fname (optProblem opt) + f fname + +ubcsat' :: Options -> FilePath -> Maybe FilePath -> IO [(Integer, SAT.Model)] +ubcsat' opt fname varInitFile = do + let wcnf = optProblem opt + let args = + [ "-w" | ".wcnf" `isSuffixOf` map toLower fname] ++ + [ "-alg", "irots" + , "-seed", "0" + , "-runs", "10" + , "-cutoff", show (CNF.wcnfNumVars wcnf * 50) + , "-timeout", show (10 :: Int) + , "-gtimeout", show (30 :: Int) + , "-solve" + , "-r", "bestsol" + , "-inst", fname + ] ++ + (case varInitFile of + Nothing -> [] + Just fname2 -> ["-varinitfile", fname2]) + stdinStr = "" + + putStrLn $ "c Running " ++ show (optCommand opt) ++ " with " ++ show args + ret <- try $ readProcess (optCommand opt) args stdinStr + case ret of + Left (err :: IOError) -> do + forM_ (lines (show err)) $ \l -> do + putStr "c " >> putStrLn l + return [] + Right s -> do + forM_ (lines s) $ \l -> putStr "c " >> putStrLn l + return $ scanSolutions (CNF.wcnfNumVars wcnf) s + +scanSolutions :: Int -> String -> [(Integer, SAT.Model)] +scanSolutions nv s = rights $ map (parse (solution nv) "") $ lines s + +#if MIN_VERSION_megaparsec(6,0,0) +solution :: MonadParsec Void String m => Int -> m (Integer, SAT.Model) +#else +solution :: Int -> Parser (Integer, SAT.Model) +#endif +solution nv = do + skipSome digitChar + space + _ <- char '0' <|> char '1' + space + obj <- liftM read $ some digitChar + space + values <- many ((char '0' >> return False) <|> (char '1' >> return True)) + let m = array (1, nv) (zip [1..] values) + return (obj, m) + + +split :: Int -> [a] -> [[a]] +split n = go + where + go [] = [] + go xs = + case splitAt n xs of + (ys, zs) -> ys : go zs diff --git a/src/ToySolver/SAT/Store/CNF.hs b/src/ToySolver/SAT/Store/CNF.hs --- a/src/ToySolver/SAT/Store/CNF.hs +++ b/src/ToySolver/SAT/Store/CNF.hs @@ -1,14 +1,17 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Store.CNF -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (FlexibleContexts, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.SAT.Store.CNF diff --git a/src/ToySolver/SAT/Store/PB.hs b/src/ToySolver/SAT/Store/PB.hs --- a/src/ToySolver/SAT/Store/PB.hs +++ b/src/ToySolver/SAT/Store/PB.hs @@ -1,14 +1,17 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SAT.Store.PB -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : experimental --- Portability : non-portable (FlexibleContexts, FlexibleInstances, MultiParamTypeClasses) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.SAT.Store.PB diff --git a/src/ToySolver/SAT/TheorySolver.hs b/src/ToySolver/SAT/TheorySolver.hs --- a/src/ToySolver/SAT/TheorySolver.hs +++ b/src/ToySolver/SAT/TheorySolver.hs @@ -1,3 +1,14 @@ +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.TheorySolver +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.SAT.TheorySolver ( TheorySolver (..) , emptyTheory diff --git a/src/ToySolver/SAT/Types.hs b/src/ToySolver/SAT/Types.hs --- a/src/ToySolver/SAT/Types.hs +++ b/src/ToySolver/SAT/Types.hs @@ -1,4 +1,20 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.SAT.Types +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.SAT.Types ( -- * Variable @@ -33,6 +49,10 @@ , clauseToPBLinAtLeast -- * Packed Clause + , PackedVar + , PackedLit + , packLit + , unpackLit , PackedClause , packClause , unpackClause @@ -95,6 +115,7 @@ import Data.Array.Unboxed import Data.Ord import Data.List +import Data.Int import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) @@ -224,13 +245,22 @@ clauseToPBLinAtLeast :: Clause -> PBLinAtLeast clauseToPBLinAtLeast xs = ([(1,l) | l <- xs], 1) -type PackedClause = VU.Vector Lit +type PackedVar = PackedLit +type PackedLit = Int32 +packLit :: Lit -> PackedLit +packLit = fromIntegral + +unpackLit :: PackedLit -> Lit +unpackLit = fromIntegral + +type PackedClause = VU.Vector PackedLit + packClause :: Clause -> PackedClause -packClause = VU.fromList +packClause = VU.fromList . map packLit unpackClause :: PackedClause -> Clause -unpackClause = VU.toList +unpackClause = map unpackLit . VU.toList type AtLeast = ([Lit], Int) type Exactly = ([Lit], Int) @@ -355,7 +385,7 @@ step3 :: PBLinExactly -> PBLinExactly step3 constr@(xs,n) = case SubsetSum.subsetSum (V.fromList [c | (c,_) <- xs]) n of - Just _ -> constr + Just _ -> constr Nothing -> ([], 1) -- false {-# SPECIALIZE instantiatePBLinAtLeast :: (Lit -> IO LBool) -> PBLinAtLeast -> IO PBLinAtLeast #-} @@ -538,7 +568,7 @@ class AddClause m a => AddCardinality m a | a -> m where {-# MINIMAL addAtLeast #-} - -- | Add a cardinality constraints /atleast({l1,l2,..},n)/. + -- | Add a cardinality constraints /atleast({l1,l2,..},n)/. addAtLeast :: a -> [Lit] -- ^ set of literals /{l1,l2,..}/ (duplicated elements are ignored) diff --git a/src/ToySolver/SDP.hs b/src/ToySolver/SDP.hs --- a/src/ToySolver/SDP.hs +++ b/src/ToySolver/SDP.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -142,7 +143,7 @@ type Target DualizeInfo = SDPFile.Solution instance ForwardTransformer DualizeInfo where - transformForward (DualizeInfo _origM origBlockStruct) + transformForward (DualizeInfo _origM origBlockStruct) SDPFile.Solution { SDPFile.primalVector = xV , SDPFile.primalMatrix = xM diff --git a/src/ToySolver/SMT.hs b/src/ToySolver/SMT.hs --- a/src/ToySolver/SMT.hs +++ b/src/ToySolver/SMT.hs @@ -1,13 +1,19 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, CPP, OverloadedStrings, ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.SMT -- Copyright : (c) Masahiro Sakai 2015 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : unstable --- Portability : non-portable (MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, CPP, OverloadedStrings, ScopedTypeVariables) +-- Portability : non-portable -- ----------------------------------------------------------------------------- module ToySolver.SMT @@ -528,7 +534,7 @@ FEUFFun (_,s) _ -> s -- ------------------------------------------------------------------- - + exprToFormula :: Solver -> Expr -> IO Tseitin.Formula exprToFormula solver (EAp "true" []) = return true exprToFormula solver (EAp "false" []) = return false @@ -670,7 +676,7 @@ c2 <- abstractLRAAtom solver (ret .==. e') Tseitin.addFormula (smtEnc solver) $ ite c' (Atom c1) (Atom c2) return ret -exprToLRAExpr solver (EAp f xs) = +exprToLRAExpr solver (EAp f xs) = lraExprFromTerm solver =<< exprToEUFTerm solver f xs abstractLRAAtom :: Solver -> LA.Atom Rational -> IO SAT.Lit @@ -686,7 +692,7 @@ vGt <- SAT.newVar (smtSAT solver) SAT.addClause (smtSAT solver) [vLt,vEq,vGt] SAT.addClause (smtSAT solver) [-vLt, -vEq] - SAT.addClause (smtSAT solver) [-vLt, -vGt] + SAT.addClause (smtSAT solver) [-vLt, -vGt] SAT.addClause (smtSAT solver) [-vEq, -vGt] let xs = IntMap.fromList [ (vEq, LA.var v .==. LA.constant rhs) @@ -861,7 +867,7 @@ Nothing -> do c <- EUF.newFSym (smtEUF solver) let w = BV.width e - m = IntMap.findWithDefault IntMap.empty w fsymToBV + m = IntMap.findWithDefault IntMap.empty w fsymToBV forM_ (IntMap.toList m) $ \(d, d_bv) -> do -- allocate interface equalities b1 <- abstractEUFAtom solver (EUF.TApp c [], EUF.TApp d []) @@ -1001,8 +1007,8 @@ m1 <- readIORef ref let m2 = IntMap.fromList [(lit, name) | (name, lit) <- Map.toList named] failed <- SAT.getFailedAssumptions (smtSAT solver) - writeIORef (smtUnsatAssumptions solver) $ catMaybes [IntMap.lookup l m1 | l <- failed] - writeIORef (smtUnsatCore solver) $ catMaybes [IntMap.lookup l m2 | l <- failed] + writeIORef (smtUnsatAssumptions solver) $ catMaybes [IntMap.lookup l m1 | l <- IntSet.toList failed] + writeIORef (smtUnsatCore solver) $ catMaybes [IntMap.lookup l m2 | l <- IntSet.toList failed] return ret getContextLit :: Solver -> IO SAT.Lit @@ -1027,7 +1033,7 @@ { alSavedNamedAssertions = named , alSavedFDefs = if globalDeclarations then Nothing else Just fdefs , alSelector = l2 - } + } Vec.push (smtAssertionStack solver) newLevel pop :: Solver -> IO () @@ -1211,7 +1217,7 @@ Nothing -> EUF.mUnspecified (mEUFModel m) entityToValue :: Model -> EUF.Entity -> Sort -> Value -entityToValue m e s = +entityToValue m e s = case s of Sort SSymBool _ -> ValBool (e == mEUFTrue m) Sort SSymReal _ -> @@ -1234,7 +1240,7 @@ deriving (Eq, Show) evalFSym :: Model -> FSym -> FunDef -evalFSym m f = +evalFSym m f = case Map.lookup f (mDefs m) of Just (FEUFFun (argsSorts@(_:_), resultSort) sym) -> -- proper function symbol let tbl = EUF.mFunctions (mEUFModel m) IntMap.! sym @@ -1251,7 +1257,7 @@ Nothing -> E.throw $ Error $ "unknown function symbol: " ++ show f -- | Constraints that cannot represented as function definitions. --- +-- -- For example, zero-division result values cannot be specified by -- function definition, because division is interpreted function. modelGetAssertions :: Model -> [Expr] @@ -1285,7 +1291,7 @@ , EValue (ValBitVec t) ] | (s,t) <- Map.toList bvRemTable - ] + ] where (_, bvDivTable, bvRemTable) = mBVModel m diff --git a/src/ToySolver/Text/CNF.hs b/src/ToySolver/Text/CNF.hs --- a/src/ToySolver/Text/CNF.hs +++ b/src/ToySolver/Text/CNF.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} -- {-# LANGUAGE BangPatterns #-} -- {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -6,7 +7,7 @@ -- Module : ToySolver.Text.CNF -- Copyright : (c) Masahiro Sakai 2016-2018 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable diff --git a/src/ToySolver/Text/GCNF.hs b/src/ToySolver/Text/GCNF.hs --- a/src/ToySolver/Text/GCNF.hs +++ b/src/ToySolver/Text/GCNF.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Text.GCNF -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/Text/QDimacs.hs b/src/ToySolver/Text/QDimacs.hs --- a/src/ToySolver/Text/QDimacs.hs +++ b/src/ToySolver/Text/QDimacs.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Text.QDimacs -- Copyright : (c) Masahiro Sakai 2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/Text/SDPFile.hs b/src/ToySolver/Text/SDPFile.hs --- a/src/ToySolver/Text/SDPFile.hs +++ b/src/ToySolver/Text/SDPFile.hs @@ -1,12 +1,17 @@ -{-# LANGUAGE CPP, ConstraintKinds, FlexibleContexts, GADTs, ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} ----------------------------------------------------------------------------- -- | -- Module : ToySolver.Text.SDPFile -- Copyright : (c) Masahiro Sakai 2012,2016 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : non-portable @@ -42,7 +47,7 @@ , denseMatrix , denseBlock , diagBlock - + -- * Rendering , renderData , renderSparseData @@ -62,21 +67,26 @@ import Data.Char import qualified Data.Foldable as F import Data.List (intersperse) +#if !MIN_VERSION_base(4,11,0) import Data.Monoid -import Data.Scientific (Scientific) -#if !MIN_VERSION_megaparsec(5,0,0) -import Data.Scientific (fromFloatDigits) #endif +import Data.Scientific (Scientific) import Data.Map (Map) import qualified Data.Map as Map import qualified Data.IntMap as IntMap import System.FilePath (takeExtension) import System.IO import qualified Text.Megaparsec as MegaParsec -#if MIN_VERSION_megaparsec(6,0,0) +#if MIN_VERSION_megaparsec(7,0,0) import Data.Word import Data.Void import Text.Megaparsec hiding (ParseError, oneOf) +import Text.Megaparsec.Byte +import qualified Text.Megaparsec.Byte.Lexer as Lexer +#elif MIN_VERSION_megaparsec(6,0,0) +import Data.Word +import Data.Void +import Text.Megaparsec hiding (ParseError, oneOf) import Text.Megaparsec.Byte hiding (oneOf) import qualified Text.Megaparsec.Byte as MegaParsec import qualified Text.Megaparsec.Byte.Lexer as Lexer @@ -93,12 +103,9 @@ #elif MIN_VERSION_megaparsec(6,0,0) type C e s m = (MonadParsec e s m, Token s ~ Word8) type ParseError = MegaParsec.ParseError Word8 Void -#elif MIN_VERSION_megaparsec(5,0,0) +#else type C e s m = (MonadParsec e s m, Token s ~ Char) type ParseError = MegaParsec.ParseError Char Dec -#else -type C e s m = (MonadParsec s m Char) -type ParseError = MegaParsec.ParseError #endif #if MIN_VERSION_megaparsec(7,0,0) @@ -255,7 +262,7 @@ let int' = int >>= \i -> optional sep >> return i xs <- many int' _ <- manyTill anyChar newline - return $ map fromIntegral xs + return $ map fromIntegral xs where sep = some (oneOf " \t(){},") @@ -326,10 +333,8 @@ real :: forall e s m. C e s m => m Scientific #if MIN_VERSION_megaparsec(6,0,0) real = Lexer.signed (return ()) Lexer.scientific -#elif MIN_VERSION_megaparsec(5,0,0) -real = Lexer.signed (return ()) Lexer.number #else -real = liftM (either fromInteger fromFloatDigits) $ Lexer.signed (return ()) $ Lexer.number +real = Lexer.signed (return ()) Lexer.number #endif #if MIN_VERSION_megaparsec(6,0,0) @@ -387,7 +392,7 @@ | (blkno, blk) <- zip [(1::Int)..] m, ((i,j),e) <- Map.toList blk, i <= j ] renderDenseMatrix :: Matrix -> Builder - renderDenseMatrix m = + renderDenseMatrix m = "{\n" <> mconcat [renderDenseBlock b s <> "\n" | (b,s) <- zip m (blockStruct prob)] <> "}\n" @@ -396,9 +401,9 @@ renderDenseBlock b s | s < 0 = " " <> renderVec [blockElem i i b | i <- [1 .. abs s]] - | otherwise = + | otherwise = " { " <> - sepByS [renderRow i | i <- [1..s]] ", " <> + sepByS [renderRow i | i <- [1..s]] ", " <> " }" where renderRow i = renderVec [blockElem i j b | j <- [1..s]] diff --git a/src/ToySolver/Text/WCNF.hs b/src/ToySolver/Text/WCNF.hs --- a/src/ToySolver/Text/WCNF.hs +++ b/src/ToySolver/Text/WCNF.hs @@ -4,7 +4,7 @@ -- Module : ToySolver.Text.WCNF -- Copyright : (c) Masahiro Sakai 2012 -- License : BSD-style --- +-- -- Maintainer : masahiro.sakai@gmail.com -- Stability : provisional -- Portability : portable diff --git a/src/ToySolver/Version.hs b/src/ToySolver/Version.hs --- a/src/ToySolver/Version.hs +++ b/src/ToySolver/Version.hs @@ -1,4 +1,17 @@ -{-# LANGUAGE CPP, TemplateHaskell #-} +{-# OPTIONS_HADDOCK show-extensions #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Version +-- Copyright : (c) Masahiro Sakai 2013 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.Version ( version , packageVersions @@ -15,6 +28,9 @@ packageVersions :: [(String, String)] packageVersions = sort $ tail [ (undefined, undefined) -- dummy +#ifdef VERSION_MIP + , ("MIP", VERSION_MIP) +#endif #ifdef VERSION_OpenCL , ("OpenCL", VERSION_OpenCL) #endif diff --git a/src/ToySolver/Version/TH.hs b/src/ToySolver/Version/TH.hs --- a/src/ToySolver/Version/TH.hs +++ b/src/ToySolver/Version/TH.hs @@ -1,5 +1,18 @@ -{-# LANGUAGE ScopedTypeVariables, TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_HADDOCK show-extensions #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Version.TH +-- Copyright : (c) Masahiro Sakai 2015 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : non-portable +-- +----------------------------------------------------------------------------- module ToySolver.Version.TH ( gitHashQ , compilationTimeQ @@ -15,7 +28,7 @@ getGitHash = liftM (Just . takeWhile (/='\n')) (readProcess "git" ["rev-parse", "--short", "HEAD"] "") `catch` \(_::SomeException) -> return Nothing - + gitHashQ :: ExpQ gitHashQ = do m <- runIO getGitHash diff --git a/src/ToySolver/Wang.hs b/src/ToySolver/Wang.hs --- a/src/ToySolver/Wang.hs +++ b/src/ToySolver/Wang.hs @@ -1,4 +1,15 @@ {-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : ToySolver.Wang +-- Copyright : (c) Masahiro Sakai 2012 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Stability : provisional +-- Portability : portable +-- +----------------------------------------------------------------------------- module ToySolver.Wang ( Formula , Sequent diff --git a/test/Test/AReal.hs b/test/Test/AReal.hs --- a/test/Test/AReal.hs +++ b/test/Test/AReal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.AReal (arealTestGroup) where import Data.Maybe @@ -54,7 +55,7 @@ -- bug? sample_rootAdd = p where - x = P.var X + x = P.var X p :: UPolynomial Rational p = rootAdd (x^2 - 2) (x^6 + 6*x^3 - 2*x^2 + 9) diff --git a/test/Test/AReal2.hs b/test/Test/AReal2.hs --- a/test/Test/AReal2.hs +++ b/test/Test/AReal2.hs @@ -63,7 +63,7 @@ forAll areals $ \c -> a * (b + c) == a * b + a * c -prop_mult_zero = +prop_mult_zero = forAll areals $ \a -> 0 * a == 0 diff --git a/test/Test/Arith.hs b/test/Test/Arith.hs --- a/test/Test/Arith.hs +++ b/test/Test/Arith.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Arith (arithTestGroup) where import Control.Monad @@ -151,7 +152,7 @@ x <- elements (LA.unitVar : vs) c <- arbitrary return (c,x) - + genLAExprSmallInt :: [Var] -> Gen (LA.Expr Rational) genLAExprSmallInt vs = do size <- choose (0,3) @@ -171,7 +172,7 @@ rhs <- genLAExpr [1..nv] return $ ordRel op lhs rhs return (vs, cs) - + genQFLAConjSmallInt :: Gen (VarSet, [LA.Atom Rational]) genQFLAConjSmallInt = do nv <- choose (0, 3) @@ -191,7 +192,7 @@ return (x,val) ------------------------------------------------------------------------ - + prop_FourierMotzkin_solve :: Property prop_FourierMotzkin_solve = forAll genQFLAConj $ \(vs,cs) -> @@ -200,7 +201,7 @@ Just m -> property $ all (LA.eval m) cs case_FourierMotzkin_test1 :: Assertion -case_FourierMotzkin_test1 = +case_FourierMotzkin_test1 = case uncurry FourierMotzkin.solve test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -208,7 +209,7 @@ LA.eval m a @?= True case_FourierMotzkin_test2 :: Assertion -case_FourierMotzkin_test2 = +case_FourierMotzkin_test2 = case uncurry FourierMotzkin.solve test2' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -229,7 +230,7 @@ -} case_FourierMotzkinOptimization_test1 :: Assertion case_FourierMotzkinOptimization_test1 = do - Interval.upperBound' i @?= (3005/24, True) + Interval.upperBound' i @?= (3005/24, Interval.Closed) and [LA.eval m c | c <- cs] @?= True where (i, f) = FMOpt.optimize (IS.fromList vs) OptMax obj cs @@ -249,7 +250,7 @@ ] ------------------------------------------------------------------------ - + prop_VirtualSubstitution_solve :: Property prop_VirtualSubstitution_solve = forAll genQFLAConj $ \(vs,cs) -> @@ -258,7 +259,7 @@ Just m -> property $ all (LA.eval m) cs case_VirtualSubstitution_test1 :: Assertion -case_VirtualSubstitution_test1 = +case_VirtualSubstitution_test1 = case uncurry VirtualSubstitution.solve test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -266,7 +267,7 @@ LA.eval m a @?= True case_VirtualSubstitution_test2 :: Assertion -case_VirtualSubstitution_test2 = +case_VirtualSubstitution_test2 = case uncurry VirtualSubstitution.solve test2' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -274,7 +275,7 @@ LA.eval m a @?= True ------------------------------------------------------------------------ - + -- too slow disabled_prop_CAD_solve :: Property disabled_prop_CAD_solve = @@ -289,7 +290,7 @@ Just m -> property $ all (evalPAtom m) cs' case_CAD_test1 :: Assertion -case_CAD_test1 = +case_CAD_test1 = case CAD.solve vs cs of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -300,7 +301,7 @@ cs = map toPRel $ snd test1' case_CAD_test2 :: Assertion -case_CAD_test2 = +case_CAD_test2 = case CAD.solve vs cs of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> @@ -346,7 +347,7 @@ Just m -> property $ all (LA.eval (fmap fromInteger m :: Model Rational)) cs case_OmegaTest_test1 :: Assertion -case_OmegaTest_test1 = +case_OmegaTest_test1 = case uncurry (OmegaTest.solve def) test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do @@ -354,7 +355,7 @@ LA.eval (IM.map fromInteger m :: Model Rational) a @?= True case_OmegaTest_test2 :: Assertion -case_OmegaTest_test2 = +case_OmegaTest_test2 = case uncurry (OmegaTest.solve def) test2' of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return () @@ -379,7 +380,7 @@ Just m -> property $ all (LA.eval (fmap fromInteger m :: Model Rational)) cs case_Cooper_test1 :: Assertion -case_Cooper_test1 = +case_Cooper_test1 = case uncurry Cooper.solve test1' of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do @@ -387,13 +388,13 @@ LA.eval (IM.map fromInteger m :: Model Rational) a @?= True case_Cooper_test2 :: Assertion -case_Cooper_test2 = +case_Cooper_test2 = case uncurry Cooper.solve test2' of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return () ------------------------------------------------------------------------ - + prop_Simplex_solve :: Property prop_Simplex_solve = forAll genQFLAConj $ \(vs,cs) -> do case SimplexSimple.check vs cs of @@ -458,12 +459,73 @@ case ret of Nothing -> return () Just e -> do + QM.monitor (counterexample (show e)) ret2 <- f (`IS.member` e) - QM.assert (ret2 == Just e) - forM_ (IS.toList e) $ \i -> do - ret3 <- f (`IS.member` (IS.delete i e)) - QM.assert (isNothing ret3) + case ret2 of + Nothing -> QM.assert False + Just e2 -> do + QM.monitor (counterexample (show e2)) + if Simplex.configEnableBoundTightening config then do + QM.assert (e2 `IS.isSubsetOf` e) + else do + -- minimality of e is ensured only when bound-tightening is disabled + QM.assert (e2 == e) + forM_ (IS.toList e) $ \i -> do + ret3 <- f (`IS.member` (IS.delete i e)) + QM.assert (isNothing ret3) + +case_Simplex_explain_1 :: Assertion +case_Simplex_explain_1 = do + let vs = IS.fromList [1,2,3] + cs = + [ OrdRel (LA.fromTerms [(1746056284631 / 9826412301665,-1),(15203152363938 / 2590082592775,3)]) Lt (LA.fromTerms [((-10805767966036066790492005) / 2717766383823209137090944,1),((-6954371332529) / 2556884703077,3)]) + , OrdRel (LA.fromTerms [((-46318513084543) / 2825954452605,-1),((-84836161104808) / 6821232664449,3)]) Lt (LA.fromTerms [((-32878986163057639423497343) / 6340282666298520092181187,-1),((-2102058562915) / 152354534193,2)]) + , OrdRel (LA.fromTerms [(800927333029 / 343631592637,1)]) Eql (LA.fromTerms [(12974358287795 / 1163880192697,1),((-26182414536409) / 2543710855391,2)]) + , OrdRel (LA.fromTerms [((-83492509556885) / 8651844058708,1)]) Ge (LA.fromTerms [((-356015815369) / 22673757336,2),((-27476085033935) / 4622007003834,3)]) + , OrdRel (LA.fromTerms [((-39875095304489) / 3101412109143,-1),(28185656388712 / 2199966699027,2)]) Eql (LA.fromTerms []) + ] + config = + Simplex.Config + { Simplex.configPivotStrategy = Simplex.PivotStrategyBlandRule + , Simplex.configEnableBoundTightening = True + } + + let f p = do + solver <- Simplex.newSolver + Simplex.setConfig solver config + m <- liftM IM.fromList $ forM (IS.toList vs) $ \v -> do + v2 <- Simplex.newVar solver + return (v, LA.var v2) + forM (zip [0..] cs) $ \(i,c) -> do + when (p i) $ + Simplex.assertAtomEx' solver (LA.applySubstAtom m c) (Just i) + ret <- Simplex.check solver + if ret then do + return Nothing + else do + liftM Just $ Simplex.explain solver + + ret <- f (const True) + case ret of + Nothing -> return () + Just e -> do + ret2 <- f (`IS.member` e) + case ret2 of + Nothing -> assertFailure (show e ++ " should be unsatisfiable") + Just e2 -> do + if Simplex.configEnableBoundTightening config then do + assertBool (show e2 ++ " should be subset of " ++ show e) (e2 `IS.isSubsetOf` e) + else do + -- minimality of e is ensured only when bound-tightening is disabled + e2 @?= e + forM_ (IS.toList e) $ \i -> do + ret3 <- f (`IS.member` (IS.delete i e)) + case ret3 of + Nothing -> return () + Just e3 -> assertFailure (show i ++ " is redundant in " ++ show e ++ " (" ++ show e3 ++ " is smaller explanation)") + + instance Arbitrary Simplex.Config where arbitrary = do ps <- arbitrary @@ -482,7 +544,7 @@ -- Too slow disabled_case_ContiTraverso_test1 :: Assertion -disabled_case_ContiTraverso_test1 = +disabled_case_ContiTraverso_test1 = case ContiTraverso.solve P.grlex (fst test1') OptMin (LA.constant 0) (snd test1') of Nothing -> assertFailure "expected: Just\n but got: Nothing" Just m -> do @@ -490,7 +552,7 @@ LA.eval (IM.map fromInteger m :: Model Rational) a @?= True disabled_case_ContiTraverso_test2 :: Assertion -disabled_case_ContiTraverso_test2 = +disabled_case_ContiTraverso_test2 = case ContiTraverso.solve P.grlex (fst test2') OptMin (LA.constant 0) (snd test2') of Just _ -> assertFailure "expected: Nothing\n but got: Just" Nothing -> return () diff --git a/test/Test/BipartiteMatching.hs b/test/Test/BipartiteMatching.hs --- a/test/Test/BipartiteMatching.hs +++ b/test/Test/BipartiteMatching.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.BipartiteMatching (bipartiteMatchingTestGroup) where import Control.Monad diff --git a/test/Test/BitVector.hs b/test/Test/BitVector.hs --- a/test/Test/BitVector.hs +++ b/test/Test/BitVector.hs @@ -1,6 +1,6 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wall #-} module Test.BitVector (bitVectorTestGroup) where diff --git a/test/Test/BoolExpr.hs b/test/Test/BoolExpr.hs --- a/test/Test/BoolExpr.hs +++ b/test/Test/BoolExpr.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.BoolExpr (boolExprTestGroup) where import Test.QuickCheck.Function diff --git a/test/Test/CNF.hs b/test/Test/CNF.hs --- a/test/Test/CNF.hs +++ b/test/Test/CNF.hs @@ -1,11 +1,10 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.CNF (cnfTestGroup) where -import Control.Monad import Data.ByteString.Builder import Test.Tasty import Test.Tasty.QuickCheck diff --git a/test/Test/CongruenceClosure.hs b/test/Test/CongruenceClosure.hs --- a/test/Test/CongruenceClosure.hs +++ b/test/Test/CongruenceClosure.hs @@ -33,7 +33,7 @@ merge solver (TApp a []) (TApp c []) ret <- areCongruent solver (TApp a [TApp b []]) (TApp c [TApp d []]) ret @?= False - + merge solver (TApp b []) (TApp d []) ret <- areCongruent solver (TApp a [TApp b []]) (TApp c [TApp d []]) ret @?= True @@ -49,11 +49,11 @@ mergeFlatTerm solver (FTConst a) c ret <- areCongruentFlatTerm solver (FTApp a b) (FTApp c d) ret @?= False - + mergeFlatTerm solver (FTConst b) d ret <- areCongruentFlatTerm solver (FTApp a b) (FTApp c d) ret @?= True - + case_Example_2 :: Assertion case_Example_2 = do solver <- newSolver @@ -62,14 +62,14 @@ c <- newConst solver f <- newFun solver g <- newFun solver - h <- newFun solver - + h <- newFun solver + merge solver (f b) c merge solver (f c) a merge solver (g a) (h a a) ret <- areCongruent solver (g b) (h c b) ret @?= False - + merge solver b c ret <- areCongruent solver (g b) (h c b) ret @?= True @@ -88,7 +88,7 @@ case_NO2007_Example_16 = do solver <- newSolver a <- newFSym solver - b <- newFSym solver + b <- newFSym solver c <- newFSym solver d <- newFSym solver e <- newFSym solver @@ -130,7 +130,7 @@ ret <- areCongruentFlatTerm solver (FTConst a2) (FTConst b2) ret @?= False ret <- areCongruentFlatTerm solver (FTApp a1 a2) (FTApp b1 b2) - ret @?= False + ret @?= False popBacktrackPoint solver case_backtracking_preserve_definition :: Assertion @@ -144,7 +144,7 @@ a <- flatTermToFSym solver (FTApp a1 a2) b <- flatTermToFSym solver (FTApp b1 b2) popBacktrackPoint solver - c <- newFSym solver + c <- newFSym solver mergeFlatTerm solver (FTApp a1 a2) c mergeFlatTerm solver (FTApp b1 b2) c ret <- areCongruentFlatTerm solver (FTConst a) (FTConst b) diff --git a/test/Test/Converter.hs b/test/Test/Converter.hs --- a/test/Test/Converter.hs +++ b/test/Test/Converter.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Converter (converterTestGroup) where import Control.Monad @@ -9,6 +11,7 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.IntMap.Strict as IntMap import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet import qualified Data.Vector.Generic as VG @@ -21,7 +24,8 @@ import ToySolver.Converter import qualified ToySolver.FileFormat.CNF as CNF -import qualified ToySolver.MaxCut as MaxCut +import ToySolver.Graph.Base +import qualified ToySolver.Graph.MaxCut as MaxCut import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT @@ -33,21 +37,21 @@ prop_sat2naesat_forward :: Property prop_sat2naesat_forward = forAll arbitraryCNF $ \cnf -> let ret@(nae,info) = sat2naesat cnf - in counterexample (show ret) $ + in counterexample (show ret) $ forAllAssignments (CNF.cnfNumVars cnf) $ \m -> evalCNF m cnf === evalNAESAT (transformForward info m) nae prop_sat2naesat_backward :: Property prop_sat2naesat_backward = forAll arbitraryCNF $ \cnf -> let ret@(nae,info) = sat2naesat cnf - in counterexample (show ret) $ + in counterexample (show ret) $ forAllAssignments (fst nae) $ \m -> evalCNF (transformBackward info m) cnf === evalNAESAT m nae prop_naesat2sat_forward :: Property prop_naesat2sat_forward = forAll arbitraryNAESAT $ \nae -> let ret@(cnf,info) = naesat2sat nae - in counterexample (show ret) $ + in counterexample (show ret) $ forAllAssignments (fst nae) $ \m -> evalNAESAT m nae === evalCNF (transformForward info m) cnf @@ -141,6 +145,92 @@ ------------------------------------------------------------------------ +prop_satToIS_forward :: Property +prop_satToIS_forward = + forAll arbitraryCNF $ \cnf -> do + let r@((g,k), info) = satToIS cnf + in counterexample (show r) $ conjoin + [ counterexample (show m) $ counterexample (show set) $ + not (evalCNF m cnf) || (isIndependentSet g set && IntSet.size set >= k) + | m <- allAssignments (CNF.cnfNumVars cnf) + , let set = transformForward info m + ] + +prop_satToIS_backward :: Property +prop_satToIS_backward = + forAll arbitraryCNF $ \cnf -> do + let r@((g,k), info) = satToIS cnf + in counterexample (show r) $ + forAll (oneof [arbitraryIndependentSet g, arbitraryIndependentSet' g k]) $ \set -> do + let m = transformBackward info set + in counterexample (show m) $ + not (IntSet.size set >= k) || evalCNF m cnf + +prop_mis2MaxSAT_forward :: Property +prop_mis2MaxSAT_forward = + forAll arbitraryGraph $ \g -> do + let r@(wcnf, info) = mis2MaxSAT g + in counterexample (show r) $ conjoin + [ counterexample (show set) $ counterexample (show m) $ o1 === o2 + | set <- map IntSet.fromList $ allSubsets $ range $ bounds g + , let m = transformForward info set + o1 = if isIndependentSet g set + then Just (transformObjValueForward info (IntSet.size set)) + else Nothing + o2 = evalWCNF m wcnf + ] + where + allSubsets :: [a] -> [[a]] + allSubsets = filterM (const [False, True]) + +prop_mis2MaxSAT_backward :: Property +prop_mis2MaxSAT_backward = + forAll arbitraryGraph $ \g -> do + let r@(wcnf, info) = mis2MaxSAT g + in counterexample (show r) $ conjoin + [ counterexample (show m) $ counterexample (show set) $ o1 === o2 + | m <- allAssignments (CNF.wcnfNumVars wcnf) + , let set = transformBackward info m + o1 = if isIndependentSet g set + then Just (IntSet.size set) + else Nothing + o2 = fmap (transformObjValueBackward info) $ evalWCNF m wcnf + ] + +arbitraryGraph :: Gen Graph +arbitraryGraph = do + n <- choose (0, 8) -- inclusive range + es <- liftM concat $ forM [0..n-1] $ \v1 -> do + vs <- sublistOf [0..n-1] + return [(v1, v2, ()) | v2 <- vs] + return $ graphFromUnorderedEdges n es + +arbitraryIndependentSet :: Graph -> Gen IntSet +arbitraryIndependentSet g = do + s <- arbitraryMaximalIndependentSet g + liftM IntSet.fromList $ sublistOf $ IntSet.toList s + +arbitraryIndependentSet' :: Graph -> Int -> Gen IntSet +arbitraryIndependentSet' g k = go IntSet.empty (IntSet.fromList (range (bounds g))) + where + go s c + | IntSet.size s >= k = return s + | IntSet.null c = return s + | otherwise = do + a <- elements (IntSet.toList c) + go (IntSet.insert a s) (IntSet.delete a c IntSet.\\ (IntMap.keysSet (g ! a))) + +arbitraryMaximalIndependentSet :: Graph -> Gen IntSet +arbitraryMaximalIndependentSet g = go IntSet.empty (IntSet.fromList (range (bounds g))) + where + go s c + | IntSet.null c = return s + | otherwise = do + a <- elements (IntSet.toList c) + go (IntSet.insert a s) (IntSet.delete a c IntSet.\\ (IntMap.keysSet (g ! a))) + +------------------------------------------------------------------------ + prop_pb2sat :: Property prop_pb2sat = QM.monadicIO $ do pb@(nv,cs) <- QM.pick arbitraryPB @@ -233,11 +323,19 @@ cs2 = map f (PBFile.pbConstraints opb) pb = (PBFile.pbNumVars opb, obj, cs2) + QM.monitor $ counterexample (show wbo') + QM.monitor $ counterexample (show opb) + + -- no constant terms in objective function + QM.assert $ all (\(_,ls) -> length ls > 0) obj + solver1 <- arbitrarySolver solver2 <- arbitrarySolver method <- QM.pick arbitrary ret1 <- QM.run $ optimizeWBO solver1 method wbo ret2 <- QM.run $ optimizePBNLC solver2 method pb + QM.monitor $ counterexample (show ret1) + QM.monitor $ counterexample (show ret2) QM.assert $ isJust ret1 == isJust ret2 case ret1 of Nothing -> return () @@ -293,7 +391,7 @@ Just o -> SAT.evalPBFormula (transformBackward info m) pb === Just o Nothing -> property True ] - where + where collectTerms :: PBFile.Formula -> Set IntSet collectTerms formula = Set.fromList [t' | t <- terms, let t' = IntSet.fromList t, IntSet.size t' >= 3] where diff --git a/test/Test/Delta.hs b/test/Test/Delta.hs --- a/test/Test/Delta.hs +++ b/test/Test/Delta.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Delta (deltaTestGroup) where import Data.VectorSpace ((*^)) @@ -11,7 +12,7 @@ -- --------------------------------------------------------------------- -- Delta - + instance Arbitrary r => Arbitrary (Delta r) where arbitrary = do r <- arbitrary @@ -72,12 +73,12 @@ a * (b + c) == a * b + a * c prop_Delta_mult_zero :: Property -prop_Delta_mult_zero = +prop_Delta_mult_zero = forAll arbitrary $ \(a :: Delta Rational) -> 0 * a == 0 prop_Delta_scale_mult :: Property -prop_Delta_scale_mult = +prop_Delta_scale_mult = forAll arbitrary $ \(a :: Delta Rational) -> forAll arbitrary $ \b -> Delta.fromReal a * b == a *^ b diff --git a/test/Test/FiniteModelFinder.hs b/test/Test/FiniteModelFinder.hs --- a/test/Test/FiniteModelFinder.hs +++ b/test/Test/FiniteModelFinder.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.FiniteModelFinder (fmfTestGroup) where import Control.Monad diff --git a/test/Test/GraphShortestPath.hs b/test/Test/GraphShortestPath.hs --- a/test/Test/GraphShortestPath.hs +++ b/test/Test/GraphShortestPath.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.GraphShortestPath (graphShortestPathTestGroup) where import Control.Monad @@ -11,20 +12,20 @@ import Test.Tasty.QuickCheck hiding ((.&&.), (.||.)) import Test.Tasty.TH import ToySolver.Graph.ShortestPath -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import qualified Data.HashSet as HashSet +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.IntSet as IntSet -- ------------------------------------------------------------------------ type Vertex = Int type Cost = Rational type Label = Char - -genGraph :: Gen Cost -> Gen (HashMap Vertex [OutEdge Vertex Cost Label]) + +genGraph :: Gen Cost -> Gen (IntMap [OutEdge Cost Label]) genGraph genCost = do n <- choose (1, 20) -- inclusive - liftM HashMap.fromList $ forM [1..n] $ \i -> do + liftM IntMap.fromList $ forM [1..n] $ \i -> do m <- choose (0, min (n+1) 20) ys <- replicateM m $ do j <- choose (1, n) @@ -33,34 +34,34 @@ return (j,c,l) return (i, ys) -genGraphNonNegative :: Gen (HashMap Vertex [OutEdge Vertex Cost Label]) +genGraphNonNegative :: Gen (IntMap [OutEdge Cost Label]) genGraphNonNegative = genGraph (liftM getNonNegative arbitrary) isValidEdge - :: (Eq vertex, Hashable vertex, Eq cost, Eq label) - => HashMap vertex [OutEdge vertex cost label] - -> Edge vertex cost label + :: (Eq cost, Eq label) + => IntMap [OutEdge cost label] + -> Edge cost label -> Bool isValidEdge g (v,u,c,l) = - case HashMap.lookup v g of + case IntMap.lookup v g of Nothing -> False Just outs -> (u,c,l) `elem` outs isValidPath - :: (Eq vertex, Hashable vertex, Eq cost, Num cost, Eq label) - => HashMap vertex [OutEdge vertex cost label] - -> Path vertex cost label + :: (Eq cost, Num cost, Eq label) + => IntMap [OutEdge cost label] + -> Path cost label -> Bool isValidPath g = f where - f (Empty v) = v `HashMap.member` g + f (Empty v) = v `IntMap.member` g f (Singleton e) = isValidEdge g e f (Append p1 p2 c) = f p1 && f p2 && pathTo p1 == pathFrom p2 && pathCost p1 + pathCost p2 == c isValidNegativeCostCycle - :: (Eq vertex, Hashable vertex, Num cost, Ord cost, Eq label) - => HashMap vertex [OutEdge vertex cost label] - -> Path vertex cost label + :: (Num cost, Ord cost, Eq label) + => IntMap [OutEdge cost label] + -> Path cost label -> Bool isValidNegativeCostCycle g cyclePath = isValidPath g cyclePath && @@ -68,43 +69,43 @@ pathCost cyclePath < 0 isValidResult - :: (Eq vertex, Hashable vertex, Eq cost, Num cost, Eq label) - => HashMap vertex [OutEdge vertex cost label] - -> [vertex] - -> HashMap vertex (cost, Last (InEdge vertex cost label)) + :: (Eq cost, Num cost, Eq label) + => IntMap [OutEdge cost label] + -> [Vertex] + -> IntMap (cost, Last (InEdge cost label)) -> Bool -isValidResult g ss p = +isValidResult g ss p = and [ case m of - Nothing -> tc == 0 && u `HashSet.member` ss' - Just (v,c,l) -> isValidEdge g (v,u,c,l) && tc == fst (p HashMap.! v) + c - | (u, (tc,Last m)) <- HashMap.toList p + Nothing -> tc == 0 && u `IntSet.member` ss' + Just (v,c,l) -> isValidEdge g (v,u,c,l) && tc == fst (p IntMap.! v) + c + | (u, (tc,Last m)) <- IntMap.toList p ] where - ss' = HashSet.fromList ss + ss' = IntSet.fromList ss -- ------------------------------------------------------------------------ prop_bellmanFord_valid_path :: Property prop_bellmanFord_valid_path = forAll (genGraph arbitrary) $ \g -> - forAll (sublistOf (HashMap.keys g)) $ \ss -> + forAll (sublistOf (IntMap.keys g)) $ \ss -> and [ isValidPath g p && pathTo p == u && pathFrom p `elem` ss - | (u, (_,p)) <- HashMap.toList $ bellmanFord path g ss + | (u, (_,p)) <- IntMap.toList $ bellmanFord path g ss ] prop_dijkstra_valid_path :: Property prop_dijkstra_valid_path = forAll (genGraphNonNegative) $ \g -> - forAll (sublistOf (HashMap.keys g)) $ \ss -> + forAll (sublistOf (IntMap.keys g)) $ \ss -> and [ isValidPath g p && pathTo p == u && pathFrom p `elem` ss - | (u, (_,p)) <- HashMap.toList $ dijkstra path g ss + | (u, (_,p)) <- IntMap.toList $ dijkstra path g ss ] prop_floydWarshall_valid_path :: Property @@ -114,46 +115,46 @@ [ isValidPath g p && pathFrom p == u && pathTo p == v - | (u,m) <- HashMap.toList (floydWarshall path g) - , (v,(_,p)) <- HashMap.toList m + | (u,m) <- IntMap.toList (floydWarshall path g) + , (v,(_,p)) <- IntMap.toList m ] prop_dijkstra_equals_bellmanFord :: Property prop_dijkstra_equals_bellmanFord = forAll (genGraphNonNegative) $ \g -> - let vs = HashMap.keys g + let vs = IntMap.keys g in forAll (elements vs) $ \v -> forAll (elements vs) $ \u -> - (fmap (pathCost . snd) . HashMap.lookup u $ dijkstra path g [v]) + (fmap (pathCost . snd) . IntMap.lookup u $ dijkstra path g [v]) == - (fmap (pathCost . snd) . HashMap.lookup u $ bellmanFord path g [v]) + (fmap (pathCost . snd) . IntMap.lookup u $ bellmanFord path g [v]) prop_floydWarshall_equals_dijkstra :: Property prop_floydWarshall_equals_dijkstra = forAll (genGraphNonNegative) $ \g -> - let vs = HashMap.keys g + let vs = IntMap.keys g m = floydWarshall path g in forAll (elements vs) $ \v -> forAll (elements vs) $ \u -> - fmap (pathCost . snd) (HashMap.lookup u =<< HashMap.lookup v m) + fmap (pathCost . snd) (IntMap.lookup u =<< IntMap.lookup v m) == - fmap (pathCost . snd) (HashMap.lookup u $ dijkstra path g [v]) + fmap (pathCost . snd) (IntMap.lookup u $ dijkstra path g [v]) prop_floydWarshall_equals_bellmanFord :: Property prop_floydWarshall_equals_bellmanFord = forAll (genGraph arbitrary) $ \g -> - let vs = HashMap.keys g + let vs = IntMap.keys g ret1 = floydWarshall lastInEdge g in counterexample (show ret1) $ conjoin $ [ counterexample (show v) $ counterexample (show ret2) $ case bellmanFordDetectNegativeCycle path g ret2 of Just cyclePath -> conjoin - [ counterexample (show u) (fst (ret1 HashMap.! u HashMap.! u) < 0) + [ counterexample (show u) (fst (ret1 IntMap.! u IntMap.! u) < 0) | u <- pathVertexes cyclePath ] Nothing -> - fmap fst (HashMap.lookupDefault HashMap.empty v ret1) + fmap fst (IntMap.findWithDefault IntMap.empty v ret1) === fmap fst ret2 | v <- vs @@ -164,31 +165,32 @@ -- case_bellmanFord_test1 :: Assertion case_bellmanFord_test1 = do - let ret = bellmanFord lastInEdge g ['A'] + let ret = bellmanFord lastInEdge g [vA] ret @?= expected bellmanFordDetectNegativeCycle path g ret @?= Nothing where - g :: HashMap Char [(Char, Int, ())] - g = HashMap.fromList - [ ('A', [('B',-7,()), ('C',-9,())]) - , ('B', [('C',-8,()), ('D',-10,())]) - , ('C', [('D',4,())]) - , ('D', [('E',-3,())]) - , ('E', [('F',5,())]) - , ('F', [('C',-3,())]) + g :: IntMap [(Vertex, Int, ())] + g = IntMap.fromList + [ (vA, [(vB,-7,()), (vC,-9,())]) + , (vB, [(vC,-8,()), (vD,-10,())]) + , (vC, [(vD,4,())]) + , (vD, [(vE,-3,())]) + , (vE, [(vF,5,())]) + , (vF, [(vC,-3,())]) ] - expected = HashMap.fromList - [ ('A', (0, Last Nothing)) - , ('B', (-7, Last (Just ('A',-7,())))) - , ('C', (-18, Last (Just ('F',-3,())))) - , ('D', (-17, Last (Just ('B',-10,())))) - , ('E', (-20, Last (Just ('D',-3,())))) - , ('F', (-15, Last (Just ('E',5,())))) + [vA, vB, vC, vD, vE, vF] = [0..5] + expected = IntMap.fromList + [ (vA, (0, Last Nothing)) + , (vB, (-7, Last (Just (vA,-7,())))) + , (vC, (-18, Last (Just (vF,-3,())))) + , (vD, (-17, Last (Just (vB,-10,())))) + , (vE, (-20, Last (Just (vD,-3,())))) + , (vF, (-15, Last (Just (vE,5,())))) ] case_bellmanFord_normal :: Assertion case_bellmanFord_normal = do - let g = HashMap.fromListWith (++) $ + let g = IntMap.fromListWith (++) $ [(v,[(u,c,())]) | ((v,u),c) <- bellmanford_example_normal] m = bellmanFord lastInEdge g [24] assertBool (show m ++ " is not a valid result") $ isValidResult g [24] m @@ -558,11 +560,11 @@ case_bellmanFord_negativecost_cycle :: Assertion case_bellmanFord_negativecost_cycle = do - let g = HashMap.fromListWith (++) $ + let g = IntMap.fromListWith (++) $ [(v, [(u,c,())]) | ((v,u),c) <- bellmanford_example_negativecost_cycle] m = bellmanFord lastInEdge g [25] case bellmanFordDetectNegativeCycle path g m of - Nothing -> assertFailure ("negative cost cycle should be found (" ++ show m ++ ")") + Nothing -> assertFailure ("negative cost cycle should be found (" ++ show m ++ ")") Just cyclePath -> assertBool (show cyclePath ++ " should be valid negative cost cycle") $ isValidNegativeCostCycle g cyclePath bellmanford_example_negativecost_cycle :: [((Vertex, Vertex), Cost)] @@ -947,14 +949,14 @@ case_floydWarshall_normal :: Assertion case_floydWarshall_normal = do fmap (fmap fst) m @?= expected - forM_ (HashMap.toList m) $ \(u,m1) -> do - forM_ (HashMap.toList m1) $ \(v,(_,p)) -> do + forM_ (IntMap.toList m) $ \(u,m1) -> do + forM_ (IntMap.toList m1) $ \(v,(_,p)) -> do pathFrom p @?= u pathTo p @?= v assertBool (show p ++ " is not a valid path") (isValidPath floydWarshall_example p) where m = floydWarshall path floydWarshall_example - expected = HashMap.fromListWith HashMap.union [(u, HashMap.singleton v c) | ((u,v),c) <- xs] + expected = IntMap.fromListWith IntMap.union [(u, IntMap.singleton v c) | ((u,v),c) <- xs] xs = [ ((1,1),0), ((1,2),-1), ((1,3),-2), ((1,4),0) , ((2,1),4), ((2,2),0), ((2,3),2), ((2,4),4) @@ -963,20 +965,13 @@ ] -- https://en.wikipedia.org/wiki/Floyd%E2%80%93Warshall_algorithm -floydWarshall_example :: HashMap Vertex [OutEdge Vertex Cost ()] -floydWarshall_example = HashMap.fromList +floydWarshall_example :: IntMap [OutEdge Cost ()] +floydWarshall_example = IntMap.fromList [ (1, [(3,-2,())]) , (2, [(1,4,()), (3,3,())]) , (3, [(4,2,())]) , (4, [(2,-1,())]) ] - --- ------------------------------------------------------------------------ - -#if !MIN_VERSION_QuickCheck(2,8,0) -sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> choose (False, True)) xs -#endif -- ------------------------------------------------------------------------ -- Test harness diff --git a/test/Test/HittingSets.hs b/test/Test/HittingSets.hs --- a/test/Test/HittingSets.hs +++ b/test/Test/HittingSets.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.HittingSets (hittingSetsTestGroup) where import Prelude hiding (all) @@ -180,7 +181,7 @@ [ Set.map (IntSet.insert y) f , Set.map (IntSet.insert z) g , Set.singleton (IntSet.fromList [y,z]) - ] + ] in HittingSet.minimalHittingSets h == h case_FredmanKhachiyan1996_condition_1_1_solve_L :: Assertion @@ -254,7 +255,7 @@ propGenerateCNFAndDNF :: (IntSet -> (IntSet -> Bool) -> Set IntSet -> Set IntSet -> (Set IntSet, Set IntSet)) -> Property -propGenerateCNFAndDNF impl = +propGenerateCNFAndDNF impl = forAll hyperGraph $ \g -> let vs = IntSet.unions $ Set.toList g f xs = any (\is -> not $ IntSet.null $ xs `IntSet.intersection` is) (Set.toList g) @@ -267,8 +268,8 @@ in all (`isPrimeImplicantOf` f) (Set.toList dnf) && all (`isPrimeImplicateOf` f) (Set.toList cnf) -propMinimalHittingSetsMinimality :: (Set IntSet -> Set IntSet) -> Property -propMinimalHittingSetsMinimality minimalHittingSets = +_propMinimalHittingSetsMinimality :: (Set IntSet -> Set IntSet) -> Property +_propMinimalHittingSetsMinimality minimalHittingSets = forAll hyperGraph $ \g -> forAll (elements (Set.toList (minimalHittingSets g))) $ \s -> if IntSet.null s then diff --git a/test/Test/Knapsack.hs b/test/Test/Knapsack.hs --- a/test/Test/Knapsack.hs +++ b/test/Test/Knapsack.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Knapsack (knapsackTestGroup) where import Control.Monad @@ -34,7 +35,7 @@ (v1,_,_) = KnapsackBB.solve items' lim' (v2,_,_) = KnapsackDPDense.solve items lim in v1 == v2 - + case_knapsack_DPSparse_1 :: Assertion case_knapsack_DPSparse_1 = KnapsackDPSparse.solve [(5::Int,4::Int), (6,5), (3,2)] 9 @?= (11, 9, [True,True,False]) diff --git a/test/Test/LPFile.hs b/test/Test/LPFile.hs deleted file mode 100644 --- a/test/Test/LPFile.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Test.LPFile (lpTestGroup) where - -import Control.Monad -import Data.Default.Class -import Data.List -import Data.Maybe -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Test.Tasty.TH -import ToySolver.Data.MIP.LPFile - -case_testdata = checkString "testdata" testdata -case_test_indicator = checkFile "samples/lp/test-indicator.lp" -case_test_qcp = checkFile "samples/lp/test-qcp.lp" -case_test_qcp2 = checkFile "samples/lp/test-qcp2.lp" -case_test_qp = checkFile "samples/lp/test-qp.lp" -case_empty_obj_1 = checkFile "samples/lp/empty_obj_1.lp" -case_empty_obj_2 = checkFile "samples/lp/empty_obj_2.lp" - ------------------------------------------------------------------------- --- Sample data - -testdata :: String -testdata = unlines - [ "Maximize" - , " obj: x1 + 2 x2 + 3 x3 + x4" - , "Subject To" - , " c1: - x1 + x2 + x3 + 10 x4 <= 20" - , " c2: x1 - 3 x2 + x3 <= 30" - , " c3: x2 - 3.5 x4 = 0" - , "Bounds" - , " 0 <= x1 <= 40" - , " 2 <= x4 <= 3" - , "General" - , " x4" - , "End" - ] - ------------------------------------------------------------------------- --- Utilities - -checkFile :: FilePath -> Assertion -checkFile fname = do - lp <- parseFile def fname - case render def lp of - Left err -> assertFailure ("render failure: " ++ err) - Right _ -> return () - -checkString :: String -> String -> Assertion -checkString name str = do - case parseString def name str of - Left err -> assertFailure $ show err - Right lp -> - case render def lp of - Left err -> assertFailure ("render failure: " ++ err) - Right _ -> return () - ------------------------------------------------------------------------- --- Test harness - -lpTestGroup :: TestTree -lpTestGroup = $(testGroupGenerator) diff --git a/test/Test/MIP.hs b/test/Test/MIP.hs deleted file mode 100644 --- a/test/Test/MIP.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.MIP (mipTestGroup) where - -import Algebra.PartialOrd -import Algebra.Lattice -import Data.Maybe -import qualified Data.Map as Map -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck -import Test.Tasty.TH -import ToySolver.Data.MIP (meetStatus) -import qualified ToySolver.Data.MIP as MIP -import qualified ToySolver.Data.MIP.Solution.CBC as CBCSol -import qualified ToySolver.Data.MIP.Solution.CPLEX as CPLEXSol -import qualified ToySolver.Data.MIP.Solution.GLPK as GLPKSol -import qualified ToySolver.Data.MIP.Solution.Gurobi as GurobiSol -import qualified ToySolver.Data.MIP.Solution.SCIP as SCIPSol - -prop_status_refl :: Property -prop_status_refl = forAll arbitrary $ \(x :: MIP.Status) -> do - x `leq` x - -prop_status_trans :: Property -prop_status_trans = - forAll arbitrary $ \(x :: MIP.Status) -> - forAll (upper x) $ \y -> - forAll (upper y) $ \z -> - x `leq` z - where - -- upper :: (PartialOrd a, Enum a, Bounded a) => a -> Gen a - upper a = elements [b | b <- [minBound .. maxBound], a `leq` b] - -prop_status_meet_idempotency :: Property -prop_status_meet_idempotency = - forAll arbitrary $ \(x :: MIP.Status) -> - x `meetStatus` x == x - -prop_status_meet_comm :: Property -prop_status_meet_comm = - forAll arbitrary $ \(x :: MIP.Status) y -> - x `meetStatus` y == y `meetStatus` x - -prop_status_meet_assoc :: Property -prop_status_meet_assoc = - forAll arbitrary $ \(x :: MIP.Status) y z -> - (x `meetStatus` y) `meetStatus` z == x `meetStatus` (y `meetStatus` z) - -prop_status_meet_leq :: Property -prop_status_meet_leq = - forAll arbitrary $ \(x :: MIP.Status) y -> -#if MIN_VERSION_lattices(2,0,0) - (x == (x `meetStatus` y)) == x `leq` y -#else - x `meetLeq` y == x `leq` y -#endif - -instance Arbitrary MIP.Status where - arbitrary = arbitraryBoundedEnum - -case_CBCSol :: Assertion -case_CBCSol = do - sol <- CBCSol.readFile "samples/lp/test-solution-cbc.txt" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just (-122.5) - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_CBCSol_infeasible :: Assertion -case_CBCSol_infeasible = do - sol <- CBCSol.readFile "samples/lp/test-solution-cbc-infeasible.txt" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusInfeasible - , MIP.solObjectiveValue = Just 0.00000000 - , MIP.solVariables = Map.fromList [("x", 0.11111111), ("y", 0), ("z", 0.33333333)] - } - -case_CBCSol_unbounded :: Assertion -case_CBCSol_unbounded = do - sol <- CBCSol.readFile "samples/lp/test-solution-cbc-unbounded.txt" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusInfeasibleOrUnbounded - , MIP.solObjectiveValue = Just 0.00000000 - , MIP.solVariables = Map.fromList [("x", 0), ("y", 0)] - } - -case_CPLEXSol :: Assertion -case_CPLEXSol = do - sol <- CPLEXSol.readFile "samples/lp/test-solution-cplex.sol" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_CPLEXSol_unbounded :: Assertion -case_CPLEXSol_unbounded = do - sol <- CPLEXSol.readFile "samples/lp/test-solution-cplex-unbounded.sol" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusUnbounded - , MIP.solObjectiveValue = Just 3.0 - , MIP.solVariables = Map.fromList [("x", 1.0), ("y", 2.0)] - } - -case_GLPKSol :: Assertion -case_GLPKSol = do - sol <- GLPKSol.readFile "samples/lp/test-solution-glpk.sol" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_GLPKSol_long_var :: Assertion -case_GLPKSol_long_var = do - sol <- GLPKSol.readFile "samples/lp/test-solution-glpk-long.sol" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1AAAAAAAAAAAAAAAAAAAAAAAAAAAA", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_GurobiSol :: Assertion -case_GurobiSol = do - sol <- GurobiSol.readFile "samples/lp/test-solution-gurobi.sol" - isJust (GurobiSol.solObjectiveValue sol) @?= True - GurobiSol.parse (GurobiSol.render sol) @?= sol - -case_SCIPSol :: Assertion -case_SCIPSol = do - sol <- SCIPSol.readFile "samples/lp/test-solution-scip.sol" - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -mipTestGroup :: TestTree -mipTestGroup = $(testGroupGenerator) diff --git a/test/Test/MIPSolver.hs b/test/Test/MIPSolver.hs --- a/test/Test/MIPSolver.hs +++ b/test/Test/MIPSolver.hs @@ -1,301 +1,125 @@ -{-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} module Test.MIPSolver (mipSolverTestGroup) where import Control.Monad -import Data.Default.Class -import qualified Data.Map as Map +import Data.List +import Data.Ratio +import qualified Data.IntMap as IM +import qualified Data.IntSet as IS +import Data.VectorSpace import Test.Tasty import Test.Tasty.HUnit -import qualified ToySolver.Data.MIP as MIP -import ToySolver.Data.MIP.Solver - --- ------------------------------------------------------------------------ - -case_cbc :: Assertion -case_cbc = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve cbc def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_cbc_unbounded :: Assertion -case_cbc_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve cbc def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] - -case_cbc_infeasible :: Assertion -case_cbc_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve cbc def prob - MIP.solStatus sol @?= MIP.StatusInfeasible - -case_cbc_infeasible2 :: Assertion -case_cbc_infeasible2 = do - prob <- MIP.readFile def "samples/lp/glpk-preprocess-bug.lp" - sol <- solve cbc def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusInfeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusInfeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] - --- ------------------------------------------------------------------------ - -case_cplex :: Assertion -case_cplex = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve cplex def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } - -case_cplex_unbounded :: Assertion -case_cplex_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve cplex def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] - -case_cplex_infeasible :: Assertion -case_cplex_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve cplex def prob - MIP.solStatus sol @?= MIP.StatusInfeasible - -case_cplex_infeasible2 :: Assertion -case_cplex_infeasible2 = do - prob <- MIP.readFile def "samples/lp/glpk-preprocess-bug.lp" - sol <- solve cplex def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusInfeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusInfeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] +import Test.Tasty.TH +import Text.Printf --- ------------------------------------------------------------------------ +import qualified ToySolver.Data.LA as LA +import qualified ToySolver.Arith.Simplex as Simplex +import ToySolver.Arith.Simplex +import qualified ToySolver.Arith.MIP as MIPSolver -case_glpsol :: Assertion -case_glpsol = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve glpsol def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } +------------------------------------------------------------------------ -case_glpsol_unbounded :: Assertion -case_glpsol_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve glpsol def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status +example1 :: (OptDir, LA.Expr Rational, [Atom Rational], IS.IntSet) +example1 = (optdir, obj, cs, ivs) + where + optdir = OptMax + x1 = LA.var 1 + x2 = LA.var 2 + x3 = LA.var 3 + x4 = LA.var 4 + obj = x1 ^+^ 2 *^ x2 ^+^ 3 *^ x3 ^+^ x4 + cs = + [ (-1) *^ x1 ^+^ x2 ^+^ x3 ^+^ 10*^x4 .<=. LA.constant 20 + , x1 ^-^ 3 *^ x2 ^+^ x3 .<=. LA.constant 30 + , x2 ^-^ 3.5 *^ x4 .==. LA.constant 0 + , LA.constant 0 .<=. x1 + , x1 .<=. LA.constant 40 + , LA.constant 0 .<=. x2 + , LA.constant 0 .<=. x3 + , LA.constant 2 .<=. x4 + , x4 .<=. LA.constant 3 ] - -case_glpsol_infeasible :: Assertion -case_glpsol_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve glpsol def prob - MIP.solStatus sol @?= MIP.StatusInfeasible + ivs = IS.singleton 4 --- ------------------------------------------------------------------------ +case_test1 = do + let (optdir, obj, cs, ivs) = example1 + lp <- Simplex.newSolver + replicateM 5 (Simplex.newVar lp) + setOptDir lp optdir + setObj lp obj + mapM_ (Simplex.assertAtom lp) cs + mip <- MIPSolver.newSolver lp ivs + ret <- MIPSolver.optimize mip -case_gurobiCl :: Assertion -case_gurobiCl = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve gurobiCl def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.50000000000006 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.500000000000018), ("x4", 3)] - } + ret @?= Simplex.Optimum -case_gurobiCl_unbounded :: Assertion -case_gurobiCl_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve gurobiCl def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] + Just m <- MIPSolver.getBestModel mip + forM_ [(1,40),(2,21/2),(3,39/2),(4,3)] $ \(var, val) -> + m IM.! var @?= val -case_gurobiCl_infeasible :: Assertion -case_gurobiCl_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve gurobiCl def prob - MIP.solStatus sol @?= MIP.StatusInfeasible + Just v <- MIPSolver.getBestValue mip + v @?= 245/2 -case_gurobiCl_infeasible2 :: Assertion -case_gurobiCl_infeasible2 = do - prob <- MIP.readFile def "samples/lp/glpk-preprocess-bug.lp" - sol <- solve gurobiCl def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusInfeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusInfeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] +case_test1' = do + let (optdir, obj, cs, ivs) = example1 + lp <- Simplex.newSolver + replicateM 5 (Simplex.newVar lp) + setOptDir lp (f optdir) + setObj lp (negateV obj) + mapM_ (Simplex.assertAtom lp) cs + mip <- MIPSolver.newSolver lp ivs + ret <- MIPSolver.optimize mip --- ------------------------------------------------------------------------ + ret @?= Simplex.Optimum -case_lpSolve :: Assertion -case_lpSolve = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve lpSolve def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } + Just m <- MIPSolver.getBestModel mip + forM_ [(1,40),(2,21/2),(3,39/2),(4,3)] $ \(var, val) -> + m IM.! var @?= val -case_lpSolve_unbounded :: Assertion -case_lpSolve_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve lpSolve def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] + Just v <- MIPSolver.getBestValue mip + v @?= -245/2 -case_lpSolve_infeasible :: Assertion -case_lpSolve_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve lpSolve def prob - MIP.solStatus sol @?= MIP.StatusInfeasible + where + f OptMin = OptMax + f OptMax = OptMin -case_lpSolve_infeasible2 :: Assertion -case_lpSolve_infeasible2 = do - prob <- MIP.readFile def "samples/lp/glpk-preprocess-bug.lp" - sol <- solve lpSolve def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusInfeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusInfeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status +-- 『数理計画法の基礎』(坂和 正敏) p.109 例 3.8 +example2 = (optdir, obj, cs, ivs) + where + optdir = OptMin + [x1,x2,x3] = map LA.var [1..3] + obj = (-1) *^ x1 ^-^ 3 *^ x2 ^-^ 5 *^ x3 + cs = + [ 3 *^ x1 ^+^ 4 *^ x2 .<=. LA.constant 10 + , 2 *^ x1 ^+^ x2 ^+^ x3 .<=. LA.constant 7 + , 3 *^ x1 ^+^ x2 ^+^ 4 *^ x3 .==. LA.constant 12 + , LA.constant 0 .<=. x1 + , LA.constant 0 .<=. x2 + , LA.constant 0 .<=. x3 ] - --- ------------------------------------------------------------------------ + ivs = IS.fromList [1,2] -case_scip :: Assertion -case_scip = do - prob <- MIP.readFile def "samples/lp/test.lp" - sol <- solve scip def prob - sol @?= - MIP.Solution - { MIP.solStatus = MIP.StatusOptimal - , MIP.solObjectiveValue = Just 122.5 - , MIP.solVariables = Map.fromList [("x1", 40), ("x2", 10.5), ("x3", 19.5), ("x4", 3)] - } +case_test2 = do + let (optdir, obj, cs, ivs) = example2 + lp <- Simplex.newSolver + replicateM 4 (Simplex.newVar lp) + setOptDir lp optdir + setObj lp obj + mapM_ (Simplex.assertAtom lp) cs + mip <- MIPSolver.newSolver lp ivs + ret <- MIPSolver.optimize mip -case_scip_unbounded :: Assertion -case_scip_unbounded = do - prob <- MIP.readFile def "samples/lp/unbounded-ip.lp" - sol <- solve scip def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusUnbounded || status == MIP.StatusFeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusUnbounded, StatusFeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] + ret @?= Simplex.Optimum -case_scip_infeasible :: Assertion -case_scip_infeasible = do - prob <- MIP.readFile def "samples/lp/infeasible.lp" - sol <- solve scip def prob - MIP.solStatus sol @?= MIP.StatusInfeasible + Just m <- MIPSolver.getBestModel mip + forM_ [(1,0),(2,2),(3,5/2)] $ \(var, val) -> + m IM.! var @?= val -case_scip_infeasible2 :: Assertion -case_scip_infeasible2 = do - prob <- MIP.readFile def "samples/lp/glpk-preprocess-bug.lp" - sol <- solve scip def prob - let status = MIP.solStatus sol - unless (status == MIP.StatusInfeasible || status == MIP.StatusInfeasibleOrUnbounded) $ - assertFailure $ unlines $ - [ "expected: StatusInfeasible or StatusInfeasibleOrUnbounded" - , " but got: " ++ show status - ] + Just v <- MIPSolver.getBestValue mip + v @?= -37/2 --- ------------------------------------------------------------------------ +------------------------------------------------------------------------ +-- Test harness mipSolverTestGroup :: TestTree -mipSolverTestGroup = testGroup "Test.MIPSolver" $ [] -#ifdef TEST_CBC - ++ - [ testCase "cbc" case_cbc - , testCase "cbc unbounded" case_cbc_unbounded - , testCase "cbc infeasible" case_cbc_infeasible - , testCase "cbc infeasible2" case_cbc_infeasible2 - ] -#endif -#ifdef TEST_CPLEX - ++ - [ testCase "cplex" case_cplex - , testCase "cplex unbounded" case_cplex_unbounded - , testCase "cplex infeasible" case_cplex_infeasible - , testCase "cplex infeasible2" case_cplex_infeasible2 - ] -#endif -#ifdef TEST_GLPSOL - ++ - [ testCase "glpsol" case_glpsol - , testCase "glpsol unbounded" case_glpsol_unbounded - , testCase "glpsol infeasible" case_glpsol_infeasible - ] -#endif -#ifdef TEST_GUROBI_CL - ++ - [ testCase "gurobiCl" case_gurobiCl - , testCase "gurobiCl unbounded" case_gurobiCl_unbounded - , testCase "gurobiCl infeasible" case_gurobiCl_infeasible - , testCase "gurobiCl infeasible2" case_gurobiCl_infeasible2 - ] -#endif -#ifdef TEST_LP_SOLVE - ++ - [ testCase "lpSolve" case_lpSolve - , testCase "lpSolve unbounded" case_lpSolve_unbounded - , testCase "lpSolve infeasible" case_lpSolve_infeasible - , testCase "lpSolve infeasible2" case_lpSolve_infeasible2 - ] -#endif -#ifdef TEST_SCIP - ++ - [ testCase "scip" case_scip - , testCase "scip unbounded" case_scip_unbounded - , testCase "scip infeasible" case_scip_infeasible - , testCase "scip infeasible2" case_scip_infeasible2 - ] -#endif - +mipSolverTestGroup = $(testGroupGenerator) diff --git a/test/Test/MIPSolver2.hs b/test/Test/MIPSolver2.hs deleted file mode 100644 --- a/test/Test/MIPSolver2.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Test.MIPSolver2 (mipSolver2TestGroup) where - -import Control.Monad -import Data.List -import Data.Ratio -import qualified Data.IntMap as IM -import qualified Data.IntSet as IS -import Data.VectorSpace -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.TH -import Text.Printf - -import qualified ToySolver.Data.LA as LA -import qualified ToySolver.Arith.Simplex as Simplex -import ToySolver.Arith.Simplex -import qualified ToySolver.Arith.MIP as MIPSolver - ------------------------------------------------------------------------- - -example1 :: (OptDir, LA.Expr Rational, [Atom Rational], IS.IntSet) -example1 = (optdir, obj, cs, ivs) - where - optdir = OptMax - x1 = LA.var 1 - x2 = LA.var 2 - x3 = LA.var 3 - x4 = LA.var 4 - obj = x1 ^+^ 2 *^ x2 ^+^ 3 *^ x3 ^+^ x4 - cs = - [ (-1) *^ x1 ^+^ x2 ^+^ x3 ^+^ 10*^x4 .<=. LA.constant 20 - , x1 ^-^ 3 *^ x2 ^+^ x3 .<=. LA.constant 30 - , x2 ^-^ 3.5 *^ x4 .==. LA.constant 0 - , LA.constant 0 .<=. x1 - , x1 .<=. LA.constant 40 - , LA.constant 0 .<=. x2 - , LA.constant 0 .<=. x3 - , LA.constant 2 .<=. x4 - , x4 .<=. LA.constant 3 - ] - ivs = IS.singleton 4 - -case_test1 = do - let (optdir, obj, cs, ivs) = example1 - lp <- Simplex.newSolver - replicateM 5 (Simplex.newVar lp) - setOptDir lp optdir - setObj lp obj - mapM_ (Simplex.assertAtom lp) cs - mip <- MIPSolver.newSolver lp ivs - ret <- MIPSolver.optimize mip - - ret @?= Simplex.Optimum - - Just m <- MIPSolver.getBestModel mip - forM_ [(1,40),(2,21/2),(3,39/2),(4,3)] $ \(var, val) -> - m IM.! var @?= val - - Just v <- MIPSolver.getBestValue mip - v @?= 245/2 - -case_test1' = do - let (optdir, obj, cs, ivs) = example1 - lp <- Simplex.newSolver - replicateM 5 (Simplex.newVar lp) - setOptDir lp (f optdir) - setObj lp (negateV obj) - mapM_ (Simplex.assertAtom lp) cs - mip <- MIPSolver.newSolver lp ivs - ret <- MIPSolver.optimize mip - - ret @?= Simplex.Optimum - - Just m <- MIPSolver.getBestModel mip - forM_ [(1,40),(2,21/2),(3,39/2),(4,3)] $ \(var, val) -> - m IM.! var @?= val - - Just v <- MIPSolver.getBestValue mip - v @?= -245/2 - - where - f OptMin = OptMax - f OptMax = OptMin - --- 『数理計画法の基礎』(坂和 正敏) p.109 例 3.8 -example2 = (optdir, obj, cs, ivs) - where - optdir = OptMin - [x1,x2,x3] = map LA.var [1..3] - obj = (-1) *^ x1 ^-^ 3 *^ x2 ^-^ 5 *^ x3 - cs = - [ 3 *^ x1 ^+^ 4 *^ x2 .<=. LA.constant 10 - , 2 *^ x1 ^+^ x2 ^+^ x3 .<=. LA.constant 7 - , 3 *^ x1 ^+^ x2 ^+^ 4 *^ x3 .==. LA.constant 12 - , LA.constant 0 .<=. x1 - , LA.constant 0 .<=. x2 - , LA.constant 0 .<=. x3 - ] - ivs = IS.fromList [1,2] - -case_test2 = do - let (optdir, obj, cs, ivs) = example2 - lp <- Simplex.newSolver - replicateM 4 (Simplex.newVar lp) - setOptDir lp optdir - setObj lp obj - mapM_ (Simplex.assertAtom lp) cs - mip <- MIPSolver.newSolver lp ivs - ret <- MIPSolver.optimize mip - - ret @?= Simplex.Optimum - - Just m <- MIPSolver.getBestModel mip - forM_ [(1,0),(2,2),(3,5/2)] $ \(var, val) -> - m IM.! var @?= val - - Just v <- MIPSolver.getBestValue mip - v @?= -37/2 - ------------------------------------------------------------------------- --- Test harness - -mipSolver2TestGroup :: TestTree -mipSolver2TestGroup = $(testGroupGenerator) diff --git a/test/Test/MPSFile.hs b/test/Test/MPSFile.hs deleted file mode 100644 --- a/test/Test/MPSFile.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Test.MPSFile (mpsTestGroup) where - -import Control.Monad -import Data.Default.Class -import Data.List -import Data.Maybe -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Test.Tasty.TH -import ToySolver.Data.MIP.MPSFile - -case_testdata = checkString "testdata" testdata -case_example2 = checkFile "samples/mps/example2.mps" -case_ind1 = checkFile "samples/mps/ind1.mps" -case_intvar1 = checkFile "samples/mps/intvar1.mps" -case_intvar2 = checkFile "samples/mps/intvar2.mps" -case_quadobj1 = checkFile "samples/mps/quadobj1.mps" -case_quadobj2 = checkFile "samples/mps/quadobj2.mps" -case_ranges = checkFile "samples/mps/ranges.mps" -case_sos = checkFile "samples/mps/sos.mps" -case_sc = checkFile "samples/mps/sc.mps" - ------------------------------------------------------------------------- --- Sample data - -testdata :: String -testdata = unlines - [ "NAME example2.mps" - , "ROWS" - , " N obj " - , " L c1 " - , " L c2 " - , "COLUMNS" - , " x1 obj -1 c1 -1" - , " x1 c2 1" - , " x2 obj -2 c1 1" - , " x2 c2 -3" - , " x3 obj -3 c1 1" - , " x3 c2 1" - , "RHS" - , " rhs c1 20 c2 30" - , "BOUNDS" - , " UP BOUND x1 40" - , "ENDATA" - ] - ------------------------------------------------------------------------- --- Utilities - -checkFile :: FilePath -> Assertion -checkFile fname = do - _ <- parseFile def fname - return () - -checkString :: String -> String -> Assertion -checkString name str = do - case parseString def name str of - Left err -> assertFailure (show err) - Right lp -> return () - ------------------------------------------------------------------------- --- Test harness - -mpsTestGroup :: TestTree -mpsTestGroup = $(testGroupGenerator) diff --git a/test/Test/Misc.hs b/test/Test/Misc.hs --- a/test/Test/Misc.hs +++ b/test/Test/Misc.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Misc (miscTestGroup) where import Control.Monad @@ -33,8 +34,8 @@ readUnsignedInteger "006666666666666667" @?= 6666666666666667 prop_readUnsignedInteger :: Property -prop_readUnsignedInteger = - forAll (choose (0, 2^(128::Int))) $ \i -> +prop_readUnsignedInteger = + forAll (choose (0, 2^(128::Int))) $ \i -> readUnsignedInteger (show i) == i -- --------------------------------------------------------------------- @@ -68,7 +69,7 @@ case_Vec_clone :: Assertion case_Vec_clone = do - (v::Vec.UVec Int) <- Vec.new + (v::Vec.UVec Int) <- Vec.new Vec.push v 0 v2 <- Vec.clone v Vec.write v2 0 1 diff --git a/test/Test/ProbSAT.hs b/test/Test/ProbSAT.hs --- a/test/Test/ProbSAT.hs +++ b/test/Test/ProbSAT.hs @@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.ProbSAT (probSATTestGroup) where import Control.Applicative @@ -17,7 +17,7 @@ import Test.QuickCheck.Modifiers import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT.Types as SAT -import qualified ToySolver.SAT.SLS.ProbSAT as ProbSAT +import qualified ToySolver.SAT.Solver.SLS.ProbSAT as ProbSAT import Test.SAT.Utils diff --git a/test/Test/QBF.hs b/test/Test/QBF.hs --- a/test/Test/QBF.hs +++ b/test/Test/QBF.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.QBF (qbfTestGroup) where import Control.Monad @@ -64,8 +65,8 @@ f lit = if lit > 0 then BoolExpr.Atom lit else notB (BoolExpr.Atom (abs lit)) - (sat1, cert1) <- QM.run $ QBF.solveCEGAR nv prefix matrix1' - (sat2, cert2) <- QM.run $ QBF.solveCEGAR nv (init prefix) matrix2' + (sat1, _cert1) <- QM.run $ QBF.solveCEGAR nv prefix matrix1' + (sat2, _cert2) <- QM.run $ QBF.solveCEGAR nv (init prefix) matrix2' QM.assert $ sat1 == sat2 where gen :: Gen (Int, QBF.Prefix, [[Int]]) @@ -76,7 +77,7 @@ q1 <- arbitrary q2 <- arbitrary vs1 <- IntSet.fromList <$> subsetof vs - vs2 <- IntSet.fromList <$> subsetof vs + vs2 <- IntSet.fromList <$> subsetof vs matrix <- replicateM nc $ do if nv == 0 then return [] @@ -136,7 +137,7 @@ return [] else replicateM len $ choose (-nv, nv) `suchThat` (/= 0) - + return ( nv , [(q1,vs1), (q2, vs2 IntSet.\\ vs1), (q3, IntSet.fromList vs IntSet.\\ (vs1 `IntSet.union` vs2))] diff --git a/test/Test/QUBO.hs b/test/Test/QUBO.hs --- a/test/Test/QUBO.hs +++ b/test/Test/QUBO.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.QUBO (quboTestGroup) where import Control.Monad diff --git a/test/Test/SAT.hs b/test/Test/SAT.hs --- a/test/Test/SAT.hs +++ b/test/Test/SAT.hs @@ -1,11 +1,17 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT (satTestGroup) where +import Control.Exception import Control.Monad import Data.Array.IArray import Data.Default.Class +import qualified Data.IntSet as IntSet +import Data.IORef +import qualified Data.Map.Strict as Map import qualified Data.Vector as V import qualified System.Random.MWC as Rand @@ -369,7 +375,7 @@ ret @?= lUndef SAT.addClause solver [-x1] - + ret <- SAT.getVarFixed solver x1 ret @?= lFalse @@ -391,7 +397,7 @@ ret <- SAT.solveWith solver [-x2] ret @?= True xs <- SAT.getAssumptionsImplications solver - xs @?= [x3] + xs @?= IntSet.singleton x3 prop_getAssumptionsImplications :: Property prop_getAssumptionsImplications = QM.monadicIO $ do @@ -403,7 +409,7 @@ forM_ (CNF.cnfClauses cnf) $ \c -> SAT.addClause solver (SAT.unpackClause c) SAT.solveWith solver ls when ret $ do - xs <- QM.run $ SAT.getAssumptionsImplications solver + xs <- liftM IntSet.toList $ QM.run $ SAT.getAssumptionsImplications solver forM_ xs $ \x -> do ret2 <- QM.run $ SAT.solveWith solver (-x : ls) QM.assert $ not ret2 @@ -589,6 +595,67 @@ conflict: [-4,-12] conflict analysis yields [] and that causes error -} + +------------------------------------------------------------------------ + +pigeonHole :: SAT.Solver -> Integer -> Integer -> IO () +pigeonHole solver p h = do + vs <- liftM Map.fromList $ forM [(i,j) | i <- [1..p], j <- [1..h]] $ \(i,j) -> do + v <- SAT.newVar solver + return ((i,j), v) + forM_ [1..p] $ \i -> do + SAT.addAtLeast solver [vs Map.! (i,j) | j <- [1..h]] 1 + forM_ [1..h] $ \j -> do + SAT.addAtMost solver [vs Map.! (i,j) | i<-[1..p]] 1 + return () + +case_setTerminateCallback :: IO () +case_setTerminateCallback = do + solver <- SAT.newSolver + SAT.setTerminateCallback solver (return True) + + pigeonHole solver 5 4 + + m <- try (SAT.solve solver) + case m of + Left (e :: SAT.Canceled) -> return () + Right x -> assertFailure ("Canceled should be thrown: " ++ show x) + +case_clearTerminateCallback :: IO () +case_clearTerminateCallback = do + solver <- SAT.newSolver + SAT.setTerminateCallback solver (return True) + + pigeonHole solver 5 4 + + SAT.clearTerminateCallback solver + _ <- SAT.solve solver + return () + +case_setLearnCallback :: IO () +case_setLearnCallback = do + solver <- SAT.newSolver + learntRef <- newIORef [] + SAT.setLearnCallback solver (\clause -> modifyIORef learntRef (clause:)) + + pigeonHole solver 5 4 + + _ <- SAT.solve solver + learnt <- readIORef learntRef + assertBool "learn callback should have been called" (not (null learnt)) + +case_clearLearnCallback :: IO () +case_clearLearnCallback = do + solver <- SAT.newSolver + learntRef <- newIORef [] + SAT.setLearnCallback solver (\clause -> modifyIORef learntRef (clause:)) + + pigeonHole solver 5 4 + + SAT.clearLearnCallback solver + _ <- SAT.solve solver + learnt <- readIORef learntRef + assertBool "learn callback should not have been called" (null learnt) ------------------------------------------------------------------------ -- Test harness diff --git a/test/Test/SAT/Encoder.hs b/test/Test/SAT/Encoder.hs --- a/test/Test/SAT/Encoder.hs +++ b/test/Test/SAT/Encoder.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.Encoder (satEncoderTestGroup) where import Control.Monad @@ -17,11 +19,13 @@ import ToySolver.Data.BoolExpr import ToySolver.Data.Boolean +import ToySolver.Data.LBool import qualified ToySolver.FileFormat.CNF as CNF import qualified ToySolver.SAT as SAT import qualified ToySolver.SAT.Types as SAT import qualified ToySolver.SAT.Encoder.Tseitin as Tseitin import qualified ToySolver.SAT.Encoder.Cardinality as Cardinality +import qualified ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer as Totalizer import qualified ToySolver.SAT.Encoder.PB as PB import qualified ToySolver.SAT.Encoder.PB.Internal.Sorter as PBEncSorter import qualified ToySolver.SAT.Store.CNF as CNFStore @@ -173,7 +177,7 @@ rhs <- choose (-1, nv+2) return $ (lhs, rhs) strategy <- QM.pick arbitrary - (cnf,defs) <- QM.run $ do + (cnf,defs,defs2) <- QM.run $ do db <- CNFStore.newCNFStore SAT.newVars_ db nv tseitin <- Tseitin.newEncoder db @@ -181,13 +185,130 @@ SAT.addAtLeast card lhs rhs cnf <- CNFStore.getCNFFormula db defs <- Tseitin.getDefinitions tseitin - return (cnf, defs) + defs2 <- Cardinality.getTotalizerDefinitions card + return (cnf, defs, defs2) forM_ (allAssignments nv) $ \m -> do let m2 :: Array SAT.Var Bool - m2 = array (1, CNF.cnfNumVars cnf) $ assocs m ++ [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs] + m2 = array (1, CNF.cnfNumVars cnf) $ + assocs m ++ + [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs] ++ + Cardinality.evalTotalizerDefinitions m2 defs2 b1 = SAT.evalAtLeast m (lhs,rhs) b2 = evalCNF (array (bounds m2) (assocs m2)) cnf QM.assert $ b1 == b2 + + +case_Totalizer_unary :: Assertion +case_Totalizer_unary = do + solver <- SAT.newSolver + tseitin <- Tseitin.newEncoder solver + totalizer <- Totalizer.newEncoder tseitin + SAT.newVars_ solver 5 + xs <- Totalizer.encodeSum totalizer [1,2,3,4,5] + SAT.addClause solver [xs !! 2] + SAT.addClause solver [- (xs !! 1)] + ret <- SAT.solve solver + ret @?= False + + +-- -- This does not hold: +-- case_Totalizer_pre_unary :: Assertion +-- case_Totalizer_pre_unary = do +-- solver <- SAT.newSolver +-- tseitin <- Tseitin.newEncoder solver +-- totalizer <- Totalizer.newEncoder tseitin +-- SAT.newVars_ solver 5 +-- xs <- Totalizer.encodeSum totalizer [1,2,3,4,5] +-- SAT.addClause solver [xs !! 2] +-- v0 <- SAT.getLitFixed solver (xs !! 0) +-- v1 <- SAT.getLitFixed solver (xs !! 1) +-- v0 @?= lTrue +-- v1 @?= lTrue + + +prop_Totalizer_forward_propagation :: Property +prop_Totalizer_forward_propagation = QM.monadicIO $ do + nv <- QM.pick $ choose (2, 10) -- inclusive range + let xs = [1..nv] + (xs1, xs2) <- QM.pick $ do + cs <- forM xs $ \x -> do + c <- arbitrary + return (x,c) + return ([x | (x, Just True) <- cs], [x | (x, Just False) <- cs]) + let p = length xs1 + q = length xs2 + lbs <- QM.run $ do + solver <- SAT.newSolver + tseitin <- Tseitin.newEncoder solver + totalizer <- Totalizer.newEncoder tseitin + SAT.newVars_ solver nv + ys <- Totalizer.encodeSum totalizer xs + forM_ xs1 $ \x -> SAT.addClause solver [x] + forM_ xs2 $ \x -> SAT.addClause solver [-x] + forM ys $ SAT.getLitFixed solver + QM.monitor $ counterexample (show lbs) + QM.assert $ lbs == replicate p lTrue ++ replicate (nv - p - q) lUndef ++ replicate q lFalse + + +prop_Totalizer_backward_propagation :: Property +prop_Totalizer_backward_propagation = QM.monadicIO $ do + nv <- QM.pick $ choose (2, 10) -- inclusive range + let xs = [1..nv] + (xs1, xs2) <- QM.pick $ do + cs <- forM xs $ \x -> do + c <- arbitrary + return (x,c) + return ([x | (x, Just True) <- cs], [x | (x, Just False) <- cs]) + let p = length xs1 + q = length xs2 + e <- QM.pick arbitrary + lbs <- QM.run $ do + solver <- SAT.newSolver + tseitin <- Tseitin.newEncoder solver + totalizer <- Totalizer.newEncoder tseitin + SAT.newVars_ solver nv + ys <- Totalizer.encodeSum totalizer xs + forM_ xs1 $ \x -> SAT.addClause solver [x] + forM_ xs2 $ \x -> SAT.addClause solver [-x] + forM_ (take (nv - p - q) (drop p ys)) $ \x -> do + SAT.addClause solver [if e then x else - x] + forM xs $ SAT.getLitFixed solver + QM.monitor $ counterexample (show lbs) + QM.assert $ and [x `elem` xs1 || x `elem` xs2 || lbs !! (x-1) == liftBool e | x <- xs] + + +prop_encodeAtLeast :: Property +prop_encodeAtLeast = QM.monadicIO $ do + let nv = 4 + (lhs,rhs) <- QM.pick $ do + lhs <- liftM catMaybes $ forM [1..nv] $ \i -> do + b <- arbitrary + if b then + Just <$> elements [i, -i] + else + return Nothing + rhs <- choose (-1, nv+2) + return $ (lhs, rhs) + strategy <- QM.pick arbitrary + (l,cnf,defs,defs2) <- QM.run $ do + db <- CNFStore.newCNFStore + SAT.newVars_ db nv + tseitin <- Tseitin.newEncoder db + card <- Cardinality.newEncoderWithStrategy tseitin strategy + l <- Cardinality.encodeAtLeast card (lhs, rhs) + cnf <- CNFStore.getCNFFormula db + defs <- Tseitin.getDefinitions tseitin + defs2 <- Cardinality.getTotalizerDefinitions card + return (l, cnf, defs, defs2) + forM_ (allAssignments nv) $ \m -> do + let m2 :: Array SAT.Var Bool + m2 = array (1, CNF.cnfNumVars cnf) $ + assocs m ++ + [(v, Tseitin.evalFormula m2 phi) | (v,phi) <- defs] ++ + Cardinality.evalTotalizerDefinitions m2 defs2 + b1 = evalCNF (array (bounds m2) (assocs m2)) cnf + QM.assert $ not b1 || (SAT.evalLit m2 l == SAT.evalAtLeast m (lhs,rhs)) + satEncoderTestGroup :: TestTree satEncoderTestGroup = $(testGroupGenerator) diff --git a/test/Test/SAT/ExistentialQuantification.hs b/test/Test/SAT/ExistentialQuantification.hs --- a/test/Test/SAT/ExistentialQuantification.hs +++ b/test/Test/SAT/ExistentialQuantification.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.ExistentialQuantification (satExistentialQuantificationTestGroup) where import Control.Monad @@ -123,7 +125,7 @@ SAT.newVars_ solver (CNF.cnfNumVars brauer11_phi) forM_ (CNF.cnfClauses brauer11_phi) $ \c -> SAT.addClause solver (SAT.unpackClause c) SAT.solveWith solver [if SAT.evalLit m y then y else -y | y <- [1..6]] - let b2 = all (SAT.evalClause m . SAT.unpackClause) (CNF.cnfClauses psi) + let b2 = all (SAT.evalClause m . SAT.unpackClause) (CNF.cnfClauses psi) (b1 == b2) @?= True case_shortestImplicantsE_phi :: Assertion diff --git a/test/Test/SAT/MUS.hs b/test/Test/SAT/MUS.hs --- a/test/Test/SAT/MUS.hs +++ b/test/Test/SAT/MUS.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.MUS (satMUSTestGroup) where import Control.Monad @@ -241,7 +243,7 @@ -- and hence not MSS. ret <- SAT.solveWith solver [y0,y1,y2,y4,y5,y6,y7,y9,y11,y12] assertBool "failed to prove the bug of HYCAM paper" (not ret) - + let cand = map IntSet.fromList [[y5], [y3,y2], [y0,y1,y2]] (actual,_) <- MUSEnum.allMUSAssumptions solver sels def{ MUSEnum.optMethod = MUSEnum.CAMUS, MUSEnum.optKnownCSes = cand } let actual' = Set.fromList $ actual diff --git a/test/Test/SAT/TheorySolver.hs b/test/Test/SAT/TheorySolver.hs --- a/test/Test/SAT/TheorySolver.hs +++ b/test/Test/SAT/TheorySolver.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.TheorySolver (satTheorySolverTestGroup) where import Control.Monad @@ -39,7 +41,7 @@ solver <- SAT.newSolver SAT.newVars_ solver nv forM_ cs $ \c -> SAT.addClause solver (SAT.unpackClause c) - + ref <- newIORef [] let tsolver = TheorySolver @@ -57,7 +59,7 @@ SAT.solveWith solver xs , thExplain = \m -> do case m of - Nothing -> SAT.getFailedAssumptions solver + Nothing -> liftM IntSet.toList $ SAT.getFailedAssumptions solver Just _ -> return [] , thPushBacktrackPoint = modifyIORef ref ([] :) , thPopBacktrackPoint = modifyIORef ref tail @@ -116,7 +118,7 @@ vGt <- SAT.newVar satSolver SAT.addClause satSolver [vLt,vEq,vGt] SAT.addClause satSolver [-vLt, -vEq] - SAT.addClause satSolver [-vLt, -vGt] + SAT.addClause satSolver [-vLt, -vGt] SAT.addClause satSolver [-vEq, -vGt] writeIORef tblRef (Map.insert (v,rhs) (vLt, vEq, vGt) tbl) let xs = IntMap.fromList @@ -202,11 +204,11 @@ satSolver <- SAT.newSolver eufSolver <- EUF.newSolver enc <- Tseitin.newEncoder satSolver - + tblRef <- newIORef (Map.empty :: Map (EUF.Term, EUF.Term) SAT.Var) defsRef <- newIORef (IntMap.empty :: IntMap (EUF.Term, EUF.Term)) eufModelRef <- newIORef (undefined :: EUF.Model) - + let abstractEUFAtom :: (EUF.Term, EUF.Term) -> IO SAT.Lit abstractEUFAtom (t1,t2) | t1 >= t2 = abstractEUFAtom (t2,t1) abstractEUFAtom (t1,t2) = do @@ -246,7 +248,7 @@ when b2 $ do _ <- callback v return () - return b + return b , thExplain = \m -> do case m of Nothing -> liftM IntSet.toList $ EUF.explain eufSolver Nothing diff --git a/test/Test/SAT/Types.hs b/test/Test/SAT/Types.hs --- a/test/Test/SAT/Types.hs +++ b/test/Test/SAT/Types.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.Types (satTypesTestGroup) where import Control.Monad @@ -161,7 +163,7 @@ prop_pbLinUpperBound = forAll (choose (0,10)) $ \nv -> forAll (arbitraryPBLinSum nv) $ \s -> - forAll (arbitraryAssignment nv) $ \m -> + forAll (arbitraryAssignment nv) $ \m -> let ub = SAT.pbLinUpperBound s in counterexample (show ub) $ SAT.evalPBLinSum m s <= ub @@ -169,7 +171,7 @@ prop_pbLinLowerBound = forAll (choose (0,10)) $ \nv -> forAll (arbitraryPBLinSum nv) $ \s -> - forAll (arbitraryAssignment nv) $ \m -> + forAll (arbitraryAssignment nv) $ \m -> let lb = SAT.pbLinLowerBound s in counterexample (show lb) $ lb <= SAT.evalPBLinSum m s @@ -187,14 +189,14 @@ forAll (choose (0,10)) $ \nv -> forAll (arbitraryPBSum nv) $ \s -> let s' = SAT.removeNegationFromPBSum s - in counterexample (show s') $ + in counterexample (show s') $ forAll (arbitraryAssignment nv) $ \m -> SAT.evalPBSum m s === SAT.evalPBSum m s' prop_pbUpperBound :: Property prop_pbUpperBound = forAll (choose (0,10)) $ \nv -> forAll (arbitraryPBSum nv) $ \s -> - forAll (arbitraryAssignment nv) $ \m -> + forAll (arbitraryAssignment nv) $ \m -> let ub = SAT.pbUpperBound s in counterexample (show ub) $ SAT.evalPBSum m s <= ub @@ -202,7 +204,7 @@ prop_pbLowerBound = forAll (choose (0,10)) $ \nv -> forAll (arbitraryPBSum nv) $ \s -> - forAll (arbitraryAssignment nv) $ \m -> + forAll (arbitraryAssignment nv) $ \m -> let lb = SAT.pbLowerBound s in counterexample (show lb) $ lb <= SAT.evalPBSum m s diff --git a/test/Test/SAT/Utils.hs b/test/Test/SAT/Utils.hs --- a/test/Test/SAT/Utils.hs +++ b/test/Test/SAT/Utils.hs @@ -1,6 +1,8 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SAT.Utils where import Control.Monad @@ -41,7 +43,7 @@ bs <- replicateM nv arbitrary return $ array (1,nv) (zip [1..] bs) --- --------------------------------------------------------------------- +-- --------------------------------------------------------------------- arbitraryCNF :: Gen CNF.CNF arbitraryCNF = do @@ -268,7 +270,7 @@ nv <- choose (0,10) nc <- choose (0,50) cs <- replicateM nc $ do - len <- choose (0,10) + len <- choose (0,10) lhs <- if nv == 0 then return [] @@ -541,8 +543,3 @@ arbitrary = arbitraryBoundedEnum -- --------------------------------------------------------------------- - -#if !MIN_VERSION_QuickCheck(2,8,0) -sublistOf :: [a] -> Gen [a] -sublistOf xs = filterM (\_ -> choose (False, True)) xs -#endif diff --git a/test/Test/SDPFile.hs b/test/Test/SDPFile.hs --- a/test/Test/SDPFile.hs +++ b/test/Test/SDPFile.hs @@ -36,16 +36,16 @@ } where f0 = [ [[-1.4, -3.2], [-3.2, -28]] - , [[15, -12, 2.1], [-12, 16, -3.8], [2.1, -3.8, 15]] - , [[1.8, 0], [0, -4.0]] + , [[15, -12, 2.1], [-12, 16, -3.8], [2.1, -3.8, 15]] + , [[1.8, 0], [0, -4.0]] ] f1 = [ [[0.5, 5.2], [5.2,-5.3]] - , [[7.8, -2.4, 6.0], [-2.4, 4.2, 6.5], [6.0, 6.5, 2.1]] + , [[7.8, -2.4, 6.0], [-2.4, 4.2, 6.5], [6.0, 6.5, 2.1]] , [[-4.5, 0], [0, -3.5]] ] f5 = [ [[-6.5, -5.4], [-5.4, -6.6]] - , [[6.7, -7.2, -3.6], [-7.2, 7.3, -3.0], [-3.6, -3.0, -1.4]] - , [[6.1, 0],[0, -1.5]] + , [[6.7, -7.2, -3.6], [-7.2, 7.3, -3.0], [-3.6, -3.0, -1.4]] + , [[6.1, 0],[0, -1.5]] ] case_test1 = checkParsed example1b example1 diff --git a/test/Test/SMT.hs b/test/Test/SMT.hs --- a/test/Test/SMT.hs +++ b/test/Test/SMT.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SMT (smtTestGroup) where import Control.Applicative((<$>)) @@ -59,7 +61,7 @@ m <- SMT.getModel solver SMT.eval m c1 @?= SMT.ValBool True SMT.eval m c2 @?= SMT.ValBool True - + SMT.assert solver $ x ret <- SMT.checkSAT solver ret @?= False @@ -205,7 +207,7 @@ ] forM_ cs $ SMT.assert solver ret <- SMT.checkSATAssuming solver [cond] - m <- SMT.getModel solver + m <- SMT.getModel solver forM_ cs $ \c -> do let val = SMT.eval m c -- unless (val == SMT.ValBool True) $ print val @@ -353,7 +355,7 @@ replicateM nconstrs (genExpr genSorts sig SMT.sBool 10) QM.run $ do forM_ constrs $ \constr -> SMT.assert solver constr - ret <- SMT.checkSAT solver + ret <- SMT.checkSAT solver when ret $ do m <- SMT.getModel solver forM_ fs2 $ \(f,_) -> do @@ -492,7 +494,7 @@ | size >= 3 ] put size' - return e + return e f s = do modify (subtract 1) size <- get @@ -520,7 +522,7 @@ | s == SMT.sBool, size >= 2 , op <- ["="] ] - ++ + ++ [ flip runStateT size $ do w <- lift $ choose (1, 10) arg1 <- f (SMT.Sort (SMT.SSymBitVec w) []) diff --git a/test/Test/SMTLIB2Solver.hs b/test/Test/SMTLIB2Solver.hs --- a/test/Test/SMTLIB2Solver.hs +++ b/test/Test/SMTLIB2Solver.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SMTLIB2Solver (smtlib2SolverTestGroup) where import Control.Applicative((<$>)) @@ -49,7 +50,8 @@ [ TermQualIdentifierT (QIdentifier (ISymbol "not")) [TermQualIdentifier (QIdentifier (ISymbol "a"))] , TermQualIdentifierT (QIdentifier (ISymbol "not")) [TermQualIdentifier (QIdentifier (ISymbol "b"))] ] - r @?= expected + -- XXX: Term type is not Hashable nor Ord. + Set.fromList (map showSL r) @?= Set.fromList (map showSL expected) case_declareConst :: Assertion case_declareConst = do diff --git a/test/Test/Simplex.hs b/test/Test/Simplex.hs --- a/test/Test/Simplex.hs +++ b/test/Test/Simplex.hs @@ -108,7 +108,7 @@ example 5.7 minimize 3 x1 + 4 x2 + 5 x3 -subject to +subject to 1 x1 + 2 x2 + 3 x3 >= 5 2 x1 + 2 x2 + 1 x3 >= 6 @@ -145,7 +145,7 @@ example 5.7 maximize -3 x1 -4 x2 -5 x3 -subject to +subject to -1 x1 -2 x2 -3 x3 <= -5 -2 x1 -2 x2 -1 x3 <= -6 diff --git a/test/Test/SimplexTextbook.hs b/test/Test/SimplexTextbook.hs --- a/test/Test/SimplexTextbook.hs +++ b/test/Test/SimplexTextbook.hs @@ -125,7 +125,7 @@ ------------------------------------------------------------------------ case_lp_example_5_7_twoPhaseSimplex :: Assertion -case_lp_example_5_7_twoPhaseSimplex = do +case_lp_example_5_7_twoPhaseSimplex = do ret @?= LP.Optimum oval @?= -11 assertBool "invalid tableau" (isValidTableau tbl) @@ -135,7 +135,7 @@ oval :: Rational ((ret,tbl,oval),result) = flip runState (LP.emptySolver IntSet.empty) $ do _ <- LP.newVar - x1 <- LP.newVar + x1 <- LP.newVar x2 <- LP.newVar x3 <- LP.newVar LP.addConstraint (LA.fromTerms [(-1,x1),(-2,x2),(-3,x3)] .<=. LA.constant (-5)) @@ -148,7 +148,7 @@ return (ret,tbl,oval) case_lp_example_5_7_primalDualSimplex :: Assertion -case_lp_example_5_7_primalDualSimplex = do +case_lp_example_5_7_primalDualSimplex = do ret @?= LP.Optimum oval @?= -11 assertBool "invalid tableau" (isValidTableau tbl) @@ -158,7 +158,7 @@ oval :: Rational ((ret,tbl,oval),result) = flip runState (LP.emptySolver IntSet.empty) $ do _ <- LP.newVar - x1 <- LP.newVar + x1 <- LP.newVar x2 <- LP.newVar x3 <- LP.newVar LP.addConstraint (LA.fromTerms [(-1,x1),(-2,x2),(-3,x3)] .<=. LA.constant (-5)) diff --git a/test/Test/Smtlib.hs b/test/Test/Smtlib.hs --- a/test/Test/Smtlib.hs +++ b/test/Test/Smtlib.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.Smtlib (smtlibTestGroup) where import Control.DeepSeq @@ -70,7 +71,7 @@ parse parseGenResponse "" (showSL a) == Right a prop_parseGetInfoResponse :: Property -prop_parseGetInfoResponse = forAll arbitrary $ \a -> +prop_parseGetInfoResponse = forAll arbitrary $ \a -> parse parseGetInfoResponse "" ("(" ++ joinA a ++ ")") == Right a prop_parseCheckSatResponse :: Property @@ -133,7 +134,7 @@ parse str "" s == Right s case_parseSexprKeyword_bug :: Assertion -case_parseSexprKeyword_bug = +case_parseSexprKeyword_bug = parse parseSexprKeyword "" ":keyword" @?= Right (SexprKeyword ":keyword") case_parseHexadecimal :: Assertion @@ -253,7 +254,7 @@ , TermQualIdentifier <$> arbitrary ] ++ (if n > 0 then gs else []) where - gs = + gs = [ liftM2 TermQualIdentifierT arbitrary (listOf1' arbitrary') , liftM2 TermLet (listOf1' arbitrary) arbitrary' , liftM2 TermForall (listOf1' arbitrary) arbitrary' @@ -273,7 +274,7 @@ , AttrValueSymbol <$> genSymbol , AttrValueSexpr <$> listOf' arbitrary ] - + instance Arbitrary Attribute where arbitrary = oneof [ Attribute <$> genKeyword @@ -285,7 +286,7 @@ [ QIdentifier <$> arbitrary , liftM2 QIdentifierAs arbitrary arbitrary ] - + instance Arbitrary Index where arbitrary = oneof [ IndexNumeral <$> abs <$> arbitrary @@ -319,7 +320,7 @@ s <- listOf $ arbitrary `suchThat` p return $ "\"" ++ concat [if c == '"' then "\"\"" else [c] | c <- s] ++ "\"" ] - + instance Arbitrary Sexpr where arbitrary = sized $ \n -> oneof $ [ SexprSpecConstant <$> arbitrary @@ -529,7 +530,7 @@ ] instance Arbitrary GenResponse where - arbitrary = oneof + arbitrary = oneof [ return Unsupported , return Success , Error <$> genStringLiteral @@ -544,7 +545,7 @@ instance Arbitrary CheckSatResponse where arbitrary = elements [Sat, Unsat, Unknown] -instance Arbitrary InfoResponse where +instance Arbitrary InfoResponse where arbitrary = oneof [ ResponseErrorBehavior <$> arbitrary , ResponseName <$> genStringLiteral diff --git a/test/Test/SubsetSum.hs b/test/Test/SubsetSum.hs --- a/test/Test/SubsetSum.hs +++ b/test/Test/SubsetSum.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} module Test.SubsetSum (subsetSumTestGroup) where import Control.Monad diff --git a/test/TestPolynomial.hs b/test/TestPolynomial.hs --- a/test/TestPolynomial.hs +++ b/test/TestPolynomial.hs @@ -1,4 +1,7 @@ -{-# LANGUAGE FlexibleContexts, TemplateHaskell, ScopedTypeVariables, DataKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} import Prelude hiding (lex) import qualified Control.Exception as E @@ -20,60 +23,61 @@ import qualified ToySolver.Data.Polynomial.Factorization.FiniteField as FactorFF import qualified ToySolver.Data.Polynomial.Factorization.Hensel.Internal as Hensel import qualified ToySolver.Data.Polynomial.Factorization.Zassenhaus as Zassenhaus +import qualified ToySolver.Data.Polynomial.Interpolation.Hermite as HermiteInterpolation import qualified ToySolver.Data.Polynomial.Interpolation.Lagrange as LagrangeInterpolation import qualified Data.Interval as Interval -import Data.Interval (Interval, EndPoint (..), (<=..<=), (<..<=), (<=..<), (<..<)) +import Data.Interval (Interval, Extended (..), (<=..<=), (<..<=), (<=..<), (<..<)) {-------------------------------------------------------------------- Polynomial type --------------------------------------------------------------------} -prop_plus_comm = +prop_plus_comm = forAll polynomials $ \a -> forAll polynomials $ \b -> a + b == b + a -prop_plus_assoc = +prop_plus_assoc = forAll polynomials $ \a -> forAll polynomials $ \b -> forAll polynomials $ \c -> a + (b + c) == (a + b) + c -prop_plus_unitL = +prop_plus_unitL = forAll polynomials $ \a -> P.constant 0 + a == a -prop_plus_unitR = +prop_plus_unitR = forAll polynomials $ \a -> a + P.constant 0 == a -prop_prod_comm = +prop_prod_comm = forAll polynomials $ \a -> forAll polynomials $ \b -> a * b == b * a -prop_prod_assoc = +prop_prod_assoc = forAll polynomials $ \a -> forAll polynomials $ \b -> forAll polynomials $ \c -> a * (b * c) == (a * b) * c -prop_prod_unitL = +prop_prod_unitL = forAll polynomials $ \a -> P.constant 1 * a == a -prop_prod_unitR = +prop_prod_unitR = forAll polynomials $ \a -> a * P.constant 1 == a -prop_distL = +prop_distL = forAll polynomials $ \a -> forAll polynomials $ \b -> forAll polynomials $ \c -> a * (b + c) == a * b + a * c -prop_distR = +prop_distR = forAll polynomials $ \a -> forAll polynomials $ \b -> forAll polynomials $ \c -> @@ -130,7 +134,7 @@ prop_divMod = forAll upolynomials $ \a -> forAll upolynomials $ \b -> - b /= 0 ==> + b /= 0 ==> let (q,r) = P.divMod a b in a == q*b + r && (r==0 || P.deg b > P.deg r) @@ -149,7 +153,7 @@ let c = P.gcd a b in a `P.mod` c == 0 && b `P.mod` c == 0 -prop_gcd_comm = +prop_gcd_comm = forAll upolynomials $ \a -> forAll upolynomials $ \b -> P.gcd a b == P.gcd b a @@ -162,13 +166,13 @@ P.gcd p q == P.gcd p (q + p*r) case_gcd_1 = P.gcd f1 f2 @?= 1 - where + where x :: UPolynomial Rational x = P.var X f1 = x^3 + x^2 + x f2 = x^2 + 1 -prop_exgcd = +prop_exgcd = forAll upolynomials $ \a -> forAll upolynomials $ \b -> let (g,u,v) = P.exgcd a b @@ -191,7 +195,7 @@ case P.mapCoeff fromInteger a `P.divMod` P.mapCoeff fromInteger b of (q,r) -> r == 0 && P.deg q <= 0 -prop_gcd'_comm = +prop_gcd'_comm = forAll upolynomialsZ $ \a -> forAll upolynomialsZ $ \b -> P.gcd' a b `eqUpToInvElem` P.gcd' b a @@ -204,7 +208,7 @@ P.gcd' p q `eqUpToInvElem` P.gcd' p (q + p*r) case_gcd'_1 = eqUpToInvElem (P.gcd' f1 f2) 1 @?= True - where + where x :: UPolynomial Integer x = P.var X f1 = x^3 + x^2 + x @@ -217,7 +221,7 @@ let c = P.lcm a b in c `P.mod` a == 0 && c `P.mod` b == 0 -prop_lcm_comm = +prop_lcm_comm = forAll upolynomials $ \a -> forAll upolynomials $ \b -> P.lcm a b == P.lcm b a @@ -291,41 +295,41 @@ --------------------------------------------------------------------} prop_degreeOfProduct = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> P.deg (a `P.mmult` b) == P.deg a + P.deg b prop_degreeOfUnit = P.deg P.mone == 0 -prop_mmult_unitL = - forAll monicMonomials $ \a -> +prop_mmult_unitL = + forAll monicMonomials $ \a -> P.mone `P.mmult` a == a -prop_mmult_unitR = - forAll monicMonomials $ \a -> +prop_mmult_unitR = + forAll monicMonomials $ \a -> a `P.mmult` P.mone == a -prop_mmult_comm = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> +prop_mmult_comm = + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> a `P.mmult` b == b `P.mmult` a -prop_mmult_assoc = +prop_mmult_assoc = forAll monicMonomials $ \a -> forAll monicMonomials $ \b -> forAll monicMonomials $ \c -> a `P.mmult` (b `P.mmult` c) == (a `P.mmult` b) `P.mmult` c -prop_mmult_Divisible = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> +prop_mmult_Divisible = + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> let c = a `P.mmult` b in a `P.mdivides` c && b `P.mdivides` c -prop_mmult_Div = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> +prop_mmult_Div = + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> let c = a `P.mmult` b in c `P.mdiv` a == b && c `P.mdiv` b == a @@ -346,15 +350,15 @@ p1 = P.mfromIndices [(1,2),(2,4)] p2 = P.mfromIndices [(2,1),(3,2)] -prop_mlcm_divisible = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> +prop_mlcm_divisible = + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> let c = P.mlcm a b in a `P.mdivides` c && b `P.mdivides` c -prop_mgcd_divisible = - forAll monicMonomials $ \a -> - forAll monicMonomials $ \b -> +prop_mgcd_divisible = + forAll monicMonomials $ \a -> + forAll monicMonomials $ \b -> let c = P.mgcd a b in c `P.mdivides` a && c `P.mdivides` b @@ -495,7 +499,7 @@ -- http://www.orcca.on.ca/~reid/NewWeb/DetResDes/node4.html -- 時間がかかるので自動実行されるテストケースには含めていない -disabled_case_buchberger4 = Set.fromList gb @?= Set.fromList expected +disabled_case_buchberger4 = Set.fromList gb @?= Set.fromList expected where x :: Polynomial Rational Int x = P.var 1 @@ -619,7 +623,7 @@ product [g^n | (g,n) <- actual] @?= f where x :: UPolynomial Integer - x = P.var X + x = P.var X f = 2*(x^5 + x^4 + x^2 + x + 2) actual = P.factor f expected = [(2,1), (x^2+x+1,1), (x^3-x+2,1)] @@ -629,7 +633,7 @@ product [g^n | (g,n) <- actual] @?= f where x :: UPolynomial Integer - x = P.var X + x = P.var X f = - (x^5 + x^4 + x^2 + x + 2) actual = P.factor f expected = [(-1,1), (x^2+x+1,1), (x^3-x+2,1)] @@ -857,7 +861,7 @@ case_Zassenhaus_factor = actual @?= expected where x :: UPolynomial Integer - x = P.var X + x = P.var X f = - (x^(5::Int) + x^(4::Int) + x^(2::Int) + x + 2) actual, expected :: [(UPolynomial Integer, Integer)] actual = sort $ Zassenhaus.factor f @@ -906,6 +910,30 @@ , (3, 27) ] q = 6*x^2 - 11*x + 6 + +-- https://en.wikipedia.org/wiki/Hermite_interpolation +case_Hermite_interpolation = p @?= q + where + x :: UPolynomial Rational + x = P.var X + p = HermiteInterpolation.interpolate + [ (-1, [2, -8, 56]) + , (0, [1, 0, 0]) + , (1, [2, 8, 56]) + ] + q = x^8 + 1 + +prop_Hermite_interpolation_random = + forAll upolynomials $ \p -> + forAll (choose (0, 2)) $ \m -> + let d = P.deg p + -- m = 2 + n = (d + 1 + m) `div` (m+1) + -- d <= n (m + 1) - 1 + xs = genericTake n [-1, 0 ..] + ds = [(x', genericTake (m+1) [P.eval (\_ -> x') q | q <- iterate (\q -> P.deriv q X) p]) | x' <- xs] + p' = HermiteInterpolation.interpolate ds + in counterexample (show (p, ds, p')) $ p == p' -- --------------------------------------------------------------------- diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -16,11 +16,7 @@ import Test.GraphShortestPath import Test.HittingSets import Test.Knapsack -import Test.LPFile -import Test.MIP import Test.MIPSolver -import Test.MIPSolver2 -import Test.MPSFile import Test.ProbSAT import Test.SDPFile import Test.Misc @@ -56,12 +52,8 @@ , graphShortestPathTestGroup , hittingSetsTestGroup , knapsackTestGroup - , lpTestGroup , miscTestGroup - , mipTestGroup , mipSolverTestGroup - , mipSolver2TestGroup - , mpsTestGroup , probSATTestGroup , qbfTestGroup , quboTestGroup diff --git a/toysolver.cabal b/toysolver.cabal --- a/toysolver.cabal +++ b/toysolver.cabal @@ -1,26 +1,29 @@ Name: toysolver -Version: 0.6.0 +Version: 0.7.0 License: BSD3 License-File: COPYING Author: Masahiro Sakai (masahiro.sakai@gmail.com) Maintainer: masahiro.sakai@gmail.com Category: Algorithms, Optimisation, Optimization, Theorem Provers, Constraints, Logic, Formal Methods, SMT -Cabal-Version: 1.18 +Cabal-Version: 2.0 Synopsis: Assorted decision procedures for SAT, SMT, Max-SAT, PB, MIP, etc Description: Toy-level solver implementation of various problems including SAT, SMT, Max-SAT, PBS/PBO (Pseudo Boolean Satisfaction/Optimization), MILP (Mixed Integer Linear Programming) and non-linear real arithmetic. Homepage: https://github.com/msakai/toysolver/ Bug-Reports: https://github.com/msakai/toysolver/issues Tested-With: - GHC ==7.10.3 GHC ==8.0.2 GHC ==8.2.2 GHC ==8.4.4 - GHC ==8.6.4 + GHC ==8.6.5 + GHC ==8.8.4 + GHC ==8.10.2 Extra-Source-Files: README.md CHANGELOG.markdown COPYING COPYING-GPL + app/toysat-ipasir/ipasir.h + app/toysat-ipasir/ipasir.map misc/build_bdist_linux.sh misc/build_bdist_macos.sh misc/build_bdist_win32.sh @@ -38,7 +41,7 @@ misc/smtcomp/bin/starexec_run_default misc/smtcomp/starexec_description.txt src/ToySolver/Data/Polyhedron.hs - src/ToySolver/SAT/MessagePassing/SurveyPropagation/sp.cl + src/ToySolver/SAT/Solver/MessagePassing/SurveyPropagation/sp.cl samples/gcnf/*.cnf samples/gcnf/*.gcnf samples/gcnf/edn_20403_8.cnf_0.03000000.unsat.gcnf @@ -76,9 +79,6 @@ samples/programs/numberlink/ADC2016/sample/01/*.txt benchmarks/UF250.1065.100/*.cnf benchmarks/UUF250.1065.100/*.cnf - doc-images/MIP-Status-diagram.tex -Extra-Doc-Files: - doc-images/MIP-Status-diagram.png Build-Type: Simple Flag ForceChar8 @@ -111,11 +111,6 @@ Default: False Manual: True -Flag LogicTPTP045 - Description: use logic-TPTP >=0.4.5.0 - Manual: False - Default: True - Flag UseHaskeline Description: use haskeline package Manual: True @@ -126,33 +121,8 @@ Manual: True Default: False -Flag TestCBC - Description: run test cases that depends on cbc command - Manual: True - Default: False - -Flag TestCPLEX - Description: run test cases that depends on cplex command - Manual: True - Default: False - -Flag TestGlpsol - Description: run test cases that depends on glpsol command - Manual: True - Default: False - -Flag TestGurobiCl - Description: run test cases that depends on gurobi_cl command - Manual: True - Default: False - -Flag TestLPSolve - Description: run test cases that depends on lp_solve command - Manual: True - Default: False - -Flag TestSCIP - Description: run test cases that depends on scip command +Flag ExtraBoundsChecking + Description: enable extra bounds checking for debugging Manual: True Default: False @@ -164,9 +134,9 @@ Exposed: True Hs-source-dirs: src Build-Depends: - array >=0.4.0.0, - -- GHC >=7.10 - base >=4.8 && <5, + array >=0.5, + -- GHC >=8.0 + base >=4.9 && <5, bytestring >=0.9.2.1 && <0.11, bytestring-builder, bytestring-encoding, @@ -174,26 +144,30 @@ clock >=0.7.1, -- IntMap.mergeWithKey and IntMap.toDescList require containers >=0.5.0 containers >=0.5.0, + data-default, data-default-class, - data-interval >=1.0.1 && <1.4.0, + data-interval >=2.0.1 && <2.1.0, deepseq, + directory, extended-reals >=0.1 && <1.0, filepath, finite-field >=0.9.0 && <1.0.0, - hashable >=1.1.2.5 && <1.3.0.0, + -- hashUsing is available on hashable >=1.2 + hashable >=1.2 && <1.4.0.0, hashtables, heaps, intern >=0.9.1.2 && <1.0.0.0, log-domain, -- numLoopState requires loop >=0.3.0 loop >=0.3.0 && < 1.0.0, + MIP >=0.1.1.0 && <0.2, mtl >=2.1.2, multiset, -- createSystemRandom requires mwc-random >=0.13.1.0 mwc-random >=0.13.1 && <0.15, OptDir, lattices, - megaparsec >=4 && <8, + megaparsec >=5 && <10, -- Text.PrettyPrint.HughesPJClass is available on pretty >=1.1.2.0 pretty >=1.1.2.0 && <1.2, primes, @@ -208,11 +182,13 @@ template-haskell, temporary >=1.2, text >=1.1.0.0, + -- defaultTimeLocale is available on time >=1.5.0 time >=1.5.0, transformers >=0.2, transformers-compat >=0.3, unordered-containers >=0.2.3 && <0.3.0, - vector, + -- imapM and modify are available on vector >=0.11.0 + vector >=0.11, vector-space >=0.8.6, xml-conduit if flag(WithZlib) @@ -220,30 +196,35 @@ CPP-Options: "-DWITH_ZLIB" if flag(OpenCL) Build-Depends: OpenCL >=1.0.3.4 - Exposed-Modules: ToySolver.SAT.MessagePassing.SurveyPropagation.OpenCL + Exposed-Modules: ToySolver.SAT.Solver.MessagePassing.SurveyPropagation.OpenCL + if flag(ExtraBoundsChecking) + CPP-Options: "-DEXTRA_BOUNDS_CHECKING" if impl(ghc) Build-Depends: ghc-prim Default-Language: Haskell2010 Other-Extensions: BangPatterns CPP + ConstraintKinds DeriveDataTypeable ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies + GADTs GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures MultiParamTypeClasses OverloadedStrings - RecursiveDo Rank2Types + RecursiveDo ScopedTypeVariables TemplateHaskell TypeFamilies TypeOperators TypeSynonymInstances - -- commented out because cabal-1.16 does not understand InstanceSigs extension - -- InstanceSigs + UndecidableInstances if impl(ghc) Other-Extensions: MagicHash @@ -305,6 +286,7 @@ ToySolver.Converter.PB2SMP ToySolver.Converter.QBF2IPC ToySolver.Converter.QUBO + ToySolver.Converter.SAT2MIS ToySolver.Converter.SAT2KSAT ToySolver.Converter.SAT2MaxCut ToySolver.Converter.SAT2MaxSAT @@ -323,24 +305,6 @@ ToySolver.Data.LA ToySolver.Data.LA.FOL ToySolver.Data.LBool - ToySolver.Data.MIP - ToySolver.Data.MIP.Base - ToySolver.Data.MIP.FileUtils - ToySolver.Data.MIP.LPFile - ToySolver.Data.MIP.MPSFile - ToySolver.Data.MIP.Solution.CBC - ToySolver.Data.MIP.Solution.CPLEX - ToySolver.Data.MIP.Solution.GLPK - ToySolver.Data.MIP.Solution.Gurobi - ToySolver.Data.MIP.Solution.SCIP - ToySolver.Data.MIP.Solver - ToySolver.Data.MIP.Solver.Base - ToySolver.Data.MIP.Solver.CBC - ToySolver.Data.MIP.Solver.CPLEX - ToySolver.Data.MIP.Solver.Glpsol - ToySolver.Data.MIP.Solver.GurobiCl - ToySolver.Data.MIP.Solver.LPSolve - ToySolver.Data.MIP.Solver.SCIP ToySolver.Data.OrdRel ToySolver.Data.Polynomial ToySolver.Data.Polynomial.Factorization.FiniteField @@ -352,16 +316,17 @@ ToySolver.Data.Polynomial.Factorization.SquareFree ToySolver.Data.Polynomial.Factorization.Zassenhaus ToySolver.Data.Polynomial.GroebnerBasis + ToySolver.Data.Polynomial.Interpolation.Hermite ToySolver.Data.Polynomial.Interpolation.Lagrange ToySolver.FileFormat ToySolver.FileFormat.Base ToySolver.FileFormat.CNF + ToySolver.Graph.Base ToySolver.Graph.ShortestPath - ToySolver.MaxCut + ToySolver.Graph.MaxCut ToySolver.QBF ToySolver.QUBO ToySolver.SAT - ToySolver.SAT.Config ToySolver.SAT.Encoder.Integer ToySolver.SAT.Encoder.PB ToySolver.SAT.Encoder.PB.Internal.Adder @@ -371,9 +336,9 @@ ToySolver.SAT.Encoder.Cardinality ToySolver.SAT.Encoder.Cardinality.Internal.Naive ToySolver.SAT.Encoder.Cardinality.Internal.ParallelCounter + ToySolver.SAT.Encoder.Cardinality.Internal.Totalizer ToySolver.SAT.Encoder.Tseitin ToySolver.SAT.ExistentialQuantification - ToySolver.SAT.MessagePassing.SurveyPropagation ToySolver.SAT.MUS ToySolver.SAT.MUS.Enum ToySolver.SAT.MUS.Types @@ -384,7 +349,11 @@ ToySolver.SAT.PBO.BCD2 ToySolver.SAT.PBO.MSU4 ToySolver.SAT.PBO.UnsatBased - ToySolver.SAT.SLS.ProbSAT + ToySolver.SAT.Solver.CDCL + ToySolver.SAT.Solver.CDCL.Config + ToySolver.SAT.Solver.MessagePassing.SurveyPropagation + ToySolver.SAT.Solver.SLS.ProbSAT + ToySolver.SAT.Solver.SLS.UBCSAT ToySolver.SAT.Store.CNF ToySolver.SAT.Store.PB ToySolver.SAT.TheorySolver @@ -420,6 +389,8 @@ ToySolver.SAT.MUS.Enum.CAMUS ToySolver.Version.TH Paths_toysolver + autogen-modules: + Paths_toysolver -- GHC-Prof-Options: -auto-all Executable toysolver @@ -431,8 +402,10 @@ containers, data-default-class, filepath, + MIP, OptDir, - optparse-applicative, + -- maybeReader is available on optparse-applicative >=0.13.0.0 + optparse-applicative >=0.13, pseudo-boolean, scientific, toysolver @@ -447,7 +420,6 @@ Executable toysat Main-is: toysat.hs - Other-Modules: UBCSAT HS-Source-Dirs: app/toysat Build-Depends: array, @@ -455,17 +427,15 @@ bytestring, containers, clock, - data-default, data-default-class, - directory, filepath, megaparsec, + MIP, mwc-random, - optparse-applicative, - process >=1.1.0.2, + -- maybeReader is available on optparse-applicative >=0.13.0.0 + optparse-applicative >=0.13, pseudo-boolean, scientific, - temporary, time, toysolver, unbounded-delays, @@ -481,6 +451,26 @@ if flag(LinuxStatic) GHC-Options: -static -optl-static -optl-pthread +Foreign-Library toysat-ipasir + type: native-shared + if os(Windows) + options: standalone + mod-def-file: app/toysat-ipasir/ipasir.def + if os(Linux) + ld-options: -Wl,--version-script=app/toysat-ipasir/ipasir.map + build-depends: + base, + containers, + toysolver + hs-source-dirs: app/toysat-ipasir + include-dirs: app/toysat-ipasir + c-sources: app/toysat-ipasir/cbits.c + cc-options: -Wall + cpp-options: -DIPASIR_SHARED_LIB -DBUILDING_IPASIR_SHARED_LIB + includes: ipasir.h + other-modules: IPASIR + default-language: Haskell2010 + Executable toysmt HS-Source-Dirs: app/toysmt, Smtlib Main-is: toysmt.hs @@ -507,7 +497,7 @@ transformers, transformers-compat if flag(UseHaskeline) - Build-Depends: haskeline >=0.7 && <0.8 + Build-Depends: haskeline >=0.7 && <0.9 CPP-Options: "-DUSE_HASKELINE_PACKAGE" Default-Language: Haskell2010 Other-Extensions: ScopedTypeVariables, CPP @@ -546,23 +536,10 @@ base, containers, intern, - -- logic-TPTP <=0.4.3 has build error on ghc <7.9 and transformers >=0.5.1. - -- https://github.com/DanielSchuessler/logic-TPTP/pull/4 - logic-TPTP >=0.4.4.0, + logic-TPTP >=0.4.6.0 && <0.5, optparse-applicative, text, toysolver - -- logic-TPTP <=0.4.4.0 is not compatible with transformers-compat >=0.5 - if impl(ghc <7.9) - if flag(LogicTPTP045) - Build-Depends: - logic-TPTP >=0.4.5.0 - else - Build-Depends: - transformers-compat <0.5 - -- for Semigroup (as superclass of) Monoid Proposal - if impl(ghc >=8.4) - Build-Depends: logic-TPTP >=0.4.6.0 Default-Language: Haskell2010 Other-Extensions: CPP GHC-Options: -rtsopts @@ -584,6 +561,7 @@ bytestring-builder, data-default-class, filepath, + MIP, optparse-applicative, pseudo-boolean, scientific, @@ -764,6 +742,7 @@ base, containers, data-default-class, + MIP, scientific, split, text, @@ -921,12 +900,8 @@ Test.GraphShortestPath Test.HittingSets Test.Knapsack - Test.LPFile Test.Misc - Test.MIP Test.MIPSolver - Test.MIPSolver2 - Test.MPSFile Test.ProbSAT Test.QBF Test.QUBO @@ -944,11 +919,11 @@ Test.SMTLIB2Solver Test.Smtlib Test.SubsetSum - ToySolver.SMT.SMTLIB2Solver, - Smtlib.Parsers.CommonParsers, - Smtlib.Parsers.ResponseParsers, - Smtlib.Parsers.CommandsParsers, - Smtlib.Syntax.Syntax, + ToySolver.SMT.SMTLIB2Solver + Smtlib.Parsers.CommonParsers + Smtlib.Parsers.ResponseParsers + Smtlib.Parsers.CommandsParsers + Smtlib.Syntax.Syntax Smtlib.Syntax.ShowSL Build-depends: array, @@ -968,7 +943,8 @@ OptDir, parsec >=3.1.2 && <4, pseudo-boolean, - QuickCheck >=2.5 && <3, + -- sublistOf is available on QuickCheck >=2.8 + QuickCheck >=2.8 && <3, scientific, tasty >=0.10.1, tasty-hunit >=0.9 && <0.11, @@ -982,19 +958,11 @@ vector, vector-space Default-Language: Haskell2010 - Other-Extensions: TemplateHaskell, ScopedTypeVariables - if flag(TestCBC) - CPP-Options: "-DTEST_CBC" - if flag(TestCPLEX) - CPP-Options: "-DTEST_CPLEX" - if flag(TestGlpsol) - CPP-Options: "-DTEST_GLPSOL" - if flag(TestGurobiCl) - CPP-Options: "-DTEST_GUROBI_CL" - if flag(TestLPSolve) - CPP-Options: "-DTEST_LP_SOLVE" - if flag(TestSCIP) - CPP-Options: "-DTEST_SCIP" + Other-Extensions: + CPP + DataKinds + ScopedTypeVariables + TemplateHaskell Benchmark BenchmarkSATLIB type: exitcode-stdio-1.0