diff --git a/sat/res.ml b/sat/res.ml index 5cd34a5f..3b86d831 100644 --- a/sat/res.ml +++ b/sat/res.ml @@ -43,6 +43,9 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct let equal_atoms a b = St.(a.aid) = St.(b.aid) let compare_atoms a b = Pervasives.compare St.(a.aid) St.(b.aid) + let _c = ref 0 + let fresh_pcl_name () = incr _c; "P" ^ (string_of_int !_c) + (* Printing functions *) let print_atom fmt a = Format.fprintf fmt "%s%d" St.(if a.var.pa == a then "" else "-") St.(a.var.vid + 1) @@ -93,7 +96,7 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct | [] -> raise (Resolution_error "No literal to resolve over") | [a] -> H.add proof new_clause (Resolution (a, (c, cl_c), (d, cl_d))); - let new_c = St.make_clause (St.fresh_name ()) new_clause (List.length new_clause) true [c; d] in + let new_c = St.make_clause (fresh_pcl_name ()) new_clause (List.length new_clause) true [c; d] in Log.debug 5 "New clause : %a" St.pp_clause new_c; new_c, new_clause | _ -> raise (Resolution_error "Resolved to a tautology") @@ -146,7 +149,7 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct let clause_unit a = St.( let l = if a.is_true then [a] else [a.neg] in - make_clause (fresh_name ()) l 1 true a.var.vpremise + make_clause (fresh_pcl_name ()) l 1 true a.var.vpremise ) let rec prove_unsat_cl (c, cl) = match cl with @@ -225,38 +228,49 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct let print_clause fmt c = print_cl fmt (to_list c) - let print_dot_rule f arg fmt cl = - Format.fprintf fmt "%s [shape=plaintext, label=<%a
>];@\n" - (c_id cl) "BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\"" f arg + let print_dot_rule opt f arg fmt cl = + Format.fprintf fmt "%s [shape=plaintext, label=<%a
>];@\n" + (c_id cl) "BORDER=\"0\" CELLBORDER=\"1\" CELLSPACING=\"0\"" opt f arg - let print_dot_edge c fmt d = - Format.fprintf fmt "%s -> %s;@\n" (c_id c) (c_id d) + let print_dot_edge id_c fmt id_d = + Format.fprintf fmt "%s -> %s;@\n" id_c id_d + + let print_res_atom id fmt a = + Format.fprintf fmt "%s [label=\"%a\"]" id print_atom a + + let print_res_node concl p1 p2 fmt atom = + let id = new_id () in + Format.fprintf fmt "%a;@\n%a%a%a" + (print_res_atom id) atom + (print_dot_edge (c_id concl)) id + (print_dot_edge id) (c_id p1) + (print_dot_edge id) (c_id p2) let rec print_dot_proof fmt p = match p.step with | Hypothesis -> let aux fmt () = - Format.fprintf fmt "%a" - print_clause p.conclusion + Format.fprintf fmt "%aHypothesis%s" + print_clause p.conclusion St.(p.conclusion.name) in - print_dot_rule aux () fmt p.conclusion + print_dot_rule "BGCOLOR=\"LIGHTBLUE\"" aux () fmt p.conclusion | Lemma _ -> let aux fmt () = - Format.fprintf fmt "%ato prove ..." - print_clause p.conclusion + Format.fprintf fmt "%aLemma%s" + print_clause p.conclusion St.(p.conclusion.name) in - print_dot_rule aux () fmt p.conclusion + print_dot_rule "BGCOLOR=\"RED\"" aux () fmt p.conclusion | Resolution (proof1, proof2, a) -> let aux fmt () = - Format.fprintf fmt "%a%a" - print_clause p.conclusion print_atom a + Format.fprintf fmt "%a%s%s" + print_clause p.conclusion + "Resolution" St.(p.conclusion.name) in let p1 = proof1 () in let p2 = proof2 () in - Format.fprintf fmt "%a%a%a%a%a" - (print_dot_rule aux ()) p.conclusion - (print_dot_edge p.conclusion) p1.conclusion - (print_dot_edge p.conclusion) p2.conclusion + Format.fprintf fmt "%a%a%a%a" + (print_dot_rule "" aux ()) p.conclusion + (print_res_node p.conclusion p1.conclusion p2.conclusion) a print_dot_proof p1 print_dot_proof p2 diff --git a/util/sat_solve.ml b/util/sat_solve.ml index 9f7fee14..7805a3c3 100644 --- a/util/sat_solve.ml +++ b/util/sat_solve.ml @@ -7,7 +7,8 @@ exception Out_of_space (* Arguments parsing *) let file = ref "" let p_assign = ref false -let p_proof = ref false +let p_proof_check = ref false +let p_proof_print = ref false let time_limit = ref 300. let size_limit = ref 1000_000_000. @@ -43,11 +44,13 @@ let usage = "Usage : main [options] " let argspec = Arg.align [ "-bt", Arg.Unit (fun () -> Printexc.record_backtrace true), " Enable stack traces"; + "-check", Arg.Set p_proof_check, + " Build and check the proof, if unsat"; "-gc", Arg.Unit setup_gc_stat, " Outputs statistics about the GC"; "-model", Arg.Set p_assign, " Outputs the boolean model found if sat"; - "-p", Arg.Set p_proof, + "-p", Arg.Unit (fun () -> p_proof_check := true; p_proof_print := true), " Outputs the proof found (in dot format) if unsat"; "-s", Arg.String (int_arg size_limit), "[kMGT] Sets the size limit for the sat solver"; @@ -107,11 +110,13 @@ let main () = if !p_assign then print_assign Format.std_formatter () | S.Unsat -> - Format.printf "Unsat@."; - if !p_proof then begin + if !p_proof_check then begin + Format.printf "/* Unsat */@."; let p = S.get_proof () in - S.print_proof Format.std_formatter p - end + if !p_proof_print then + S.print_proof Format.std_formatter p + end else + Format.printf "Unsat@." let () = try