new interface for sat/Solver, without a Sat exception, nor save/restore. Wip on levels

sat/sat.ml

@@ -23,9 +23,9 @@ module Fsat = struct
   let neg a = - a
   let norm a = abs a, a < 0
 
-  let hash = Hashtbl.hash
+  let hash (a:int) = Hashtbl.hash a
-  let equal = (=)
+  let equal (a:int) b = a=b
-  let compare = Pervasives.compare
+  let compare (a:int) b = Pervasives.compare a b
 
   let _str = Hstring.make ""
   let label a = _str
@@ -107,14 +107,14 @@ module Make(Dummy : sig end) = struct
   let solve () =
     try
       SatSolver.solve ();
-      assert false
+      Sat
-    with
+    with SatSolver.Unsat _ -> Unsat
-    | SatSolver.Sat -> Sat
-    | SatSolver.Unsat _ -> Unsat
 
   let assume l =
     incr _i;
-    SatSolver.assume l !_i
+    try
+      SatSolver.assume l !_i
+    with SatSolver.Unsat _ -> ()
 
   let eval = SatSolver.eval
 end

sat/sat.mli

@@ -26,7 +26,8 @@ module Make(Dummy: sig end) : sig
   val hash : atom -> int
   val equal : atom -> atom -> bool
   val compare : atom -> atom -> int
-  (** Usual hash and comparison functions. For now, directly uses Pervasives and Hashtbl builtins. *)
+  (** Usual hash and comparison functions. For now, directly uses
+      [Pervasives] and [Hashtbl] builtins. *)
 
   val print_atom : Format.formatter -> atom -> unit
   (** Print the atom on the given formatter. *)

sat/solver.ml

@@ -23,57 +23,80 @@ module Make (F : Formula_intf.S)
   exception Restart
   exception Conflict of clause
 
