41 (* ------------------------------------------------------------------------- *) |
41 (* ------------------------------------------------------------------------- *) |
42 |
42 |
43 exception NOT_CONFIGURED; |
43 exception NOT_CONFIGURED; |
44 |
44 |
45 (* ------------------------------------------------------------------------- *) |
45 (* ------------------------------------------------------------------------- *) |
46 (* type of partial (satisfying) assignments: 'a i = None' means that 'a' is *) |
46 (* type of partial (satisfying) assignments: 'a i = NONE' means that 'a' is *) |
47 (* a satisfying assigment regardless of the value of variable 'i' *) |
47 (* a satisfying assigment regardless of the value of variable 'i' *) |
48 (* ------------------------------------------------------------------------- *) |
48 (* ------------------------------------------------------------------------- *) |
49 |
49 |
50 type assignment = int -> bool option; |
50 type assignment = int -> bool option; |
51 |
51 |
184 |
184 |
185 (* Path.T -> string * string * string -> result *) |
185 (* Path.T -> string * string * string -> result *) |
186 |
186 |
187 fun parse_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) = |
187 fun parse_std_result_file path (satisfiable, assignment_prefix, unsatisfiable) = |
188 let |
188 let |
189 (* 'a option -> 'a Library.option *) |
189 (* 'a option -> 'a option *) |
190 fun option (SOME a) = |
190 fun option (SOME a) = |
191 Some a |
191 SOME a |
192 | option NONE = |
192 | option NONE = |
193 None |
193 NONE |
194 (* string -> int list *) |
194 (* string -> int list *) |
195 fun int_list_from_string s = |
195 fun int_list_from_string s = |
196 mapfilter (option o Int.fromString) (space_explode " " s) |
196 mapfilter (option o Int.fromString) (space_explode " " s) |
197 (* int list -> assignment *) |
197 (* int list -> assignment *) |
198 fun assignment_from_list [] i = |
198 fun assignment_from_list [] i = |
199 None (* the SAT solver didn't provide a value for this variable *) |
199 NONE (* the SAT solver didn't provide a value for this variable *) |
200 | assignment_from_list (x::xs) i = |
200 | assignment_from_list (x::xs) i = |
201 if x=i then (Some true) |
201 if x=i then (SOME true) |
202 else if x=(~i) then (Some false) |
202 else if x=(~i) then (SOME false) |
203 else assignment_from_list xs i |
203 else assignment_from_list xs i |
204 (* int list -> string list -> assignment *) |
204 (* int list -> string list -> assignment *) |
205 fun parse_assignment xs [] = |
205 fun parse_assignment xs [] = |
206 assignment_from_list xs |
206 assignment_from_list xs |
207 | parse_assignment xs (line::lines) = |
207 | parse_assignment xs (line::lines) = |
363 (* int list *) |
363 (* int list *) |
364 val indices = PropLogic.indices fm |
364 val indices = PropLogic.indices fm |
365 (* int list -> int list -> int list option *) |
365 (* int list -> int list -> int list option *) |
366 (* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *) |
366 (* binary increment: list 'xs' of current bits, list 'ys' of all bits (lower bits first) *) |
367 fun next_list _ ([]:int list) = |
367 fun next_list _ ([]:int list) = |
368 None |
368 NONE |
369 | next_list [] (y::ys) = |
369 | next_list [] (y::ys) = |
370 Some [y] |
370 SOME [y] |
371 | next_list (x::xs) (y::ys) = |
371 | next_list (x::xs) (y::ys) = |
372 if x=y then |
372 if x=y then |
373 (* reset the bit, continue *) |
373 (* reset the bit, continue *) |
374 next_list xs ys |
374 next_list xs ys |
375 else |
375 else |
376 (* set the lowest bit that wasn't set before, keep the higher bits *) |
376 (* set the lowest bit that wasn't set before, keep the higher bits *) |
377 Some (y::x::xs) |
377 SOME (y::x::xs) |
378 (* int list -> int -> bool *) |
378 (* int list -> int -> bool *) |
379 fun assignment_from_list xs i = |
379 fun assignment_from_list xs i = |
380 i mem xs |
380 i mem xs |
381 (* int list -> SatSolver.result *) |
381 (* int list -> SatSolver.result *) |
382 fun solver_loop xs = |
382 fun solver_loop xs = |
383 if PropLogic.eval (assignment_from_list xs) fm then |
383 if PropLogic.eval (assignment_from_list xs) fm then |
384 SatSolver.SATISFIABLE (Some o (assignment_from_list xs)) |
384 SatSolver.SATISFIABLE (SOME o (assignment_from_list xs)) |
385 else |
385 else |
386 (case next_list xs indices of |
386 (case next_list xs indices of |
387 Some xs' => solver_loop xs' |
387 SOME xs' => solver_loop xs' |
388 | None => SatSolver.UNSATISFIABLE) |
388 | NONE => SatSolver.UNSATISFIABLE) |
389 in |
389 in |
390 (* start with the "first" assignment (all variables are interpreted as 'false') *) |
390 (* start with the "first" assignment (all variables are interpreted as 'false') *) |
391 solver_loop [] |
391 solver_loop [] |
392 end |
392 end |
393 in |
393 in |
452 fun dpll xs fm = |
452 fun dpll xs fm = |
453 let |
453 let |
454 val (xs', fm') = eval_and_force xs fm |
454 val (xs', fm') = eval_and_force xs fm |
455 in |
455 in |
456 case fm' of |
456 case fm' of |
457 True => Some xs' |
457 True => SOME xs' |
458 | False => None |
458 | False => NONE |
459 | _ => |
459 | _ => |
460 let |
460 let |
461 val x = the (fresh_var xs') (* a fresh variable must exist since 'fm' did not evaluate to 'True'/'False' *) |
461 val x = the (fresh_var xs') (* a fresh variable must exist since 'fm' did not evaluate to 'True'/'False' *) |
462 in |
462 in |
463 case dpll (x::xs') fm' of (* passing fm' rather than fm should save some simplification work *) |
463 case dpll (x::xs') fm' of (* passing fm' rather than fm should save some simplification work *) |
464 Some xs'' => Some xs'' |
464 SOME xs'' => SOME xs'' |
465 | None => dpll ((~x)::xs') fm' (* now try interpreting 'x' as 'False' *) |
465 | NONE => dpll ((~x)::xs') fm' (* now try interpreting 'x' as 'False' *) |
466 end |
466 end |
467 end |
467 end |
468 (* int list -> assignment *) |
468 (* int list -> assignment *) |
469 fun assignment_from_list [] i = |
469 fun assignment_from_list [] i = |
470 None (* the DPLL procedure didn't provide a value for this variable *) |
470 NONE (* the DPLL procedure didn't provide a value for this variable *) |
471 | assignment_from_list (x::xs) i = |
471 | assignment_from_list (x::xs) i = |
472 if x=i then (Some true) |
472 if x=i then (SOME true) |
473 else if x=(~i) then (Some false) |
473 else if x=(~i) then (SOME false) |
474 else assignment_from_list xs i |
474 else assignment_from_list xs i |
475 in |
475 in |
476 (* initially, no variable is interpreted yet *) |
476 (* initially, no variable is interpreted yet *) |
477 case dpll [] fm' of |
477 case dpll [] fm' of |
478 Some assignment => SatSolver.SATISFIABLE (assignment_from_list assignment) |
478 SOME assignment => SatSolver.SATISFIABLE (assignment_from_list assignment) |
479 | None => SatSolver.UNSATISFIABLE |
479 | NONE => SatSolver.UNSATISFIABLE |
480 end |
480 end |
481 end (* local *) |
481 end (* local *) |
482 in |
482 in |
483 SatSolver.add_solver ("dpll", dpll_solver) |
483 SatSolver.add_solver ("dpll", dpll_solver) |
484 end; |
484 end; |