Moved some type def outside Plugins/Theories

src/core/internal.ml

@@ -6,7 +6,9 @@ Copyright 2014 Simon Cruanes
 
 module Make
     (St : Solver_types.S)
-    (Th : Plugin_intf.S with type term = St.term and type formula = St.formula and type proof = St.proof)
+    (Plugin : Plugin_intf.S with type term = St.term
+                             and type formula = St.formula
+                             and type proof = St.proof)
     (Dummy: sig end)
 = struct
 
@@ -25,7 +27,7 @@ module Make
     (* User levels always refer to decision_level 0 *)
     ul_elt_lvl : int;     (* Number of atoms in trail at decision level 0 *)
     ul_th_lvl : int;      (* Number of atoms known by the theory at decicion level 0 *)
-    ul_th_env : Th.level; (* Theory state at level 0 *)
+    ul_th_env : Plugin.level; (* Theory state at level 0 *)
     ul_clauses : int;     (* number of clauses *)
     ul_learnt : int;      (* number of learnt clauses *)
   }
@@ -48,7 +50,7 @@ module Make
 
     elt_levels : int Vec.t;
     (* decision levels in [trail]  *)
-    th_levels : Th.level Vec.t;
+    th_levels : Plugin.level Vec.t;
     (* theory states corresponding to elt_levels *)
     user_levels : user_level Vec.t;
     (* user-defined levels, for {!push} and {!pop} *)
@@ -120,14 +122,14 @@ module Make
 
     elt_queue = Vec.make 601 (of_atom dummy_atom);
     elt_levels = Vec.make 601 (-1);
-    th_levels = Vec.make 100 Th.dummy;
+    th_levels = Vec.make 100 Plugin.dummy;
 
     user_levels = Vec.make 20 {
         ul_elt_lvl = 0;
         ul_th_lvl = 0;
         ul_learnt = 0;
         ul_clauses = 0;
-        ul_th_env = Th.dummy;
+        ul_th_env = Plugin.dummy;
       };
 
     order = Iheap.init 0;
@@ -199,7 +201,7 @@ module Make
           let l = Vec.get env.elt_levels 0 in
           l, l
       and ul_th_env =
-        if Vec.is_empty env.th_levels then Th.current_level ()
+        if Vec.is_empty env.th_levels then Plugin.current_level ()
         else Vec.get env.th_levels 0
       in
       (* Keep in mind what are the current assumptions. *)
@@ -230,7 +232,7 @@ module Make
       List.iter f (Hashtbl.find iter_map v.vid)
     with Not_found ->
       let l = ref [] in
-      Th.iter_assignable (fun t -> l := add_term t :: !l) v.pa.lit;
+      Plugin.iter_assignable (fun t -> l := add_term t :: !l) v.pa.lit;
       Hashtbl.add iter_map v.vid !l;
       List.iter f !l
 
@@ -397,7 +399,7 @@ module Make
     assert (env.th_head = Vec.size env.elt_queue);
     assert (env.elt_head = Vec.size env.elt_queue);
     Vec.push env.elt_levels (Vec.size env.elt_queue);
