| author | wenzelm | 
| Tue, 31 May 2005 11:53:14 +0200 | |
| changeset 16123 | 1381e90c2694 | 
| parent 15605 | 0c544d8b521f | 
| child 16270 | 4280d6bbc1bb | 
| permissions | -rw-r--r-- | 
| 14453 | 1 | (* Title: HOL/Tools/sat_solver.ML | 
| 2 | ID: $Id$ | |
| 3 | Author: Tjark Weber | |
| 4 | Copyright 2004 | |
| 5 | ||
| 6 | Interface to external SAT solvers, and (simple) built-in SAT solvers. | |
| 7 | *) | |
| 8 | ||
| 9 | signature SAT_SOLVER = | |
| 10 | sig | |
| 14965 | 11 | exception NOT_CONFIGURED | 
| 14453 | 12 | |
| 14965 | 13 | type assignment = int -> bool option | 
| 14 | datatype result = SATISFIABLE of assignment | |
| 15 | | UNSATISFIABLE | |
| 16 | | UNKNOWN | |
| 17 | type solver = PropLogic.prop_formula -> result | |
| 18 | ||
| 19 | (* auxiliary functions to create external SAT solvers *) | |
| 14453 | 20 | val write_dimacs_cnf_file : Path.T -> PropLogic.prop_formula -> unit | 
| 21 | val write_dimacs_sat_file : Path.T -> PropLogic.prop_formula -> unit | |
| 14965 | 22 | val parse_std_result_file : Path.T -> string * string * string -> result | 
| 23 | val make_external_solver : string -> (PropLogic.prop_formula -> unit) -> (unit -> result) -> solver | |
| 14453 | 24 | |
| 15040 | 25 | val read_dimacs_cnf_file : Path.T -> PropLogic.prop_formula | 
| 26 | ||
| 14453 | 27 | (* generic interface *) | 
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 28 | val solvers : (string * solver) list ref | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 29 | val add_solver : string * solver -> unit | 
| 15605 | 30 | val invoke_solver : string -> solver (* exception Option *) | 
| 14453 | 31 | end; | 
| 32 | ||
| 33 | structure SatSolver : SAT_SOLVER = | |
| 34 | struct | |
| 35 | ||
| 36 | open PropLogic; | |
| 37 | ||
| 38 | (* ------------------------------------------------------------------------- *) | |
| 14965 | 39 | (* should be raised by an external SAT solver to indicate that the solver is *) | 
| 40 | (* not configured properly *) | |
| 41 | (* ------------------------------------------------------------------------- *) | |
| 42 | ||
| 43 | exception NOT_CONFIGURED; | |
| 44 | ||
| 45 | (* ------------------------------------------------------------------------- *) | |
| 15531 | 46 | (* type of partial (satisfying) assignments: 'a i = NONE' means that 'a' is *) | 
| 14965 | 47 | (* a satisfying assigment regardless of the value of variable 'i' *) | 
| 14453 | 48 | (* ------------------------------------------------------------------------- *) | 
| 49 | ||
| 14965 | 50 | type assignment = int -> bool option; | 
| 51 | ||
| 52 | (* ------------------------------------------------------------------------- *) | |
| 53 | (* return type of SAT solvers: if the result is 'SATISFIABLE', a satisfying *) | |
| 54 | (* assignment must be returned as well *) | |
| 55 | (* ------------------------------------------------------------------------- *) | |
| 56 | ||
| 57 | datatype result = SATISFIABLE of assignment | |
| 58 | | UNSATISFIABLE | |
| 59 | | UNKNOWN; | |
| 60 | ||
| 61 | (* ------------------------------------------------------------------------- *) | |
| 62 | (* type of SAT solvers: given a propositional formula, a satisfying *) | |
| 63 | (* assignment may be returned *) | |
| 64 | (* ------------------------------------------------------------------------- *) | |
| 65 | ||
| 66 | type solver = prop_formula -> result; | |
| 14453 | 67 | |
| 68 | (* ------------------------------------------------------------------------- *) | |
| 69 | (* write_dimacs_cnf_file: serializes a formula 'fm' of propositional logic *) | |
| 70 | (* to a file in DIMACS CNF format (see "Satisfiability Suggested *) | |
| 71 | (* Format", May 8 1993, Section 2.1) *) | |
| 72 | (* Note: 'fm' must not contain a variable index less than 1. *) | |
| 14965 | 73 | (* Note: 'fm' must be given in CNF. *) | 
| 14453 | 74 | (* ------------------------------------------------------------------------- *) | 
| 75 | ||
| 76 | (* Path.T -> prop_formula -> unit *) | |
| 77 | ||
| 78 | fun write_dimacs_cnf_file path fm = | |
| 79 | let | |
| 80 | (* prop_formula -> prop_formula *) | |
| 81 | fun cnf_True_False_elim True = | |
| 82 | Or (BoolVar 1, Not (BoolVar 1)) | |
| 83 | | cnf_True_False_elim False = | |
| 84 | And (BoolVar 1, Not (BoolVar 1)) | |
| 85 | | cnf_True_False_elim fm = | |
| 86 | fm (* since 'fm' is in CNF, either 'fm'='True'/'False', or 'fm' does not contain 'True'/'False' at all *) | |
| 87 | (* prop_formula -> int *) | |
| 88 | fun cnf_number_of_clauses (And (fm1,fm2)) = | |
| 89 | (cnf_number_of_clauses fm1) + (cnf_number_of_clauses fm2) | |
| 90 | | cnf_number_of_clauses _ = | |
| 91 | 1 | |
| 92 | (* prop_formula -> string *) | |
| 14999 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 93 | fun cnf_string fm = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 94 | let | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 95 | (* prop_formula -> string list -> string list *) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 96 | fun cnf_string_acc True acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 97 | error "formula is not in CNF" | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 98 | | cnf_string_acc False acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 99 | error "formula is not in CNF" | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 100 | | cnf_string_acc (BoolVar i) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 101 | (assert (i>=1) "formula contains a variable index less than 1"; | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 102 | string_of_int i :: acc) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 103 | | cnf_string_acc (Not (BoolVar i)) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 104 | "-" :: cnf_string_acc (BoolVar i) acc | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 105 | | cnf_string_acc (Not _) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 106 | error "formula is not in CNF" | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 107 | | cnf_string_acc (Or (fm1,fm2)) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 108 | 				cnf_string_acc fm1 (" " :: cnf_string_acc fm2 acc)
 | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 109 | | cnf_string_acc (And (fm1,fm2)) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 110 | 				cnf_string_acc fm1 (" 0\n" :: cnf_string_acc fm2 acc)
 | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 111 | in | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 112 | concat (cnf_string_acc fm []) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 113 | end | 
| 14453 | 114 | in | 
| 115 | File.write path | |
| 116 | (let | |
| 14965 | 117 | val fm' = cnf_True_False_elim fm | 
| 118 | val number_of_vars = maxidx fm' | |
| 119 | val number_of_clauses = cnf_number_of_clauses fm' | |
| 14453 | 120 | in | 
| 121 | "c This file was generated by SatSolver.write_dimacs_cnf_file\n" ^ | |
| 122 | "c (c) Tjark Weber\n" ^ | |
| 14965 | 123 | "p cnf " ^ string_of_int number_of_vars ^ " " ^ string_of_int number_of_clauses ^ "\n" ^ | 
| 14999 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 124 | cnf_string fm' ^ " 0\n" | 
| 14453 | 125 | end) | 
| 126 | end; | |
| 127 | ||
| 128 | (* ------------------------------------------------------------------------- *) | |
| 129 | (* write_dimacs_sat_file: serializes a formula 'fm' of propositional logic *) | |
| 130 | (* to a file in DIMACS SAT format (see "Satisfiability Suggested *) | |
| 131 | (* Format", May 8 1993, Section 2.2) *) | |
| 132 | (* Note: 'fm' must not contain a variable index less than 1. *) | |
| 133 | (* ------------------------------------------------------------------------- *) | |
| 134 | ||
| 135 | (* Path.T -> prop_formula -> unit *) | |
| 136 | ||
| 137 | fun write_dimacs_sat_file path fm = | |
| 138 | let | |
| 139 | (* prop_formula -> string *) | |
| 14999 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 140 | fun sat_string fm = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 141 | let | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 142 | (* prop_formula -> string list -> string list *) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 143 | fun sat_string_acc True acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 144 | "*()" :: acc | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 145 | | sat_string_acc False acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 146 | "+()" :: acc | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 147 | | sat_string_acc (BoolVar i) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 148 | (assert (i>=1) "formula contains a variable index less than 1"; | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 149 | string_of_int i :: acc) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 150 | | sat_string_acc (Not fm) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 151 | 				"-(" :: sat_string_acc fm (")" :: acc)
 | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 152 | | sat_string_acc (Or (fm1,fm2)) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 153 | 				"+(" :: sat_string_acc fm1 (" " :: sat_string_acc fm2 (")" :: acc))
 | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 154 | | sat_string_acc (And (fm1,fm2)) acc = | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 155 | 				"*(" :: sat_string_acc fm1 (" " :: sat_string_acc fm2 (")" :: acc))
 | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 156 | in | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 157 | concat (sat_string_acc fm []) | 
| 
2c39efba8f67
faster conversion into DIMACS CNF and DIMACS SAT format
 webertj parents: 
14965diff
changeset | 158 | end | 
| 14453 | 159 | in | 
| 160 | File.write path | |
| 161 | (let | |
| 162 | val number_of_vars = Int.max (maxidx fm, 1) | |
| 163 | in | |
| 164 | "c This file was generated by SatSolver.write_dimacs_sat_file\n" ^ | |
| 165 | "c (c) Tjark Weber\n" ^ | |
| 14965 | 166 | "p sat " ^ string_of_int number_of_vars ^ "\n" ^ | 
| 167 | 				"(" ^ sat_string fm ^ ")\n"
 | |
| 14453 | 168 | end) | 
| 169 | end; | |
| 170 | ||
| 171 | (* ------------------------------------------------------------------------- *) | |
| 172 | (* parse_std_result_file: scans a SAT solver's output file for a satisfying *) | |
| 14965 | 173 | (* variable assignment. Returns the assignment, or 'UNSATISFIABLE' if *) | 
| 174 | (* the file contains 'unsatisfiable', or 'UNKNOWN' if the file contains *) | |
| 175 | (* neither 'satisfiable' nor 'unsatisfiable'. Empty lines are ignored. *) | |
| 176 | (* The assignment must be given in one or more lines immediately after *) | |
| 177 | (* the line that contains 'satisfiable'. These lines must begin with *) | |
| 178 | (* 'assignment_prefix'. Variables must be separated by " ". Non- *) | |
| 179 | (* integer strings are ignored. If variable i is contained in the *) | |
| 180 | (* assignment, then i is interpreted as 'true'. If ~i is contained in *) | |
| 181 | (* the assignment, then i is interpreted as 'false'. Otherwise the *) | |
| 182 | (* value of i is taken to be unspecified. *) | |
| 14453 | 183 | (* ------------------------------------------------------------------------- *) | 
| 184 | ||
| 14965 | 185 | (* Path.T -> string * string * string -> result *) | 
| 14453 | 186 | |
| 14965 | 187 | fun parse_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) = | 
| 14453 | 188 | let | 
| 189 | (* string -> int list *) | |
| 190 | fun int_list_from_string s = | |
| 15605 | 191 | List.mapPartial Int.fromString (space_explode " " s) | 
| 14965 | 192 | (* int list -> assignment *) | 
| 14453 | 193 | fun assignment_from_list [] i = | 
| 15531 | 194 | NONE (* the SAT solver didn't provide a value for this variable *) | 
| 14453 | 195 | | assignment_from_list (x::xs) i = | 
| 15531 | 196 | if x=i then (SOME true) | 
| 197 | else if x=(~i) then (SOME false) | |
| 14453 | 198 | else assignment_from_list xs i | 
| 14965 | 199 | (* int list -> string list -> assignment *) | 
| 200 | fun parse_assignment xs [] = | |
| 201 | assignment_from_list xs | |
| 202 | | parse_assignment xs (line::lines) = | |
| 203 | if String.isPrefix assignment_prefix line then | |
| 204 | parse_assignment (xs @ int_list_from_string line) lines | |
| 205 | else | |
| 206 | assignment_from_list xs | |
| 14453 | 207 | (* string -> string -> bool *) | 
| 208 | fun is_substring needle haystack = | |
| 209 | let | |
| 210 | val length1 = String.size needle | |
| 211 | val length2 = String.size haystack | |
| 212 | in | |
| 213 | if length2 < length1 then | |
| 214 | false | |
| 215 | else if needle = String.substring (haystack, 0, length1) then | |
| 216 | true | |
| 217 | else is_substring needle (String.substring (haystack, 1, length2-1)) | |
| 218 | end | |
| 14965 | 219 | (* string list -> result *) | 
| 14453 | 220 | fun parse_lines [] = | 
| 14965 | 221 | UNKNOWN | 
| 14453 | 222 | | parse_lines (line::lines) = | 
| 14965 | 223 | if is_substring satisfiable line then | 
| 224 | SATISFIABLE (parse_assignment [] lines) | |
| 225 | else if is_substring unsatisfiable line then | |
| 226 | UNSATISFIABLE | |
| 14453 | 227 | else | 
| 228 | parse_lines lines | |
| 229 | in | |
| 15570 | 230 | (parse_lines o (List.filter (fn l => l <> "")) o split_lines o File.read) path | 
| 14453 | 231 | end; | 
| 232 | ||
| 233 | (* ------------------------------------------------------------------------- *) | |
| 234 | (* make_external_solver: call 'writefn', execute 'cmd', call 'readfn' *) | |
| 235 | (* ------------------------------------------------------------------------- *) | |
| 236 | ||
| 14965 | 237 | (* string -> (PropLogic.prop_formula -> unit) -> (unit -> result) -> solver *) | 
| 14453 | 238 | |
| 239 | fun make_external_solver cmd writefn readfn fm = | |
| 14965 | 240 | (writefn fm; system cmd; readfn ()); | 
| 14453 | 241 | |
| 242 | (* ------------------------------------------------------------------------- *) | |
| 15040 | 243 | (* read_dimacs_cnf_file: returns a propositional formula that corresponds to *) | 
| 244 | (* a SAT problem given in DIMACS CNF format *) | |
| 245 | (* ------------------------------------------------------------------------- *) | |
| 246 | ||
| 247 | (* Path.T -> PropLogic.prop_formula *) | |
| 248 | ||
| 249 | fun read_dimacs_cnf_file path = | |
| 250 | let | |
| 251 | (* string list -> string list *) | |
| 252 | fun filter_preamble [] = | |
| 253 | error "problem line not found in DIMACS CNF file" | |
| 254 | | filter_preamble (line::lines) = | |
| 255 | if String.isPrefix "c " line then | |
| 256 | (* ignore comments *) | |
| 257 | filter_preamble lines | |
| 258 | else if String.isPrefix "p " line then | |
| 259 | (* ignore the problem line (which must be the last line of the preamble) *) | |
| 260 | (* Ignoring the problem line implies that if the file contains more clauses *) | |
| 261 | (* or variables than specified in its preamble, we will accept it anyway. *) | |
| 262 | lines | |
| 263 | else | |
| 264 | error "preamble in DIMACS CNF file contains a line that does not begin with \"c \" or \"p \"" | |
| 265 | (* string -> int *) | |
| 266 | fun int_from_string s = | |
| 267 | case Int.fromString s of | |
| 268 | SOME i => i | |
| 269 | 			| NONE   => error ("token " ^ quote s ^ "in DIMACS CNF file is not a number")
 | |
| 270 | (* int list -> int list list *) | |
| 271 | fun clauses xs = | |
| 272 | let | |
| 273 | val (xs1, xs2) = take_prefix (fn i => i <> 0) xs | |
| 274 | in | |
| 15128 | 275 | case xs2 of | 
| 276 | [] => [xs1] | |
| 277 | | (0::[]) => [xs1] | |
| 278 | | (0::tl) => xs1 :: clauses tl | |
| 15329 | 279 | | _ => raise ERROR (* this cannot happen *) | 
| 15040 | 280 | end | 
| 281 | (* int -> PropLogic.prop_formula *) | |
| 282 | fun literal_from_int i = | |
| 283 | (assert (i<>0) "variable index in DIMACS CNF file is 0"; | |
| 284 | if i>0 then | |
| 285 | PropLogic.BoolVar i | |
| 286 | else | |
| 287 | PropLogic.Not (PropLogic.BoolVar (~i))) | |
| 288 | (* PropLogic.prop_formula list -> PropLogic.prop_formula *) | |
| 289 | fun disjunction [] = | |
| 290 | error "empty clause in DIMACS CNF file" | |
| 291 | | disjunction (x::xs) = | |
| 292 | (case xs of | |
| 293 | [] => x | |
| 294 | | _ => PropLogic.Or (x, disjunction xs)) | |
| 295 | (* PropLogic.prop_formula list -> PropLogic.prop_formula *) | |
| 296 | fun conjunction [] = | |
| 297 | error "no clause in DIMACS CNF file" | |
| 298 | | conjunction (x::xs) = | |
| 299 | (case xs of | |
| 300 | [] => x | |
| 301 | | _ => PropLogic.And (x, conjunction xs)) | |
| 302 | in | |
| 303 | (conjunction | |
| 304 | o (map disjunction) | |
| 305 | o (map (map literal_from_int)) | |
| 306 | o clauses | |
| 307 | o (map int_from_string) | |
| 15570 | 308 | o List.concat | 
| 15040 | 309 | o (map (String.fields (fn c => c mem [#" ", #"\t", #"\n"]))) | 
| 310 | o filter_preamble | |
| 15570 | 311 | o (List.filter (fn l => l <> "")) | 
| 15040 | 312 | o split_lines | 
| 313 | o File.read) | |
| 314 | path | |
| 315 | end; | |
| 316 | ||
| 317 | (* ------------------------------------------------------------------------- *) | |
| 14453 | 318 | (* solvers: a (reference to a) table of all registered SAT solvers *) | 
| 319 | (* ------------------------------------------------------------------------- *) | |
| 320 | ||
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 321 | val solvers = ref ([] : (string * solver) list); | 
| 14453 | 322 | |
| 323 | (* ------------------------------------------------------------------------- *) | |
| 324 | (* add_solver: updates 'solvers' by adding a new solver *) | |
| 325 | (* ------------------------------------------------------------------------- *) | |
| 326 | ||
| 327 | (* string * solver -> unit *) | |
| 328 | ||
| 329 | fun add_solver (name, new_solver) = | |
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 330 | 		(solvers := overwrite_warn (!solvers, (name, new_solver)) ("SAT solver " ^ quote name ^ " was defined before"));
 | 
| 14453 | 331 | |
| 332 | (* ------------------------------------------------------------------------- *) | |
| 333 | (* invoke_solver: returns the solver associated with the given 'name' *) | |
| 15605 | 334 | (* Note: If no solver is associated with 'name', exception 'Option' will be *) | 
| 14453 | 335 | (* raised. *) | 
| 336 | (* ------------------------------------------------------------------------- *) | |
| 337 | ||
| 338 | (* string -> solver *) | |
| 339 | ||
| 340 | fun invoke_solver name = | |
| 15570 | 341 | (valOf o assoc) (!solvers, name); | 
| 14453 | 342 | |
| 343 | end; (* SatSolver *) | |
| 344 | ||
| 345 | ||
| 346 | (* ------------------------------------------------------------------------- *) | |
| 347 | (* Predefined SAT solvers *) | |
| 348 | (* ------------------------------------------------------------------------- *) | |
| 349 | ||
| 350 | (* ------------------------------------------------------------------------- *) | |
| 14753 | 351 | (* Internal SAT solver, available as 'SatSolver.invoke_solver "enumerate"' *) | 
| 352 | (* -- simply enumerates assignments until a satisfying assignment is found *) | |
| 14453 | 353 | (* ------------------------------------------------------------------------- *) | 
| 354 | ||
| 355 | let | |
| 356 | fun enum_solver fm = | |
| 357 | let | |
| 358 | (* int list *) | |
| 359 | val indices = PropLogic.indices fm | |
| 360 | (* int list -> int list -> int list option *) | |
| 361 | (* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *) | |
| 362 | fun next_list _ ([]:int list) = | |
| 15531 | 363 | NONE | 
| 14453 | 364 | | next_list [] (y::ys) = | 
| 15531 | 365 | SOME [y] | 
| 14453 | 366 | | next_list (x::xs) (y::ys) = | 
| 367 | if x=y then | |
| 368 | (* reset the bit, continue *) | |
| 369 | next_list xs ys | |
| 370 | else | |
| 371 | (* set the lowest bit that wasn't set before, keep the higher bits *) | |
| 15531 | 372 | SOME (y::x::xs) | 
| 14453 | 373 | (* int list -> int -> bool *) | 
| 374 | fun assignment_from_list xs i = | |
| 375 | i mem xs | |
| 14965 | 376 | (* int list -> SatSolver.result *) | 
| 14453 | 377 | fun solver_loop xs = | 
| 378 | if PropLogic.eval (assignment_from_list xs) fm then | |
| 15531 | 379 | SatSolver.SATISFIABLE (SOME o (assignment_from_list xs)) | 
| 14453 | 380 | else | 
| 381 | (case next_list xs indices of | |
| 15531 | 382 | SOME xs' => solver_loop xs' | 
| 383 | | NONE => SatSolver.UNSATISFIABLE) | |
| 14453 | 384 | in | 
| 14965 | 385 | (* start with the "first" assignment (all variables are interpreted as 'false') *) | 
| 14453 | 386 | solver_loop [] | 
| 387 | end | |
| 388 | in | |
| 14965 | 389 | 	SatSolver.add_solver ("enumerate", enum_solver)
 | 
| 14453 | 390 | end; | 
| 391 | ||
| 392 | (* ------------------------------------------------------------------------- *) | |
| 14753 | 393 | (* Internal SAT solver, available as 'SatSolver.invoke_solver "dpll"' -- a *) | 
| 394 | (* simple implementation of the DPLL algorithm (cf. L. Zhang, S. Malik: "The *) | |
| 395 | (* Quest for Efficient Boolean Satisfiability Solvers", July 2002, Fig. 1). *) | |
| 14453 | 396 | (* ------------------------------------------------------------------------- *) | 
| 397 | ||
| 398 | let | |
| 399 | local | |
| 400 | open PropLogic | |
| 401 | in | |
| 402 | fun dpll_solver fm = | |
| 403 | let | |
| 14965 | 404 | (* We could use 'PropLogic.defcnf fm' instead of 'PropLogic.nnf fm' *) | 
| 405 | (* but that sometimes introduces more boolean variables than we can *) | |
| 406 | (* handle efficiently. *) | |
| 14514 | 407 | val fm' = PropLogic.nnf fm | 
| 14453 | 408 | (* int list *) | 
| 14514 | 409 | val indices = PropLogic.indices fm' | 
| 14453 | 410 | (* int list -> int -> prop_formula *) | 
| 411 | fun partial_var_eval [] i = BoolVar i | |
| 412 | | partial_var_eval (x::xs) i = if x=i then True else if x=(~i) then False else partial_var_eval xs i | |
| 413 | (* int list -> prop_formula -> prop_formula *) | |
| 414 | fun partial_eval xs True = True | |
| 415 | | partial_eval xs False = False | |
| 416 | | partial_eval xs (BoolVar i) = partial_var_eval xs i | |
| 417 | | partial_eval xs (Not fm) = SNot (partial_eval xs fm) | |
| 418 | | partial_eval xs (Or (fm1, fm2)) = SOr (partial_eval xs fm1, partial_eval xs fm2) | |
| 419 | | partial_eval xs (And (fm1, fm2)) = SAnd (partial_eval xs fm1, partial_eval xs fm2) | |
| 420 | (* prop_formula -> int list *) | |
| 421 | fun forced_vars True = [] | |
| 422 | | forced_vars False = [] | |
| 423 | | forced_vars (BoolVar i) = [i] | |
| 424 | | forced_vars (Not (BoolVar i)) = [~i] | |
| 425 | | forced_vars (Or (fm1, fm2)) = (forced_vars fm1) inter_int (forced_vars fm2) | |
| 426 | | forced_vars (And (fm1, fm2)) = (forced_vars fm1) union_int (forced_vars fm2) | |
| 427 | (* Above, i *and* ~i may be forced. In this case the first occurrence takes *) | |
| 428 | (* precedence, and the next partial evaluation of the formula returns 'False'. *) | |
| 429 | | forced_vars _ = raise ERROR (* formula is not in negation normal form *) | |
| 430 | (* int list -> prop_formula -> (int list * prop_formula) *) | |
| 431 | fun eval_and_force xs fm = | |
| 432 | let | |
| 433 | val fm' = partial_eval xs fm | |
| 434 | val xs' = forced_vars fm' | |
| 435 | in | |
| 436 | if null xs' then | |
| 437 | (xs, fm') | |
| 438 | else | |
| 439 | eval_and_force (xs@xs') fm' (* xs and xs' should be distinct, so '@' here should have *) | |
| 440 | (* the same effect as 'union_int' *) | |
| 441 | end | |
| 442 | (* int list -> int option *) | |
| 443 | fun fresh_var xs = | |
| 444 | Library.find_first (fn i => not (i mem_int xs) andalso not ((~i) mem_int xs)) indices | |
| 445 | (* int list -> prop_formula -> int list option *) | |
| 446 | (* partial assignment 'xs' *) | |
| 447 | fun dpll xs fm = | |
| 448 | let | |
| 449 | val (xs', fm') = eval_and_force xs fm | |
| 450 | in | |
| 451 | case fm' of | |
| 15531 | 452 | True => SOME xs' | 
| 453 | | False => NONE | |
| 14453 | 454 | | _ => | 
| 455 | let | |
| 15570 | 456 | val x = valOf (fresh_var xs') (* a fresh variable must exist since 'fm' did not evaluate to 'True'/'False' *) | 
| 14453 | 457 | in | 
| 458 | case dpll (x::xs') fm' of (* passing fm' rather than fm should save some simplification work *) | |
| 15531 | 459 | SOME xs'' => SOME xs'' | 
| 460 | | NONE => dpll ((~x)::xs') fm' (* now try interpreting 'x' as 'False' *) | |
| 14453 | 461 | end | 
| 462 | end | |
| 14965 | 463 | (* int list -> assignment *) | 
| 14453 | 464 | fun assignment_from_list [] i = | 
| 15531 | 465 | NONE (* the DPLL procedure didn't provide a value for this variable *) | 
| 14453 | 466 | | assignment_from_list (x::xs) i = | 
| 15531 | 467 | if x=i then (SOME true) | 
| 468 | else if x=(~i) then (SOME false) | |
| 14453 | 469 | else assignment_from_list xs i | 
| 470 | in | |
| 471 | (* initially, no variable is interpreted yet *) | |
| 14965 | 472 | case dpll [] fm' of | 
| 15531 | 473 | SOME assignment => SatSolver.SATISFIABLE (assignment_from_list assignment) | 
| 474 | | NONE => SatSolver.UNSATISFIABLE | |
| 14453 | 475 | end | 
| 476 | end (* local *) | |
| 477 | in | |
| 14965 | 478 | 	SatSolver.add_solver ("dpll", dpll_solver)
 | 
| 14453 | 479 | end; | 
| 480 | ||
| 481 | (* ------------------------------------------------------------------------- *) | |
| 14753 | 482 | (* Internal SAT solver, available as 'SatSolver.invoke_solver "auto"': uses *) | 
| 15299 
576fd0b65ed8
solver auto now returns the result of the first solver that does not raise NOT_CONFIGURED (which may be UNKNOWN)
 webertj parents: 
15128diff
changeset | 483 | (* the first installed solver (other than "auto" itself) that does not raise *) | 
| 
576fd0b65ed8
solver auto now returns the result of the first solver that does not raise NOT_CONFIGURED (which may be UNKNOWN)
 webertj parents: 
15128diff
changeset | 484 | (* 'NOT_CONFIGURED'. (However, the solver may return 'UNKNOWN'.) *) | 
| 14453 | 485 | (* ------------------------------------------------------------------------- *) | 
| 486 | ||
| 487 | let | |
| 488 | fun auto_solver fm = | |
| 14965 | 489 | let | 
| 490 | fun loop [] = | |
| 491 | SatSolver.UNKNOWN | |
| 492 | | loop ((name, solver)::solvers) = | |
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 493 | if name="auto" then | 
| 14965 | 494 | (* do not call solver "auto" from within "auto" *) | 
| 495 | loop solvers | |
| 15299 
576fd0b65ed8
solver auto now returns the result of the first solver that does not raise NOT_CONFIGURED (which may be UNKNOWN)
 webertj parents: 
15128diff
changeset | 496 | else ( | 
| 14965 | 497 | (if name="dpll" orelse name="enumerate" then | 
| 14805 
eff7b9df27e9
solver "auto" now issues a warning when it uses solver "enumerate"
 webertj parents: 
14753diff
changeset | 498 | 					warning ("Using SAT solver " ^ quote name ^ "; for better performance, consider using an external solver.")
 | 
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 499 | else | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 500 | ()); | 
| 14965 | 501 | (* apply 'solver' to 'fm' *) | 
| 15299 
576fd0b65ed8
solver auto now returns the result of the first solver that does not raise NOT_CONFIGURED (which may be UNKNOWN)
 webertj parents: 
15128diff
changeset | 502 | solver fm | 
| 
576fd0b65ed8
solver auto now returns the result of the first solver that does not raise NOT_CONFIGURED (which may be UNKNOWN)
 webertj parents: 
15128diff
changeset | 503 | handle SatSolver.NOT_CONFIGURED => loop solvers | 
| 14965 | 504 | ) | 
| 505 | in | |
| 506 | loop (rev (!SatSolver.solvers)) | |
| 507 | end | |
| 14453 | 508 | in | 
| 509 | 	SatSolver.add_solver ("auto", auto_solver)
 | |
| 510 | end; | |
| 511 | ||
| 512 | (* ------------------------------------------------------------------------- *) | |
| 15332 | 513 | (* zChaff (http://www.princeton.edu/~chaff/zchaff.html) *) | 
| 14453 | 514 | (* ------------------------------------------------------------------------- *) | 
| 515 | ||
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 516 | let | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 517 | fun zchaff fm = | 
| 14453 | 518 | let | 
| 14965 | 519 | val _ = if (getenv "ZCHAFF_HOME") = "" then raise SatSolver.NOT_CONFIGURED else () | 
| 15332 | 520 | val _ = if (getenv "ZCHAFF_VERSION") <> "2004.5.13" andalso | 
| 521 | (getenv "ZCHAFF_VERSION") <> "2004.11.15" then raise SatSolver.NOT_CONFIGURED else () | |
| 522 | (* both versions of zChaff appear to have the same interface, so we do *) | |
| 523 | (* not actually need to distinguish between them in the following code *) | |
| 14965 | 524 | val inpath = File.tmp_path (Path.unpack "isabelle.cnf") | 
| 525 | val outpath = File.tmp_path (Path.unpack "result") | |
| 14453 | 526 | val cmd = (getenv "ZCHAFF_HOME") ^ "/zchaff " ^ (Path.pack inpath) ^ " > " ^ (Path.pack outpath) | 
| 14965 | 527 | fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm) | 
| 15040 | 528 | 		fun readfn ()  = SatSolver.parse_std_result_file outpath ("Instance Satisfiable", "", "Instance Unsatisfiable")
 | 
| 15313 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 529 | 		val _          = if File.exists inpath then warning ("overwriting existing file " ^ quote (File.sysify_path inpath)) else ()
 | 
| 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 530 | 		val _          = if File.exists outpath then warning ("overwriting existing file " ^ quote (File.sysify_path outpath)) else ()
 | 
| 14965 | 531 | val result = SatSolver.make_external_solver cmd writefn readfn fm | 
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 532 | val _ = (File.rm inpath handle _ => ()) | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 533 | val _ = (File.rm outpath handle _ => ()) | 
| 14453 | 534 | in | 
| 14965 | 535 | result | 
| 14453 | 536 | end | 
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 537 | in | 
| 14965 | 538 | 	SatSolver.add_solver ("zchaff", zchaff)
 | 
| 539 | end; | |
| 540 | ||
| 541 | (* ------------------------------------------------------------------------- *) | |
| 542 | (* BerkMin 561 (http://eigold.tripod.com/BerkMin.html) *) | |
| 543 | (* ------------------------------------------------------------------------- *) | |
| 544 | ||
| 545 | let | |
| 546 | fun berkmin fm = | |
| 547 | let | |
| 548 | val _ = if (getenv "BERKMIN_HOME") = "" orelse (getenv "BERKMIN_EXE") = "" then raise SatSolver.NOT_CONFIGURED else () | |
| 549 | val inpath = File.tmp_path (Path.unpack "isabelle.cnf") | |
| 550 | val outpath = File.tmp_path (Path.unpack "result") | |
| 551 | val cmd = (getenv "BERKMIN_HOME") ^ "/" ^ (getenv "BERKMIN_EXE") ^ " " ^ (Path.pack inpath) ^ " > " ^ (Path.pack outpath) | |
| 552 | fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm) | |
| 553 | 		fun readfn ()  = SatSolver.parse_std_result_file outpath ("Satisfiable          !!", "solution =", "UNSATISFIABLE          !!")
 | |
| 15313 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 554 | 		val _          = if File.exists inpath then warning ("overwriting existing file " ^ quote (File.sysify_path inpath)) else ()
 | 
| 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 555 | 		val _          = if File.exists outpath then warning ("overwriting existing file " ^ quote (File.sysify_path outpath)) else ()
 | 
| 14965 | 556 | val result = SatSolver.make_external_solver cmd writefn readfn fm | 
| 557 | val _ = (File.rm inpath handle _ => ()) | |
| 558 | val _ = (File.rm outpath handle _ => ()) | |
| 559 | in | |
| 560 | result | |
| 561 | end | |
| 562 | in | |
| 563 | 	SatSolver.add_solver ("berkmin", berkmin)
 | |
| 564 | end; | |
| 565 | ||
| 566 | (* ------------------------------------------------------------------------- *) | |
| 567 | (* Jerusat 1.3 (http://www.cs.tau.ac.il/~ale1/) *) | |
| 568 | (* ------------------------------------------------------------------------- *) | |
| 569 | ||
| 570 | let | |
| 571 | fun jerusat fm = | |
| 572 | let | |
| 573 | val _ = if (getenv "JERUSAT_HOME") = "" then raise SatSolver.NOT_CONFIGURED else () | |
| 574 | val inpath = File.tmp_path (Path.unpack "isabelle.cnf") | |
| 575 | val outpath = File.tmp_path (Path.unpack "result") | |
| 576 | val cmd = (getenv "JERUSAT_HOME") ^ "/Jerusat1.3 " ^ (Path.pack inpath) ^ " > " ^ (Path.pack outpath) | |
| 577 | fun writefn fm = SatSolver.write_dimacs_cnf_file inpath (PropLogic.defcnf fm) | |
| 578 | 		fun readfn ()  = SatSolver.parse_std_result_file outpath ("s SATISFIABLE", "v ", "s UNSATISFIABLE")
 | |
| 15313 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 579 | 		val _          = if File.exists inpath then warning ("overwriting existing file " ^ quote (File.sysify_path inpath)) else ()
 | 
| 
24aee76539df
external solvers may now overwrite existing temporary files
 webertj parents: 
15299diff
changeset | 580 | 		val _          = if File.exists outpath then warning ("overwriting existing file " ^ quote (File.sysify_path outpath)) else ()
 | 
| 14965 | 581 | val result = SatSolver.make_external_solver cmd writefn readfn fm | 
| 582 | val _ = (File.rm inpath handle _ => ()) | |
| 583 | val _ = (File.rm outpath handle _ => ()) | |
| 584 | in | |
| 585 | result | |
| 586 | end | |
| 587 | in | |
| 588 | 	SatSolver.add_solver ("jerusat", jerusat)
 | |
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 589 | end; | 
| 14453 | 590 | |
| 591 | (* ------------------------------------------------------------------------- *) | |
| 592 | (* Add code for other SAT solvers below. *) | |
| 593 | (* ------------------------------------------------------------------------- *) | |
| 594 | ||
| 595 | (* | |
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 596 | let | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 597 | fun mysolver fm = ... | 
| 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 598 | in | 
| 14965 | 599 | 	SatSolver.add_solver ("myname", (fn fm => if mysolver_is_configured then mysolver fm else raise SatSolver.NOT_CONFIGURED));  -- register the solver
 | 
| 14487 
157d0ea7b2da
Installed solvers now determined at call time (as opposed to compile time)
 webertj parents: 
14460diff
changeset | 600 | end; | 
| 14453 | 601 | |
| 602 | -- the solver is now available as SatSolver.invoke_solver "myname" | |
| 603 | *) |