Solver module is now functorised. 'make' now compiles.

Makefile

@@ -18,6 +18,9 @@ $(LIB):
 doc:
 	$(COMP) $(FLAGS) $(DIRS) $(DOC)
 
+log:
+	cat _build/$(LOG) || true
+
 clean:
 	$(COMP) -clean
 

_tags

@@ -1,2 +1,3 @@
 <smt/*.cmx>: for-pack(Msat)
+<sat/*.cmx>: for-pack(Msat)
 

msat.mlpack

@@ -1,18 +1,5 @@
-Arith
-Cc
-Combine
-Exception
 Explanation
-Fm
+Formula_intf
-Intervals
-Literal
-Polynome
-Smt
 Solver
 Solver_types
-Sum
+Theory_intf
-Symbols
-Term
-Ty
-Uf
-Use

msat.odocl

@@ -1,15 +1,18 @@
+sat/Formula_intf
+sat/Explanation
+sat/Solver
+sat/Solver_types
+sat/Theory_intf
+
 smt/Arith
 smt/Cc
 smt/Combine
 smt/Exception
-smt/Explanation
 smt/Fm
 smt/Intervals
 smt/Literal
 smt/Polynome
 smt/Smt
-smt/Solver
-smt/Solver_types
 smt/Sum
 smt/Symbols
 smt/Term

sat/.merlin

@@ -2,3 +2,4 @@ S ./
 S ../common/
 
 B ../_build/
+B ../_build/common/

sat/explanation.ml

@@ -14,6 +14,8 @@
 
 open Format
 
+module type S = Explanation_intf.S
+
 module Make(Stypes : Solver_types.S) = struct
 
     type atom = Stypes.atom

sat/formula_intf.ml

@@ -17,12 +17,14 @@ module type S = sig
 
   type t
 
-  val vrai : t
+  val true_ : t
-  val faux : t
+  val false_ : t
   val dummy : t
 
   val neg : t -> t
+
   val norm : t -> t * bool
+  (** Returns a 'normalized' form of the formula, possibly negated *)
 
   val hash : t -> int
   val equal : t -> t -> bool
@@ -34,7 +36,6 @@ module type S = sig
   val print : Format.formatter -> t -> unit
 
   module Map : Map.S with type key = t
-  module Set : Set.S with type elt = t
 
 end
 

sat/solver.ml

@@ -12,221 +12,144 @@
 
 open Format
 
-module Make(F : Formula_intf.S)(Th : Theory_intf.S with type formula = F.t) = struct
+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) = struct
 
-module Stypes = Solver_types.Make(F)
+    open St
-module Ex = Explanation.Make(Stypes)
-
-open Stypes
 
     exception Sat
     exception Unsat of clause list
     exception Restart
+    exception Conflict of clause
 
-type env =
+    type env = {
-    {
+        (* si true_, les contraintes sont deja fausses *)
-        (* si vrai, les contraintes sont deja fausses *)
         mutable is_unsat : bool;
-
         mutable unsat_core : clause list;
-
         (* clauses du probleme *)
         mutable clauses : clause Vec.t;
-
         (* clauses apprises *)
         mutable learnts : clause Vec.t;
-
         (* valeur de l'increment pour l'activite des clauses *)
         mutable clause_inc : float;
-
         (* valeur de l'increment pour l'activite des variables *)
         mutable var_inc : float;
-
         (* un vecteur des variables du probleme *)
         mutable vars : var Vec.t;
-
         (* la pile de decisions avec les faits impliques *)
         mutable trail : atom Vec.t;
-
         (* une pile qui pointe vers les niveaux de decision dans trail *)
         mutable trail_lim : int Vec.t;
-
         (* Tete de la File des faits unitaires a propager.
 	   C'est un index vers le trail *)
         mutable qhead : int;
-
         (* Nombre des assignements top-level depuis la derniere
            execution de 'simplify()' *)
         mutable simpDB_assigns : int;
-
         (* Nombre restant de propagations a faire avant la prochaine
            execution de 'simplify()' *)
         mutable simpDB_props : int;
-
         (* Un tas ordone en fonction de l'activite des variables *)
         mutable order : Iheap.t;
-
         (* estimation de progressions, mis a jour par 'search()' *)
         mutable progress_estimate : float;
-
         (* *)
         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 *)
         clause_decay : float;
-
         (* la limite de restart initiale, vaut 100 par defaut *)
         mutable restart_first : int;
-
         (* facteur de multiplication de restart limite, vaut 1.5 par defaut*)
         restart_inc : float;
-
         (* limite initiale du nombre de clause apprises, vaut 1/3
            des clauses originales par defaut *)
         mutable learntsize_factor : float;
-
         (* multiplier learntsize_factor par cette valeur a chaque restart,
            vaut 1.1 par defaut *)
         learntsize_inc : float;
-
         (* controler la minimisation des clauses conflit, vaut true par defaut *)
         expensive_ccmin : bool;
-
         (* controle la polarite a choisir lors de la decision *)
         polarity_mode : bool;
 
         mutable starts : int;
-
         mutable decisions : int;
-
         mutable propagations : int;
-
         mutable conflicts : int;
-
         mutable clauses_literals : int;
-
         mutable learnts_literals : int;
-
         mutable max_literals : int;
-
         mutable tot_literals : int;
-
         mutable nb_init_vars : int;
-
         mutable nb_init_clauses : int;
-
         mutable model : var Vec.t;
-
         mutable tenv : Th.t;
-
         mutable tenv_queue : Th.t Vec.t;
-
         mutable tatoms_queue : atom Queue.t;
-
     }
 
-
+    type state = {
-
-exception Conflict of clause
-
-  type state =
-      {
         env : env;
         st_cpt_mk_var: int;
-        st_ma : var F.Map.t;
+        st_ma : varmap;
     }
 
-
+    let env = {
-  let env =
-    {
         is_unsat = false;
-
         unsat_core = [] ;
-
         clauses = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*)
-
         learnts = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*)
-
         clause_inc = 1.;
-
         var_inc = 1.;
-
         vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*)
-
         trail = Vec.make 601 dummy_atom;
-
         trail_lim = Vec.make 601 (-105);
-
         qhead = 0;
-
         simpDB_assigns = -1;
-
         simpDB_props = 0;
-
         order = Iheap.init 0; (* sera mis a jour dans solve *)
-
         progress_estimate = 0.;
-
         remove_satisfied = true;
-
         var_decay = 1. /. 0.95;
-
         clause_decay = 1. /. 0.999;
-
         restart_first = 100;
-
         restart_inc = 1.5;
-
         learntsize_factor = 1. /. 3. ;
-
         learntsize_inc = 1.1;
-
         expensive_ccmin = true;
-
         polarity_mode = false;
-
         starts = 0;
-
         decisions = 0;
-
         propagations = 0;
-
         conflicts = 0;
-
         clauses_literals = 0;
-
         learnts_literals = 0;
-
         max_literals = 0;
-
         tot_literals = 0;
-
         nb_init_vars = 0;
-
         nb_init_clauses = 0;
-
         model = Vec.make 0 dummy_var;
-
         tenv = Th.empty();
-
         tenv_queue = Vec.make 100 (Th.empty());
-
         tatoms_queue = Queue.create ();
-
     }
 
 
-let f_weight i j = (Vec.get env.vars j).weight < (Vec.get env.vars i).weight
+    let f_weight i j =
+        (Vec.get env.vars j).weight < (Vec.get env.vars i).weight
 
-let f_filter i = (Vec.get env.vars i).level < 0
+    let f_filter i =
+        (Vec.get env.vars i).level < 0
 
     let insert_var_order v =
         Iheap.insert f_weight env.order v.vid
 
-let var_decay_activity () = env.var_inc <- env.var_inc *. env.var_decay
+    let var_decay_activity () =
+        env.var_inc <- env.var_inc *. env.var_decay
 
     let clause_decay_activity () =
         env.clause_inc <- env.clause_inc *. env.clause_decay
@@ -349,7 +272,7 @@ let progress_estimate () =
     let propagate_in_clause a c i watched new_sz =
       let atoms = c.atoms in
       let first = Vec.get atoms 0 in
-  if first == a.neg then begin (* le litiral faux doit etre dans .(1) *)
+      if first == a.neg then begin (* le litiral false_ doit etre dans .(1) *)
         Vec.set atoms 0 (Vec.get atoms 1);
         Vec.set atoms 1 first
       end;
@@ -574,7 +497,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
         eprintf "@.>>UNSAT Deduction made from:@.";
         List.iter
           (fun hc ->
-        eprintf "    %a@." Debug.clause hc
+            eprintf "    %a@." pp_clause hc
           )!l;
       end;
       let uc = HUC.create 17 in
@@ -599,7 +522,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
         eprintf "@.>>UNSAT_CORE:@.";
         List.iter
           (fun hc ->
-        eprintf "    %a@." Debug.clause hc
+            eprintf "    %a@." pp_clause hc
           )unsat_core;
       end;
       env.is_unsat <- true;
@@ -619,7 +542,7 @@ let report_t_unsat dep =
         eprintf "@.>>T-UNSAT Deduction made from:@.";
         List.iter
           (fun hc ->
-        eprintf "    %a@." Debug.clause hc
+            eprintf "    %a@." pp_clause hc
           )l;
       end;
       let uc = HUC.create 17 in
@@ -644,7 +567,7 @@ let report_t_unsat dep =
         eprintf "@.>>T-UNSAT_CORE:@.";
         List.iter
           (fun hc ->
-        eprintf "    %a@." Debug.clause hc
+            eprintf "    %a@." pp_clause hc
           ) unsat_core;
       end;
       env.is_unsat <- true;
@@ -941,7 +864,7 @@ let init_solver cnf ~cnumber =
 
 
     let assume cnf ~cnumber =
-  let cnf = List.map (List.map Solver_types.add_atom) cnf in
+      let cnf = List.map (List.map St.add_atom) cnf in
       init_solver cnf ~cnumber
 
     let clear () =
@@ -975,7 +898,7 @@ let clear () =
       env.trail_lim <- Vec.make 601 (-105);
       env.tenv_queue <- Vec.make 100 (empty_theory);
       env.tatoms_queue <- Queue.create ();
-  Solver_types.clear ()
+      St.clear ()
 
 
     let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0
@@ -983,8 +906,8 @@ let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0
     let save () =
       let sv =
         { env = env;
-      st_cpt_mk_var = !Solver_types.cpt_mk_var;
+          st_cpt_mk_var = !St.cpt_mk_var;
-      st_ma = !Solver_types.ma }
+          st_ma = !St.ma }
       in
       copy sv
 
@@ -1019,8 +942,8 @@ let restore { env = s_env; st_cpt_mk_var = st_cpt_mk_var; st_ma = st_ma } =
       env.tenv_queue <- s_env.tenv_queue;
       env.tatoms_queue <- s_env.tatoms_queue;
       env.learntsize_factor <- s_env.learntsize_factor;
-  Solver_types.cpt_mk_var := st_cpt_mk_var;
+      St.cpt_mk_var := st_cpt_mk_var;
-  Solver_types.ma := st_ma
+      St.ma := st_ma
 
       let eval lit =
         let var, negated = make_var lit in

sat/solver.mli

@@ -11,9 +11,10 @@
 (*                                                                        *)
 (**************************************************************************)
 
-module Make (F : Formula_intf.S)(Th : Theory_intf.S with type formula = F.t) : sig
+module Make (F : Formula_intf.S)
-
+            (St : Solver_types.S with type formula = F.t)
-    module 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
 
     exception Sat
     exception Unsat of St.clause list
@@ -29,3 +30,4 @@ module Make (F : Formula_intf.S)(Th : Theory_intf.S with type formula = F.t) : s
     val restore : state -> unit
 
 end
+

sat/solver_types.ml

@@ -21,8 +21,12 @@ let is_le n = Hstring.compare n ale = 0
 let is_lt n = Hstring.compare n alt = 0
 let is_gt n = Hstring.compare n agt = 0
 
+module type S = Solver_types_intf.S
+
 module Make (F : Formula_intf.S) = struct
 
+type formula = F.t
+
 type var =
     {  vid : int;
        pa : atom;
@@ -35,7 +39,7 @@ type var =
 
 and atom =
     { var : var;
-      lit : F.t;
+      lit : formula;
       neg : atom;
       mutable watched : clause Vec.t;
       mutable is_true : bool;
@@ -80,6 +84,7 @@ and dummy_clause =
     cpremise = [] }
 
 module MA = F.Map
+type varmap = var MA.t
 
 let ale = Hstring.make "<="
 let alt = Hstring.make "<"
@@ -174,8 +179,6 @@ let clear () =
   cpt_mk_var := 0;
   ma := MA.empty
 
-module Debug = struct
-
   let sign a = if a==a.var.pa then "" else "-"
 
   let level a =
@@ -196,25 +199,23 @@ module Debug = struct
     else if a.neg.is_true then sprintf ":0%s" (level a)
     else ":X"
 
-  let premise fmt v =
+  let pp_premise fmt v =
     List.iter (fun {name=name} -> fprintf fmt "%s," name) v
 
-  let atom fmt a =
+  let pp_atom fmt a =
     fprintf fmt "%s%d%s [lit:%a] vpremise={{%a}}"
       (sign a) (a.var.vid+1) (value a) F.print a.lit
-      premise a.var.vpremise
+      pp_premise a.var.vpremise
 
-  let atoms_list fmt l = List.iter (fprintf fmt "%a ; " atom) l
+  let pp_atoms_list fmt l = List.iter (fprintf fmt "%a ; " pp_atom) l
-  let atoms_array fmt arr = Array.iter (fprintf fmt "%a ; " atom) arr
+  let pp_atoms_array fmt arr = Array.iter (fprintf fmt "%a ; " pp_atom) arr
 
-  let atoms_vec fmt vec =
+  let pp_atoms_vec fmt vec =
     for i = 0 to Vec.size vec - 1 do
-      fprintf fmt "%a ; " atom (Vec.get vec i)
+      fprintf fmt "%a ; " pp_atom (Vec.get vec i)
     done
 
-  let clause fmt {name=name; atoms=arr; cpremise=cp} =
+  let pp_clause fmt {name=name; atoms=arr; cpremise=cp} =
-    fprintf fmt "%s:{ %a} cpremise={{%a}}" name atoms_vec arr premise cp
+    fprintf fmt "%s:{ %a} cpremise={{%a}}" name pp_atoms_vec arr pp_premise cp
-
-end
 
 end

sat/solver_types_intf.ml

@@ -48,8 +48,8 @@ module type S = sig
     and premise = clause list
 
     val cpt_mk_var : int ref
-    module Map : Map.S with type key = formula
+    type varmap
-    val ma : var Map.t ref
+    val ma : varmap ref
 
     val dummy_var : var
     val dummy_atom : atom

sat/theory_intf.ml

@@ -15,13 +15,11 @@
 module type S = sig
     type t
     type formula
+    type explanation
 
-    module St : Solver_types.S with type formula = formula
+    exception Inconsistent of explanation
-    module Ex : Explanation.S with type atom = St.atom
-
-    exception Inconsistent of Ex.t
 
     val empty : unit -> t
-    val assume : cs:bool -> formula -> Ex.t -> t -> t
+    val assume : cs:bool -> formula -> explanation -> t -> t
 end
 

smt/cc.ml

@@ -189,13 +189,13 @@ module Make (X : Sig.X) = struct
 	    | _ -> []
 
   let contra_congruence  =
-    let vrai,_ = X.make T.vrai in
+    let true_,_ = X.make T.true_ in
-    let faux, _ = X.make T.faux in
+    let false_, _ = X.make T.false_ in
     fun env r ex ->
-      if X.equal (fst (Uf.find_r env.uf r)) vrai then
+      if X.equal (fst (Uf.find_r env.uf r)) true_ then
-	  new_facts_by_contra_congruence env r T.faux ex
+	  new_facts_by_contra_congruence env r T.false_ ex
-      else if X.equal (fst (Uf.find_r env.uf r)) faux then
+      else if X.equal (fst (Uf.find_r env.uf r)) false_ then
-	  new_facts_by_contra_congruence env r T.vrai ex
+	  new_facts_by_contra_congruence env r T.true_ ex
       else []
 
   let clean_use =
@@ -518,7 +518,7 @@ module Make (X : Sig.X) = struct
     let t = { gamma = env; gamma_finite = env; choices = [] } in
     let t, _, _ =
       assume ~cs:false
-        (A.LT.make (A.Distinct (false, [T.vrai; T.faux]))) Ex.empty t
+        (A.LT.make (A.Distinct (false, [T.true_; T.false_]))) Ex.empty t
     in t
 
 end

smt/literal.ml

@@ -168,8 +168,8 @@ module type S_Term = sig
 
   val mk_pred : Term.t -> t
 
-  val vrai : t
+  val true_ : t
-  val faux : t
+  val false_ : t
 
 (*  val terms_of : t -> Term.Set.t
   val vars_of : t -> Symbols.Set.t
@@ -182,16 +182,16 @@ module LT : S_Term = struct
   module L = Make(Term)
   include L
 
-  let mk_pred t = make (Eq (t, Term.vrai) )
+  let mk_pred t = make (Eq (t, Term.true_) )
 
-  let vrai = mk_pred Term.vrai
+  let true_ = mk_pred Term.true_
-  let faux = mk_pred Term.faux
+  let false_ = mk_pred Term.false_
 
   let neg a = match view a with
-    | Eq(t1, t2) when Term.equal t2 Term.faux ->
+    | Eq(t1, t2) when Term.equal t2 Term.false_ ->
-      make (Eq (t1, Term.vrai))
+      make (Eq (t1, Term.true_))
-    | Eq(t1, t2) when Term.equal t2 Term.vrai ->
+    | Eq(t1, t2) when Term.equal t2 Term.true_ ->
-      make (Eq (t1, Term.faux))
+      make (Eq (t1, Term.false_))
     | _ -> L.neg a
 
 (* let terms_of a =

smt/literal.mli

@@ -53,8 +53,8 @@ module type S_Term = sig
   include S with type elt = Term.t
 
   val mk_pred : Term.t -> t
-  val vrai : t
+  val true_ : t
-  val faux : t
+  val false_ : t
 
 end
 

smt/smt.ml

@@ -274,8 +274,8 @@ end
       lift_ite sb l ty
     with Not_found -> raise (Error (UnknownSymb s))
 
-  let t_true = T AETerm.vrai
+  let t_true = T AETerm.true_
-  let t_false = T AETerm.faux
+  let t_false = T AETerm.false_
 
   let rec is_int = function
     | T t -> AETerm.is_int t
@@ -365,8 +365,8 @@ end
     | [f] -> print fmt f
     | f::l -> fprintf fmt "%a %s %a" print f sep (print_list sep) l
 
-  let f_true = Lit Literal.LT.vrai
+  let f_true = Lit Literal.LT.true_
-  let f_false = Lit Literal.LT.faux
+  let f_false = Lit Literal.LT.false_
 
   let make comb l = Comb (comb, l)
 
@@ -565,7 +565,7 @@ end
         [] Ty.Tbool
       in
       incr cpt;
-      Literal.LT.make (Literal.Eq (t, AETerm.vrai))
+      Literal.LT.make (Literal.Eq (t, AETerm.true_))
 
   module Tseitin (Dummy : sig end)= struct
     let acc_or = ref []

smt/term.ml

@@ -62,8 +62,8 @@ let compare t1 t2 =
 
 let make s l ty = T.hashcons {f=s;xs=l;ty=ty;tag=0 (* dumb_value *) }
 
-let vrai = make (Sy.True) [] Ty.Tbool
+let true_ = make (Sy.True) [] Ty.Tbool
-let faux = make (Sy.False) [] Ty.Tbool
+let false_ = make (Sy.False) [] Ty.Tbool
 
 let int i = make (Sy.int i) [] Ty.Tint
 let real r = make (Sy.real r) [] Ty.Treal

smt/term.mli

@@ -17,8 +17,8 @@ type view = private {f: Symbols.t ; xs: t list; ty: Ty.t; tag : int}
 val view : t -> view
 val make : Symbols.t -> t list -> Ty.t -> t
 
-val vrai : t
+val true_ : t
-val faux : t
+val false_ : t
 val int : string -> t
 val real : string -> t