refactor(api): make theory state also explicit

src/core/Heap.ml

@@ -136,4 +136,4 @@ module Make(Elt : RANKED) = struct
     );
     x
 
-end
+end [@@inline]

src/core/Internal.ml

@@ -4,6 +4,8 @@ Copyright 2014 Guillaume Bury
 Copyright 2014 Simon Cruanes
 *)
 
+(* TODO: move solver types here *)
+
 module Make
     (St : Solver_types.S)
     (Plugin : Plugin_intf.S with type term = St.term
@@ -13,8 +15,9 @@ module Make
   module Proof = Res.Make(St)
 
   open St
+  type theory = Plugin.t
 
-  module H = Heap.Make(struct
+  module H = (Heap.Make [@specialise]) (struct
     type t = St.Elt.t
     let[@inline] cmp i j = Elt.weight j < Elt.weight i (* comparison by weight *)
     let idx = Elt.idx
@@ -49,6 +52,8 @@ module Make
   type t = {
     st : St.t;
 
+    th: Plugin.t;
+
     (* Clauses are simplified for eficiency purposes. In the following
        vectors, the comments actually refer to the original non-simplified
        clause. *)
@@ -121,8 +126,8 @@ module Make
   }
 
   (* Starting environment. *)
-  let create_ ~st () : t = {
-    st;
+  let create_ ~st (th:theory) : t = {
+    st; th;
     unsat_conflict = None;
     next_decision = None;
 
@@ -152,9 +157,9 @@ module Make
     dirty=false;
   }
 
-  let create ?(size=`Big) () : t =
+  let create ?(size=`Big) (th:theory) : t =
     let st = St.create ~size () in
-    create_ ~st ()
+    create_ ~st th
 
   (* Misc functions *)
   let to_float = float_of_int
@@ -195,7 +200,7 @@ module Make
         | Some _ -> ()
         | None ->
           let l = ref [] in
-          Plugin.iter_assignable
+          Plugin.iter_assignable st.th
             (fun t -> l := Lit.make st.st t :: !l)
             res.var.pa.lit;
           res.var.v_assignable <- Some !l;
@@ -386,7 +391,7 @@ module Make
     assert (st.th_head = Vec.size st.trail);
     assert (st.elt_head = Vec.size st.trail);
     Vec.push st.elt_levels (Vec.size st.trail);
-    Vec.push st.th_levels (Plugin.current_level ()); (* save the current theory state *)
+    Vec.push st.th_levels (Plugin.current_level st.th); (* save the current theory state *)
     ()
 
   (* Attach/Detach a clause.
@@ -454,7 +459,7 @@ module Make
           )
       done;
       (* Recover the right theory state. *)
-      Plugin.backtrack (Vec.get st.th_levels lvl);
+      Plugin.backtrack st.th (Vec.get st.th_levels lvl);
       (* Resize the vectors according to their new size. *)
       Vec.shrink st.trail !head;
       Vec.shrink st.elt_levels lvl;
@@ -582,7 +587,7 @@ module Make
      by boolean propagation/decision *)
   let th_eval st a : bool option =
     if a.is_true || a.neg.is_true then None
-    else match Plugin.eval a.lit with
+    else match Plugin.eval st.th a.lit with
       | Plugin_intf.Unknown -> None
       | Plugin_intf.Valued (b, l) ->
         if l = [] then
@@ -1014,7 +1019,7 @@ module Make
     ) else (
       let slice = current_slice st in
       st.th_head <- st.elt_head; (* catch up *)
-      match Plugin.assume slice with
+      match Plugin.assume st.th slice with
       | Plugin_intf.Sat ->
         propagate st
       | Plugin_intf.Unsat (l, p) ->
@@ -1067,7 +1072,7 @@ module Make
     if v.v_level >= 0 then (
       assert (v.pa.is_true || v.na.is_true);
       pick_branch_lit st
-    ) else match Plugin.eval atom.lit with
+    ) else match Plugin.eval st.th atom.lit with
       | Plugin_intf.Unknown ->
         new_decision_level st;
         let current_level = decision_level st in
@@ -1087,7 +1092,7 @@ module Make
           if Lit.level l >= 0 then
             pick_branch_lit st
           else (
-            let value = Plugin.assign l.term in
+            let value = Plugin.assign st.th l.term in
             new_decision_level st;
             let current_level = decision_level st in
             enqueue_assign st l value current_level
@@ -1174,7 +1179,7 @@ module Make
             n_of_learnts   := !n_of_learnts *. learntsize_inc
           | Sat ->
             assert (st.elt_head = Vec.size st.trail);
-            begin match Plugin.if_sat (full_slice st) with
+            begin match Plugin.if_sat st.th (full_slice st) with
               | Plugin_intf.Sat -> ()
               | Plugin_intf.Unsat (l, p) ->
                 let atoms = List.rev_map (create_atom st) l in

src/core/Plugin_intf.ml

@@ -60,8 +60,11 @@ type ('term, 'formula, 'proof) slice = {
 }
 (** The type for a slice of assertions to assume/propagate in the theory. *)
 
+(** Signature for theories to be given to the Model Constructing Solver. *)
 module type S = sig
-  (** Signature for theories to be given to the Model Constructing Solver. *)
+
+  type t
+  (** The plugin state itself *)
 
   type term
   (** The type of terms. Should be compatible with Expr_intf.Term.t*)
@@ -75,33 +78,30 @@ module type S = sig
   type level
   (** The type for levels to allow backtracking. *)
 
-  val dummy : level
-  (** A dummy level. *)
-
-  val current_level : unit -> level
+  val current_level : t -> level
   (** Return the current level of the theory (either the empty/beginning state, or the
       last level returned by the [assume] function). *)
 
-  val assume : (term, formula, proof) slice -> (formula, proof) res
+  val assume : t -> (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. *)
 
-  val if_sat : (term, formula, proof) slice -> (formula, proof) res
+  val if_sat : t -> (term, formula, proof) slice -> (formula, proof) res
   (** Called at the end of the search in case a model has been found. If no new clause is
       pushed and the function returns [Sat], then proof search ends and 'sat' is returned,
       else search is resumed. *)
 
-  val backtrack : level -> unit
+  val backtrack : t -> level -> unit
   (** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
       same state as when it returned the value [l], *)
 
-  val assign : term -> term
+  val assign : t -> term -> term
   (** Returns an assignment value for the given term. *)
 
-  val iter_assignable : (term -> unit) -> formula -> unit
+  val iter_assignable : t -> (term -> unit) -> formula -> unit
   (** An iterator over the subterms of a formula that should be assigned a value (usually the poure subterms) *)
 
-  val eval : formula -> term eval_res
+  val eval : t -> formula -> term eval_res
   (** Returns the evaluation of the formula in the current assignment *)
 
 end
@@ -110,18 +110,19 @@ module Dummy(F: Solver_types.S)
   : S with type formula = F.formula
        and type term = F.term
        and type proof = F.proof
+       and type t = unit
 = struct
+  type t = unit
   type formula = F.formula
   type term = F.term
   type proof = F.proof
   type level = unit
-  let dummy = ()
   let current_level () = ()
-  let assume _ = Sat
-  let if_sat _ = Sat
-  let backtrack _ = ()
-  let eval _ = Unknown
-  let assign t = t
+  let assume () _ = Sat
+  let if_sat () _ = Sat
+  let backtrack () _ = ()
+  let eval () _ = Unknown
+  let assign () t = t
   let mcsat = false
-  let iter_assignable _ _ = ()
+  let iter_assignable () _ _ = ()
 end

src/core/Solver.ml

@@ -27,6 +27,7 @@ module Make
   type term = St.term
   type atom = St.formula
   type clause = St.clause
+  type theory = Th.t
 
   type t = S.t
   type solver = t

src/core/Solver.mli

@@ -22,6 +22,7 @@ module Make
        and type formula = St.formula
        and type clause = St.clause
        and type Proof.lemma = St.proof
+       and type theory = Th.t
 (** Functor to make a safe external interface. *)
 
 

src/core/Solver_intf.ml

@@ -60,14 +60,17 @@ module type S = sig
 
   type clause
 
+  type theory
+
   module Proof : Res.S with type clause = clause
   (** A module to manipulate proofs. *)
 
   type t
   (** Main solver type, containing all state for solving. *)
 
-  val create : ?size:[`Tiny|`Small|`Big] -> unit -> t
+  val create : ?size:[`Tiny|`Small|`Big] -> theory -> t
   (** Create new solver
+      @param theory the theory
       @param size the initial size of internal data structures. The bigger,
         the faster, but also the more RAM it uses. *)
 

src/core/Theory_intf.ml

@@ -37,8 +37,10 @@ type ('form, 'proof) slice = {
     propagation queue. They allow to look at the propagated literals,
     and to add new clauses to the solver. *)
 
+(** Signature for theories to be given to the Solver. *)
 module type S = sig
-  (** Signature for theories to be given to the Solver. *)
+  type t
+  (** The state of the theory itself *)
 
   type formula
   (** The type of formulas. Should be compatble with Formula_intf.S *)
@@ -49,32 +51,33 @@ module type S = sig
   type level
   (** The type for levels to allow backtracking. *)
 
-  val current_level : unit -> level
+  val current_level : t -> level
   (** 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 -> (formula, proof) res
+  val assume : t -> (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. *)
 
-  val if_sat : (formula, proof) slice -> (formula, proof) res
+  val if_sat : t -> (formula, proof) slice -> (formula, proof) res
   (** 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. *)
 
-  val backtrack : level -> unit
+  val backtrack : t -> level -> unit
   (** Backtrack to the given level. After a call to [backtrack l], the theory should be in the
       same state as when it returned the value [l], *)
 
 end
 
 module Dummy(F: Formula_intf.S)
-  : S with type formula = F.t
+  : S with type formula = F.t and type t = unit
 = struct
+  type t = unit
   type formula = F.t
   type proof = unit
   type level = unit
   let current_level () = ()
-  let assume _ = Sat
-  let if_sat _ = Sat
-  let backtrack _ = ()
+  let assume () _ = Sat
+  let if_sat () _ = Sat
+  let backtrack () _ = ()
 end

src/sat/Msat_sat.mli

@@ -11,6 +11,6 @@ Copyright 2016 Guillaume Bury
 
 module Expr = Expr_sat
 
-include Msat.S with type formula = Expr.t
+include Msat.S with type formula = Expr.t and type theory = unit
 (** A functor that can generate as many solvers as needed. *)