Removed unsat_core from solver.ml

sat/res.ml

@@ -91,57 +91,28 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct
       raise (Resolution_error "Input cause is a tautology");
     res
 
-  (* Adding new proven clauses *)
+  (* Adding hyptoheses *)
-  let is_proved c = H.mem proof c
-  let is_proven c = is_proved (to_list c)
-
   let is_unit_hyp = function
     | [a] -> St.(a.var.level = 0 && a.var.reason = None && a.var.vpremise <> [])
     | _ -> false
 
-  let unit_learnts a =
+  let is_proved (c, cl) =
-      match St.(a.var.level, a.var.reason, a.var.vpremise) with
+    if H.mem proof cl then
-      | 0, None, [] -> [clause_unit a]
+      true
-      | _ -> []
+    else if is_unit_hyp cl || not St.(c.learnt) then begin
-
-  let need_clause (c, cl) =
-    if is_proved cl then
-      [], []
-    else if not St.(c.learnt) || is_unit_hyp cl then begin
       H.add proof cl Assumption;
-      [], []
+      true
     end else
-      let l =
+      false
-          if List.length cl > 1 then
-              List.flatten (List.map unit_learnts cl)
-          else
-              []
-      in
-      (*
-      Log.debug 0 "Need for : %s" St.(c.name);
-      List.iter (fun c ->
-          Log.debug 0 "  premise: %s" St.(c.name)) St.(c.cpremise);
-      List.iter (fun c ->
-          Log.debug 0 "  unit: %s" St.(c.name)) l;
-          *)
-      St.(c.cpremise), l
 
-  let rec diff_learnt acc l l' =
+  let is_proven c = is_proved (c, to_list c)
-      match l, l' with
-      | [], _ -> l' @ acc
-      | a :: r, b :: r' ->
-              if equal_atoms a b then
-                  diff_learnt acc r r'
-              else
-                  diff_learnt (b :: acc) l r'
-      | _ -> raise (Resolution_error "Impossible to derive correct clause")
 
   let add_res (c, cl_c) (d, cl_d) =
-    Log.debug 7 "Resolving clauses :";
+    Log.debug 7 "  Resolving clauses :";
     Log.debug 7 "    %a" St.pp_clause c;
     Log.debug 7 "    %a" St.pp_clause d;
-    assert (is_proved cl_c);
+    assert (is_proved (c, cl_c));
-    assert (is_proved cl_d);
+    assert (is_proved (c, cl_d));
     let l = List.merge compare_atoms cl_c cl_d in
     let resolved, new_clause = resolve l in
     match resolved with
@@ -153,14 +124,27 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct
       new_c, new_clause
     | _ -> raise (Resolution_error "Resolved to a tautology")
 
-  let add_clause cl l = (* We assume that all clauses in c.cpremise are already proved ! *)
+  let rec diff_learnt acc l l' =
+    match l, l' with
+    | [], _ -> l' @ acc
+    | a :: r, b :: r' ->
+      if equal_atoms a b then
+        diff_learnt acc r r'
+      else
+        diff_learnt (b :: acc) l r'
+    | _ -> raise (Resolution_error "Impossible to derive correct clause")
+
+  let add_clause c cl l = (* We assume that all clauses in l are already proved ! *)
     match l with
     | a :: ((_ :: _) as r) ->
+      Log.debug 5 "Resolving (with history) %a" St.pp_clause c;
       let temp_c, temp_cl = List.fold_left add_res a r in
+      Log.debug 10 " Switching to unit resolutions";
       let unit_to_use = diff_learnt [] cl temp_cl in
       let unit_r = List.map St.(fun a -> clause_unit a.neg, [a.neg]) unit_to_use in
       let new_c, new_cl = List.fold_left add_res (temp_c, temp_cl) unit_r in
       if not (equal_cl cl new_cl) then begin