-    Vec.push env.th_levels (Th.current_level ()); (* save the current tenv *)
+    Vec.push env.th_levels (Plugin.current_level ()); (* save the current tenv *)
     ()
 
   (* Attach/Detach a clause.
@@ -464,7 +466,7 @@ module Make
           end
       done;
       (* Recover the right theory state. *)
-      Th.backtrack (Vec.get env.th_levels lvl);
+      Plugin.backtrack (Vec.get env.th_levels lvl);
       (* Resize the vectors according to their new size. *)
       Vec.shrink env.elt_queue ((Vec.size env.elt_queue) - env.elt_head);
       Vec.shrink env.elt_levels ((Vec.size env.elt_levels) - lvl);
@@ -534,9 +536,9 @@ module Make
 
   let th_eval a =
     if a.is_true || a.neg.is_true then None
-    else match Th.eval a.lit with
+    else match Plugin.eval a.lit with
-      | Th.Unknown -> None
+      | Plugin_intf.Unknown -> None
-      | Th.Valued (b, lvl) ->
+      | Plugin_intf.Valued (b, lvl) ->
         let atom = if b then a else a.neg in
         enqueue_bool atom lvl (Semantic lvl);
         Some b
@@ -812,8 +814,10 @@ module Make
 
   let slice_get i =
     match Vec.get env.elt_queue i with
-    | Either.Right a -> Th.Lit a.lit, a.var.v_level
+    | Either.Right a ->
-    | Either.Left {l_level; term; assigned = Some v} -> Th.Assign (term, v), l_level
+      Plugin_intf.Lit a.lit
+    | Either.Left {l_level; term; assigned = Some v} ->
+      Plugin_intf.Assign (term, v, l_level)
     | Either.Left _ -> assert false
 
   let slice_push l lemma =
@@ -828,21 +832,21 @@ module Make
     Iheap.grow_to_by_double env.order (St.nb_elt ());
     enqueue_bool a lvl (Semantic lvl)
 
-  let current_slice () = Th.({
+  let current_slice () = {
-      start = env.th_head;
+      Plugin_intf.start = env.th_head;
       length = (Vec.size env.elt_queue) - env.th_head;
       get = slice_get;
       push = slice_push;
       propagate = slice_propagate;
-    })
+    }
 
-  let full_slice () = Th.({
+  let full_slice () = {
-      start = 0;
+      Plugin_intf.start = 0;
       length = Vec.size env.elt_queue;
       get = slice_get;
       push = slice_push;
       propagate = (fun _ -> assert false);
-    })
+    }
 
   let rec theory_propagate () =
     assert (env.elt_head = Vec.size env.elt_queue);
@@ -851,10 +855,10 @@ module Make
     else begin
       let slice = current_slice () in
       env.th_head <- env.elt_head;
-      match Th.assume slice with
+      match Plugin.assume slice with
-      | Th.Sat ->
+      | Plugin_intf.Sat ->
         propagate ()
-      | Th.Unsat (l, p) ->
+      | Plugin_intf.Unsat (l, p) ->
         let l = List.rev_map new_atom l in
         Iheap.grow_to_by_double env.order (St.nb_elt ());
         List.iter (fun a -> insert_var_order (elt_of_var a.var)) l;
@@ -965,13 +969,13 @@ module Make
     if v.v_level >= 0 then begin
       assert (v.pa.is_true || v.na.is_true);
       pick_branch_lit ()
-    end else match Th.eval atom.lit with
+    end else match Plugin.eval atom.lit with
-      | Th.Unknown ->
+      | Plugin_intf.Unknown ->
         env.decisions <- env.decisions + 1;
         new_decision_level();
         let current_level = decision_level () in
         enqueue_bool atom current_level Decision
-      | Th.Valued (b, lvl) ->
+      | Plugin_intf.Valued (b, lvl) ->
         let a = if b then atom else atom.neg in
         enqueue_bool a lvl (Semantic lvl)
 
@@ -987,7 +991,7 @@ module Make
               if l.l_level >= 0 then
                 pick_branch_lit ()
               else begin
-                let value = Th.assign l.term in
+                let value = Plugin.assign l.term in
                 env.decisions <- env.decisions + 1;
                 new_decision_level();
                 let current_level = decision_level () in
@@ -1064,7 +1068,7 @@ module Make
             n_of_conflicts := !n_of_conflicts *. env.restart_inc;
             n_of_learnts   := !n_of_learnts *. env.learntsize_inc
           | Sat ->
-            Th.if_sat (full_slice ());
+            Plugin.if_sat (full_slice ());
             if is_unsat () then raise Unsat
             else if env.elt_head = Vec.size env.elt_queue (* sanity check *)
                  && env.elt_head = St.nb_elt () (* this is the important test to know if the search is finished *)  then
@@ -1148,7 +1152,7 @@ module Make
             end
         end
     done;
-    Th.backtrack th_env; (* recover the right theory env *)
+    Plugin.backtrack th_env; (* recover the right theory env *)
     Vec.shrink env.elt_queue ((Vec.size env.elt_queue) - env.elt_head);
     Vec.clear env.elt_levels;
     Vec.clear env.th_levels;

src/core/plugin_intf.ml

@@ -12,6 +12,39 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type eval_res =
+  | Valued of bool * int
+  | Unknown
+(** The type of evaluation results, either the given formula cannot be
+    evaluated, or it can thanks to assignment. In that case, the level
+    of the evaluation is the maximum of levels of assignemnts needed
+    to evaluate the given formula. *)
+
+type ('formula, 'proof) res =
+  | Sat
+  | Unsat of 'formula list * 'proof
+(** Type returned by the theory, either the current set of assumptions is satisfiable,
+    or it is not, in which case a tautological clause (hopefully minimal) is returned.
+    Formulas in the unsat clause must come from the current set of assumptions, i.e
+    must have been encountered in a slice. *)
+
+type ('term, 'formula) assumption =
+  | Lit of 'formula
+  | Assign of 'term * 'term * int (* Assign(x, alpha) *)
+(** Asusmptions made by the core SAT solver. Can be either a formula, or an assignment.
+    Assignemnt are given a level. *)
+
+type ('term, 'formula, 'proof) slice = {
+  start : int;
+  length : int;
+  get : int -> ('term, 'formula) assumption;
+  push : 'formula list -> 'proof -> unit;
+  propagate : 'formula -> int -> unit;
+}
+(** The type for a slice of litterals to assume/propagate in the theory.
+    [get] operations should only be used for integers [ start <= i < start + length].
+    [push clause proof] allows to add a tautological clause to the sat solver. *)
+
 module type S = sig
   (** Signature for theories to be given to the Model Constructing Solver. *)
 
@@ -24,36 +57,9 @@ module type S = sig
   type proof
   (** A custom type for the proofs of lemmas produced by the theory. *)
 
-  type assumption =
-    | Lit of formula
-    | Assign of term * term (* Assign(x, alpha) *)
-
-  type slice = {
-    start : int;
-    length : int;
-    get : int -> assumption * int;
-    push : formula list -> proof -> unit;
-    propagate : formula -> int -> unit;
-  }
-  (** The type for a slice of litterals to assume/propagate in the theory.
-      [get] operations should only be used for integers [ start <= i < start + length].
-      [push clause proof] allows to add a tautological clause to the sat solver. *)
-
   type level
   (** The type for levels to allow backtracking. *)
 
-  (** Type returned by the theory, either the current set of assumptions is satisfiable,
-      or it is not, in which case a tautological clause (hopefully minimal) is returned.
-      Formulas in the unsat clause must come from the current set of assumptions, i.e
-      must have been encountered in a slice. *)
-  type res =
-    | Sat
-    | Unsat of formula list * proof
-
-  type eval_res =
-    | Valued of bool * int
-    | Unknown
-
   val dummy : level
   (** A dummy level. *)
 
@@ -61,7 +67,7 @@ module type S = sig
   (** Return the current level of the theory (either the empty/beginning state, or the
       last level returned by the [assume] function). *)
 
-  val assume : slice -> res
+  val assume : (term, formula, proof) slice -> (formula, proof) res
   (** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
       and returns the result of the new assumptions. *)
 
@@ -78,7 +84,7 @@ module type S = sig
   val eval : formula -> eval_res
   (** Returns the evaluation of the formula in the current assignment *)
 
-  val if_sat : slice -> unit
+  val if_sat : (term, formula, proof) slice -> unit
   (** Called at the end of the search in case a model has been found. If no new clause is
       pushed, then 'sat' is returned, else search is resumed. *)
 

src/core/theory_intf.ml

@@ -12,6 +12,14 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type ('formula, 'proof) res = ('formula, 'proof) Plugin_intf.res =
+  | Sat
+  | Unsat of 'formula list * 'proof
+(** Type returned by the theory, either the current set of assumptions is satisfiable,
+    or it is not, in which case a tautological clause (hopefully minimal) is returned.
+    Formulas in the unsat clause must come from the current set of assumptions, i.e
+    must have been encountered in a slice. *)
+
 type ('form, 'proof) slice = {
   start : int;
   length : int;
@@ -34,14 +42,6 @@ module type S = sig
   type level
   (** The type for levels to allow backtracking. *)
 
-  (** Type returned by the theory, either the current set of assumptions is satisfiable,
-      or it is not, in which case a tautological clause (hopefully minimal) is returned.
-      Formulas in the unsat clause must come from the current set of assumptions, i.e
-      must have been encountered in a slice. *)
-  type res =
-    | Sat of level
-    | Unsat of formula list * proof
-
   val dummy : level
   (** A dummy level. *)
 
@@ -49,7 +49,7 @@ module type S = sig
   (** Return the current level of the theory (either the empty/beginning state, or the
       last level returned by the [assume] function). *)
 
-  val assume : (formula, proof) slice -> res
+  val assume : (formula, proof) slice -> (formula, proof) res
   (** Assume the formulas in the slice, possibly pushing new formulas to be propagated,
       and returns the result of the new assumptions. *)
 

src/example/mcsat.ml

@@ -16,31 +16,11 @@ module Tsmt = struct
   type formula = Fsmt.t
   type proof = unit
 
-  type assumption =
-    | Lit of formula
-    | Assign of term * term
-
-  type slice = {
-    start : int;
-    length : int;
-    get : int -> assumption * int;
-    push : formula list -> proof -> unit;
-    propagate : formula -> int -> unit;
-  }
-
   type level = {
     cc : CC.t;
     assign : (term * int) M.t;
   }
 
-  type res =
-    | Sat
-    | Unsat of formula list * proof
-
-  type eval_res =
-    | Valued of bool * int
-    | Unknown
-
   (* Functions *)
   let dummy = { cc = CC.empty; assign = M.empty; }
 
@@ -60,12 +40,13 @@ module Tsmt = struct
     (Fsmt.mk_eq a b) :: (List.rev_map Fsmt.neg (aux [] l))
 
   let assume s =
+    let open Plugin_intf in
     try
       for i = s.start to s.start + s.length - 1 do
         match s.get i with
-        | (Assign (x, v)), lvl ->
+        | Assign (x, v, lvl) ->
           env := { !env with assign = M.add x (v, lvl) !env.assign }
-        | Lit f, _ ->
+        | Lit f ->
           Log.debugf 10 "Propagating in th :@ @[%a@]" (fun k->k Fsmt.print f);
           match f with
           | Fsmt.Prop _ -> ()
@@ -91,19 +72,23 @@ module Tsmt = struct
   let max (a: int) (b: int) = if a < b then b else a
 
   let eval = function
-    | Fsmt.Prop _ -> Unknown
+    | Fsmt.Prop _ -> Plugin_intf.Unknown
     | Fsmt.Equal (a, b) ->
       begin try
           let a', lvl_a = M.find a !env.assign in
           let b', lvl_b = M.find b !env.assign in
-          Valued (Fsmt.Term.equal a' b', max lvl_a lvl_b)
+          Plugin_intf.Valued (Fsmt.Term.equal a' b', max lvl_a lvl_b)
-        with Not_found -> Unknown end
+        with Not_found ->
+          Plugin_intf.Unknown
+      end
     | Fsmt.Distinct (a, b) ->
       begin try
           let a', lvl_a = M.find a !env.assign in
           let b', lvl_b = M.find b !env.assign in
-          Valued (not (Fsmt.Term.equal a' b'), max lvl_a lvl_b)
+          Plugin_intf.Valued (not (Fsmt.Term.equal a' b'), max lvl_a lvl_b)
-        with Not_found -> Unknown end
+        with Not_found ->
+          Plugin_intf.Unknown
+      end
 
   let if_sat _ = ()
 

src/example/smt.ml

@@ -5,7 +5,6 @@ Copyright 2014 Simon Cruanes
 *)
 
 module Fsmt = Expr
-module ThI = Theory_intf
 
 module Tsmt = struct
 
@@ -15,10 +14,6 @@ module Tsmt = struct
   type proof = unit
   type level = CC.t
 
-  type res =
-    | Sat of level
-    | Unsat of formula list * proof
-
   let dummy = CC.empty
 
   let env = ref dummy
@@ -37,15 +32,16 @@ module Tsmt = struct
     (Fsmt.mk_eq a b) :: (List.rev_map Fsmt.neg (aux [] l))
 
   let assume s =
+    let open Theory_intf in
     try
-      for i = s.ThI.start to s.ThI.start + s.ThI.length - 1 do
+      for i = s.start to s.start + s.length - 1 do
-        Log.debugf 10 "Propagating in th :@ @[%a@]" (fun k->k Fsmt.print (s.ThI.get i));
+        Log.debugf 10 "Propagating in th :@ @[%a@]" (fun k->k Fsmt.print (s.get i));
-        match s.ThI.get i with
+        match s.get i with
         | Fsmt.Prop _ -> ()
         | Fsmt.Equal (i, j) -> env := CC.add_eq !env i j
         | Fsmt.Distinct (i, j) -> env := CC.add_neq !env i j
       done;
-      Sat (current_level ())
+      Sat
     with CC.Unsat x ->
       Log.debug 8 "Making explanation clause...";
       Unsat (to_clause x, ())

src/solver/solver.ml

@@ -11,7 +11,6 @@
 (**************************************************************************)
 
 module type S = Solver_intf.S
-module ThI = Theory_intf
 
 module DummyTheory(F : Formula_intf.S) = struct
   (* We don't have anything to do since the SAT Solver already
@@ -21,20 +20,9 @@ module DummyTheory(F : Formula_intf.S) = struct
   type proof = F.proof
   type level = unit
 
-  type slice = {
-    start : int;
-    length : int;
-    get : int -> formula;
-    push : formula list -> proof -> unit;
-  }
-
-  type res =
-    | Sat of level
-    | Unsat of formula list * proof
-
   let dummy = ()
   let current_level () = ()
-  let assume _ = Sat ()
+  let assume _ = Theory_intf.Sat
   let backtrack _ = ()
 end
 
@@ -44,46 +32,25 @@ module Plugin(E : Formula_intf.S)
   type term = E.t
   type formula = E.t
   type proof = Th.proof
-
-  type assumption =
-    | Lit of formula
-    | Assign of term * term
-
-  type slice = {
-    start : int;
-    length : int;
-    get : int -> assumption * int;
-    push : formula list -> proof -> unit;
-    propagate : formula -> int -> unit;
-  }
-
   type level = Th.level
 
-  type res =
-    | Sat
-    | Unsat of formula list * proof
-
-  type eval_res =
-    | Valued of bool * int
-    | Unknown
-
   let dummy = Th.dummy
 
   let current_level = Th.current_level
 
-  let assume_get s i = match s.get i with
+  let assume_get s i =
-    | Lit f, _ -> f | _ -> assert false
+    match s.Plugin_intf.get i with
+    | Plugin_intf.Lit f -> f
+    | _ -> assert false
 
   let assume s =
-    match Th.assume {
+    let slice = {
-        ThI.
+      Theory_intf.start = s.Plugin_intf.start;
-        start = s.start;
+      length = s.Plugin_intf.length;
-        length = s.length;
       get = assume_get s;
-        push = s.push;
+      push = s.Plugin_intf.push;
-      } with
+    } in
-    | Th.Sat _ -> Sat
+    Th.assume slice
-    | Th.Unsat (l, p) -> Unsat (l, p)
 
   let backtrack = Th.backtrack
 
@@ -91,7 +58,7 @@ module Plugin(E : Formula_intf.S)
 
   let iter_assignable _ _ = ()
 
-  let eval _ = Unknown
+  let eval _ = Plugin_intf.Unknown
 
   let if_sat _ = ()