+  (* Singleton type containing the current state *)
   type env = {
-    (* si true_, les contraintes sont deja fausses *)
+
     mutable is_unsat : bool;
+    (* if [true], constraints are already false *)
+
     mutable unsat_core : clause list;
-    (* clauses du probleme *)
+    (* clauses that imply false, if any  *)
-    mutable clauses : clause Vec.t;
+
-    (* clauses apprises *)
+    clauses : clause Vec.t;
-    mutable learnts : clause Vec.t;
+    (* all currently active clauses *)
-    (* valeur de l'increment pour l'activite des clauses *)
+
+    learnts : clause Vec.t;
+    (* learnt clauses  *)
+
     mutable clause_inc : float;
-    (* valeur de l'increment pour l'activite des variables *)
+    (* increment for clauses' activity *)
+
     mutable var_inc : float;
-    (* un vecteur des variables du probleme *)
+    (* increment for variables' activity *)
-    mutable vars : var Vec.t;
+
-    (* la pile de decisions avec les faits impliques *)
+    vars : var Vec.t;
-    mutable trail : atom Vec.t;
+    (* all boolean variables *)
-    (* une pile qui pointe vers les niveaux de decision dans trail *)
+
-    mutable trail_lim : int Vec.t;
+    trail : atom Vec.t;
-    (* Tete de la File des faits unitaires a propager.
+    (* decision stack + propagated atoms *)
-       	   C'est un index vers le trail *)
+
+    trail_lim : int Vec.t;
+    (* decision levels in [trail]  *)
+
+    levels : int Vec.t;
+    (* user-defined levels. Subset of [trail_lim] *)
+
     mutable qhead : int;
-    (* Nombre des assignements top-level depuis la derniere
+    (* Start offset in the queue of unit facts to propagate, within the trail *)
-       execution de 'simplify()' *)
+
     mutable simpDB_assigns : int;
-    (* Nombre restant de propagations a faire avant la prochaine
+    (* number of toplevel assignments since last call to [simplify ()] *)
-       execution de 'simplify()' *)
+
     mutable simpDB_props : int;
-    (* Un tas ordone en fonction de l'activite des variables *)
+    (* remaining number of propagations before the next call to [simplify ()] *)
-    mutable order : Iheap.t;
+
-    (* estimation de progressions, mis a jour par 'search()' *)
+    order : Iheap.t;
+    (* Heap ordered by variable activity *)
+
     mutable progress_estimate : float;
-    (* *)
+    (* progression estimate, updated by [search ()] *)
+
     remove_satisfied : bool;
-    (* inverse du facteur d'acitivte des variables, vaut 1/0.999 par defaut *)
+
     var_decay : float;
-    (* inverse du facteur d'activite des clauses, vaut 1/0.95 par defaut *)
+    (* inverse of the activity factor for variables. Default 1/0.999 *)
+
     clause_decay : float;
-    (* la limite de restart initiale, vaut 100 par defaut *)
+    (* inverse of the activity factor for clauses. Default 1/0.95 *)
+
     mutable restart_first : int;
-    (* facteur de multiplication de restart limite, vaut 1.5 par defaut*)
+    (* intial restart limit, default 100 *)
+
     restart_inc : float;
-    (* limite initiale du nombre de clause apprises, vaut 1/3
+    (* multiplicative factor for restart limit, default 1.5 *)
-       des clauses originales par defaut *)
+
     mutable learntsize_factor : float;
-    (* multiplier learntsize_factor par cette valeur a chaque restart,
+    (* initial limit for the number of learnt clauses, 1/3 of initial
-       vaut 1.1 par defaut *)
+        number of clauses by default *)
+
     learntsize_inc : float;
-    (* controler la minimisation des clauses conflit, vaut true par defaut *)
+    (* multiplicative factor for [learntsize_factor] at each restart, default 1.1 *)
+
     expensive_ccmin : bool;
-    (* controle la polarite a choisir lors de la decision *)
+    (* control minimization of conflict clause, default true *)
+
     polarity_mode : bool;
+    (* default polarity for decision *)
 
     mutable starts : int;
     mutable decisions : int;
@@ -91,28 +114,21 @@ module Make (F : Formula_intf.S)
     mutable tatoms_queue : atom Queue.t;
   }
 
-  type state = {
-    env : env;
-    st_cpt_mk_var: int;
-    st_ma : varmap;
-  }
-
-  type t = state
-
   let env = {
     is_unsat = false;
     unsat_core = [] ;
-    clauses = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*)
+    clauses = Vec.make 0 dummy_clause; (*updated during parsing*)
-    learnts = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*)
+    learnts = Vec.make 0 dummy_clause; (*updated during parsing*)
     clause_inc = 1.;
     var_inc = 1.;
-    vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*)
+    vars = Vec.make 0 dummy_var; (*updated during parsing*)
     trail = Vec.make 601 dummy_atom;
-    trail_lim = Vec.make 601 (-105);
+    trail_lim = Vec.make 601 (-1);
+    levels =  Vec.make 20 (-1);
     qhead = 0;
     simpDB_assigns = -1;
     simpDB_props = 0;
-    order = Iheap.init 0; (* sera mis a jour dans solve *)
+    order = Iheap.init 0; (* updated in solve *)
     progress_estimate = 0.;
     remove_satisfied = true;
     var_decay = 1. /. 0.95;
@@ -139,7 +155,6 @@ module Make (F : Formula_intf.S)
     tatoms_queue = Queue.create ();
   }
 
-
   let f_weight i j =
     (Vec.get env.vars j).weight < (Vec.get env.vars i).weight
 
@@ -741,7 +756,7 @@ module Make (F : Formula_intf.S)
           record_learnt_clause blevel learnt history size
 
         | None ->
-          if nb_assigns () = env.nb_init_vars then raise Sat;
+          if nb_assigns() = env.nb_init_vars then raise Sat;
           if n_of_conflicts >= 0 && !conflictC >= n_of_conflicts then
             begin
               env.progress_estimate <- progress_estimate();
@@ -787,15 +802,15 @@ module Make (F : Formula_intf.S)
     let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in
     try
       while true do
-        (try search (to_int !n_of_conflicts) (to_int !n_of_learnts);
+        begin try
-         with Restart -> ());
+          search (to_int !n_of_conflicts) (to_int !n_of_learnts);
+        with Restart -> ()
+        end;
         n_of_conflicts := !n_of_conflicts *. env.restart_inc;
         n_of_learnts   := !n_of_learnts *. env.learntsize_inc;
       done;
     with
-    | Sat ->
+    | Sat -> ()
-      (*check_model ();*)
-      raise Sat
     | (Unsat cl) as e ->
       (* check_unsat_core cl; *)
       raise e
@@ -893,15 +908,15 @@ module Make (F : Formula_intf.S)
     let empty_theory = Th.empty () in
     env.is_unsat <- false;
     env.unsat_core <- [];
-    env.clauses <- Vec.make 0 dummy_clause;
+    Vec.clear env.clauses;
-    env.learnts <- Vec.make 0 dummy_clause;
+    Vec.clear env.learnts;
     env.clause_inc <- 1.;
     env.var_inc <- 1.;
-    env.vars <- Vec.make 0 dummy_var;
+    Vec.clear env.vars;
     env.qhead <- 0;
     env.simpDB_assigns <- -1;
     env.simpDB_props <- 0;
-    env.order <- Iheap.init 0; (* sera mis a jour dans solve *)
+    Iheap.clear env.order;
     env.progress_estimate <- 0.;
     env.restart_first <- 100;
     env.starts <- 0;
@@ -916,60 +931,35 @@ module Make (F : Formula_intf.S)
     env.nb_init_clauses <- 0;
     env.tenv <- empty_theory;
     env.model <- Vec.make 0 dummy_var;
-    env.trail <- Vec.make 601 dummy_atom;
+    Vec.clear env.trail;
-    env.trail_lim <- Vec.make 601 (-105);
+    Vec.clear env.trail_lim;
     env.tenv_queue <- Vec.make 100 Th.dummy;
     env.tatoms_queue <- Queue.create ();
     St.clear ()
 
-  let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0
-
-  let save () =
-    let sv =
-      { env = env;
-        st_cpt_mk_var = !St.cpt_mk_var;
-        st_ma = !St.ma }
-    in
-    copy sv
-
-  let restore { env = s_env; st_cpt_mk_var = st_cpt_mk_var; st_ma = st_ma } =
-    env.is_unsat <- s_env.is_unsat;
-    env.unsat_core <- s_env.unsat_core;
-    env.clauses <- s_env.clauses;
-    env.learnts <- s_env.learnts;
-    env.clause_inc <- s_env.clause_inc;
-    env.var_inc <- s_env.var_inc;
-    env.vars <- s_env.vars;
-    env.qhead <- s_env.qhead;
-    env.simpDB_assigns <- s_env.simpDB_assigns;
-    env.simpDB_props <- s_env.simpDB_props;
-    env.order <- s_env.order;
-    env.progress_estimate <- s_env.progress_estimate;
-    env.restart_first <- s_env.restart_first;
-    env.starts <- s_env.starts;
-    env.decisions <- s_env.decisions;
-    env.propagations <- s_env.propagations;
-    env.conflicts <- s_env.conflicts;
-    env.clauses_literals <- s_env.clauses_literals;
-    env.learnts_literals <- s_env.learnts_literals;
-    env.max_literals <- s_env.max_literals;
-    env.tot_literals <- s_env.tot_literals;
-    env.nb_init_vars <- s_env.nb_init_vars;
-    env.nb_init_clauses <- s_env.nb_init_clauses;
-    env.tenv <- s_env.tenv;
-    env.model <- s_env.model;
-    env.trail <- s_env.trail;
-    env.trail_lim <- s_env.trail_lim;
-    env.tenv_queue <- s_env.tenv_queue;
-    env.tatoms_queue <- s_env.tatoms_queue;
-    env.learntsize_factor <- s_env.learntsize_factor;
-    St.cpt_mk_var := st_cpt_mk_var;
-    St.ma := st_ma
-
   let eval lit =
     let var, negated = make_var lit in
     let truth = var.pa.is_true in
     if negated then not truth else truth
 
+  type level = int
+
+  let base_level = 0
+
+  let current_level() =
+    if Vec.is_empty env.levels then base_level else Vec.last env.levels
+
+  let push () =
+    let l = if Vec.is_empty env.trail_lim
+      then base_level
+      else Vec.last env.trail_lim
+    in
+    Vec.push env.levels l;
+    l
+
+  let pop l =
+    if l > current_level()
+      then invalid_arg "cannot pop() to level, it is too high";
+    () (* TODO *)
 end
 

sat/solver.mli

@@ -14,34 +14,45 @@
 module Make (F : Formula_intf.S)
     (St : Solver_types.S with type formula = F.t)
     (Ex : Explanation.S with type atom = St.atom)
-    (Th : Theory_intf.S with type formula = F.t and type explanation = Ex.t) : sig
+    (Th : Theory_intf.S with type formula = F.t and type explanation = Ex.t) :
-  (** Functor to create a SMT Solver parametrised by the atomic formulas and a theory. *)
+sig
+  (** Functor to create a SMT Solver parametrised by the atomic
+      formulas and a theory. *)
   
-  exception Sat
   exception Unsat of St.clause list
-  (** Exceptions raised by the [solve] function to return the nature of the current set of assummtions.
-      Once the [Unsat] exception is raised, the solver needs to be cleared before anything else is done. *)
-
-  type t
-  (** The type of the state of the sat solver. Mutable.*)
 
   val solve : unit -> unit
   (** Try and solves the current set of assumptions.
-      @raise Sat if the current set of assummptions is satisfiable.
+      @return () if the current set of clauses is satisfiable
-      @raise Unsat if the current set of assumptions is unsatisfiable *)
+      @raise Unsat if a toplevel conflict is found *)
 
-  val assume : F.t list list -> cnumber : int -> unit
+  val assume : F.t list list -> cnumber:int -> unit
-  (** Add the list of clauses to the current set of assumptions. Modifies the sat solver state in place. *)
+  (** Add the list of clauses to the current set of assumptions.
+      Modifies the sat solver state in place.
+      @raise Unsat if a conflict is detect when adding the clauses *)
 
   val clear : unit -> unit
-  (** Resets everything done. Basically returns the solver to a state similar to when the module was created. *)
+  (** Resets everything done. Basically returns the solver to a
+      state similar to when the module was created. *)
 
   val eval : F.t -> bool
-  (** Returns the valuation of a formula in the current state of the sat solver. *)
+  (** Returns the valuation of a formula in the current state
+      of the sat solver. *)
 
-  val save : unit -> t
+  type level
-  val restore : t -> unit
+  (** Abstract notion of assumption level. *)
-  (** Functions to be replaced by push&pop functions. *)
 
+  val base_level : level
+  (** Level with no assumption at all, corresponding to the empty solver *)
+
+  val current_level : unit -> level
+  (** The current level *)
+
+  val push : unit -> level
+  (** Create a new level that extends the previous one. *)
+
+  val pop : level -> unit
+  (** Go back to the given level, forgetting every assumption added since.
+      @raise Invalid_argument if the current level is below the argument *)
 end