+        (* We didn't get the expected clause, raise an error *)
         Log.debug 0 "Expected the following clauses to be equal :";
         Log.debug 0 "expected : %s" (Log.on_fmt print_cl cl);
         Log.debug 0 "found : %a" St.pp_clause new_c;
@@ -168,24 +152,28 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct
       end
     | _ -> assert false
 
+  let need_clause (c, cl) =
+    if is_proved (c, cl) then
+      []
+    else
+      St.(c.cpremise)
+
   let rec do_clause = function
     | [] -> ()
     | c :: r ->
       let cl = to_list c in
-      let history, unit_to_learn = need_clause (c, cl) in
+      match need_clause (c, cl) with
-      if history = [] then (* c is either an asusmption, or already proved *)
+      | [] -> do_clause r
-        do_clause r
+      | history ->
-      else
         let history_cl = List.rev_map (fun c -> c, to_list c) history in
-        let to_prove = List.filter (fun (_, cl) -> not (is_proved cl)) history_cl in
+        let to_prove = List.filter (fun (c, cl) -> not (is_proved (c, cl))) history_cl in
-        let to_prove = (List.rev_map fst to_prove) @ unit_to_learn in
+        let to_prove = (List.rev_map fst to_prove) in
-        if to_prove = [] then begin
+        begin match to_prove with
-          (* See wether we can prove c right now *)
+          | [] ->
-          add_clause cl history_cl;
+            add_clause c cl history_cl;
             do_clause r
-        end else
+          | _ -> do_clause (to_prove @ (c :: r))
-          (* Or if we have to prove some other clauses first *)
+        end
-          do_clause (to_prove @ (c :: r))
 
   let prove c =
     Log.debug 3 "Proving : %a" St.pp_clause c;
@@ -195,7 +183,6 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct
   let rec prove_unsat_cl (c, cl) = match cl with
     | [] -> true
     | a :: r ->
-      try
       Log.debug 2 "Eliminating %a in %a" St.pp_atom a St.pp_clause c;
       let d = match St.(a.var.level, a.var.reason) with
         | 0, Some d -> d
@@ -205,7 +192,12 @@ module Make(St : Solver_types.S)(Proof : sig type proof end) = struct
       prove d;
       let cl_d = to_list d in
       prove_unsat_cl (add_res (c, cl) (d, cl_d))
-      with Exit -> false
+
+  let prove_unsat_cl c =
+    try
+      prove_unsat_cl c
+    with Exit ->
+      false
 
   exception Cannot
   let assert_can_prove_unsat c =

sat/sat.ml

@@ -109,13 +109,13 @@ module Make(Dummy : sig end) = struct
     try
       SatSolver.solve ();
       Sat
-    with SatSolver.Unsat _ -> Unsat
+    with SatSolver.Unsat -> Unsat
 
   let assume l =
     incr _i;
     try
       SatSolver.assume l !_i
-    with SatSolver.Unsat _ -> ()
+    with SatSolver.Unsat -> ()
 
   let eval = SatSolver.eval
 

sat/solver.ml

@@ -19,7 +19,7 @@ module Make (F : Formula_intf.S)
   module Proof = Res.Make(St)(Th)
 
   exception Sat
-  exception Unsat of clause list
+  exception Unsat
   exception Restart
   exception Conflict of clause
 
@@ -29,9 +29,6 @@ module Make (F : Formula_intf.S)
     mutable is_unsat : bool;
     (* if [true], constraints are already false *)
 
-    mutable unsat_core : clause list;
-    (* clauses that imply false, if any  *)
-
     mutable unsat_conflict : clause option;
     (* conflict clause at decision level 0, if any *)
 
@@ -119,7 +116,6 @@ module Make (F : Formula_intf.S)
 
   let env = {
     is_unsat = false;
-    unsat_core = [] ;
     unsat_conflict = None;
     clauses = Vec.make 0 dummy_clause; (*updated during parsing*)
     learnts = Vec.make 0 dummy_clause; (*updated during parsing*)
@@ -520,105 +516,17 @@ module Make (F : Formula_intf.S)
 
 
   let report_b_unsat ({atoms=atoms} as confl) =
-    let l = ref [confl] in
-    for i = 0 to Vec.size atoms - 1 do
-      let v = (Vec.get atoms i).var in
-      l := List.rev_append v.vpremise !l;
-      match v.reason with None -> () | Some c -> l := c :: !l
-    done;
-    (*
-    if false then begin
-      eprintf "@.>>UNSAT Deduction made from:@.";
-      List.iter
-        (fun hc ->
-           eprintf "    %a@." pp_clause hc
-        )!l;
-    end;
-    *)
-    let uc = HUC.create 17 in
-    let rec roots todo =
-      match todo with
-      | [] -> ()
-      | c::r ->
-        for i = 0 to Vec.size c.atoms - 1 do
-          let v = (Vec.get c.atoms i).var in
-          if not v.seen then begin
-            v.seen <- true;
-            roots v.vpremise;
-            match v.reason with None -> () | Some r -> roots [r];
-          end
-        done;
-        match c.cpremise with
-        | []    -> if not (HUC.mem uc c) then HUC.add uc c (); roots r
-        | prems -> roots prems; roots r
-    in roots !l;
-    let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in
-    (*
-    if false then begin
-      eprintf "@.>>UNSAT_CORE:@.";
-      List.iter
-        (fun hc ->
-           eprintf "    %a@." pp_clause hc
-        )unsat_core;
-    end;
-    *)
-    env.is_unsat <- true;
-    env.unsat_core <- unsat_core;
     env.unsat_conflict <- Some confl;
-    raise (Unsat unsat_core)
+    env.is_unsat <- true;
-
+    raise Unsat
 
   let report_t_unsat dep =
-    let l =
-      Ex.fold_atoms
-        (fun {var=v} l ->
-           let l = List.rev_append v.vpremise l in
-           match v.reason with None -> l | Some c -> c :: l
-        ) dep []
-    in
-    (*
-    if false then begin
-      eprintf "@.>>T-UNSAT Deduction made from:@.";
-      List.iter
-        (fun hc ->
-           eprintf "    %a@." pp_clause hc
-        )l;
-    end;
-    *)
-    let uc = HUC.create 17 in
-    let rec roots todo =
-      match todo with
-      | [] -> ()
-      | c::r ->
-        for i = 0 to Vec.size c.atoms - 1 do
-          let v = (Vec.get c.atoms i).var in
-          if not v.seen then begin
-            v.seen <- true;
-            roots v.vpremise;
-            match v.reason with None -> () | Some r -> roots [r];
-          end
-        done;
-        match c.cpremise with
-        | []    -> if not (HUC.mem uc c) then HUC.add uc c (); roots r
-        | prems -> roots prems; roots r
-    in roots l;
-    let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in
-    (*
-    if false then begin
-      eprintf "@.>>T-UNSAT_CORE:@.";
-      List.iter
-        (fun hc ->
-           eprintf "    %a@." pp_clause hc
-        ) unsat_core;
-    end;
-    *)
     env.is_unsat <- true;
-    env.unsat_core <- unsat_core;
+    raise Unsat
-    raise (Unsat unsat_core)
 
   let simplify () =
     assert (decision_level () = 0);
-    if env.is_unsat then raise (Unsat env.unsat_core);
+    if env.is_unsat then raise Unsat;
     begin
       match propagate () with
       | Some confl -> report_b_unsat confl
@@ -640,9 +548,12 @@ module Make (F : Formula_intf.S)
       | [] -> assert false
       | [fuip] ->
         assert (blevel = 0);
+        let name = fresh_lname () in
+        let uclause = make_clause name learnt size true history in
         Log.debug 2 "Unit clause learnt : %a" St.pp_atom fuip;
+        Vec.push env.learnts uclause;
         fuip.var.vpremise <- history;
-        enqueue fuip 0 None
+        enqueue fuip 0 (Some uclause)
       | fuip :: _ ->
         let name = fresh_lname () in
         let lclause = make_clause name learnt size true history in
@@ -802,7 +713,7 @@ module Make (F : Formula_intf.S)
   (* fixpoint of propagation and decisions until a model is found, or a
      conflict is reached *)
   let solve () =
-    if env.is_unsat then raise (Unsat env.unsat_core);
+    if env.is_unsat then raise Unsat;
     let n_of_conflicts = ref (to_float env.restart_first) in
     let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in
     try
@@ -816,9 +727,6 @@ module Make (F : Formula_intf.S)
       done;
     with
     | Sat -> ()
-    | (Unsat cl) as e ->
-      (* check_unsat_core cl; *)
-      raise e
 
   exception Trivial
 
@@ -841,7 +749,7 @@ module Make (F : Formula_intf.S)
 
 
   let add_clause ~cnumber atoms =
-    if env.is_unsat then raise (Unsat env.unsat_core);
+    if env.is_unsat then raise Unsat;
     let init_name = string_of_int cnumber in
     let init0 = make_clause init_name atoms (List.length atoms) false [] in
     try
@@ -914,6 +822,7 @@ module Make (F : Formula_intf.S)
     let truth = var.pa.is_true in
     if negated then not truth else truth
 
+  let history () = env.learnts
 
   let unsat_conflict () = env.unsat_conflict
 

sat/solver.mli

@@ -19,7 +19,7 @@ sig
   (** Functor to create a SMT Solver parametrised by the atomic
       formulas and a theory. *)
 
-  exception Unsat of St.clause list
+  exception Unsat
 
   module Proof : Res.S with
     type atom = St.atom and
@@ -40,6 +40,9 @@ sig
   (** Returns the valuation of a formula in the current state
       of the sat solver. *)
 
+  val history : unit -> St.clause Vec.t
+  (** Returns the history of learnt clauses, in the right order. *)
+
   val unsat_conflict : unit -> St.clause option
   (** Returns the unsat clause found at the toplevel, if it exists (i.e if
       [solve] has raised [Unsat]) *)