simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2025-12-06 03:05:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

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

Browse source
This commit is contained in:
Guillaume Bury 2014-10-31 14:09:59 +01:00
parent 4acd669d6f
commit a00506b95f
18 changed files with 931 additions and 1009 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
Makefile
View file

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

1
_tags
View file

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

17
msat.mlpack
View file

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

9
msat.odocl
View file

@ -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

1
sat/.merlin
View file

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

2
sat/explanation.ml
View file

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

7
sat/formula_intf.ml
View file

@ -17,12 +17,14 @@ module type S = sig
type t
val vrai : t
val faux : t
val true_ : 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

133
sat/solver.ml
View file

@ -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)
module Ex = Explanation.Make(Stypes)
open Stypes
open St
exception Sat
exception Unsat of clause list
exception Restart
exception Conflict of clause
type env =
{
(* si vrai, les contraintes sont deja fausses *)
type env = {
(* si true_, 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;
}
exception Conflict of clause
type state =
{
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_ma = !Solver_types.ma }
st_cpt_mk_var = !St.cpt_mk_var;
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;
Solver_types.ma := st_ma
St.cpt_mk_var := st_cpt_mk_var;
St.ma := st_ma
let eval lit =
let var, negated = make_var lit in

8
sat/solver.mli
View file

@ -11,9 +11,10 @@
(* *)
(**************************************************************************)
module Make (F : Formula_intf.S)(Th : Theory_intf.S with type formula = F.t) : sig
module St : Solver_types.S with type formula = F.t
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
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

29
sat/solver_types.ml
View file

@ -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 atoms_array fmt arr = Array.iter (fprintf fmt "%a ; " atom) arr
let pp_atoms_list fmt l = List.iter (fprintf fmt "%a ; " pp_atom) l
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} =
fprintf fmt "%s:{ %a} cpremise={{%a}}" name atoms_vec arr premise cp
end
let pp_clause fmt {name=name; atoms=arr; cpremise=cp} =
fprintf fmt "%s:{ %a} cpremise={{%a}}" name pp_atoms_vec arr pp_premise cp
end

4
sat/solver_types_intf.ml
View file

@ -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
val ma : var Map.t ref
type varmap
val ma : varmap ref
val dummy_var : var
val dummy_atom : atom

8
sat/theory_intf.ml
View file

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

14
smt/cc.ml
View file

@ -189,13 +189,13 @@ module Make (X : Sig.X) = struct
| _ -> []
let contra_congruence =
let vrai,_ = X.make T.vrai in
let faux, _ = X.make T.faux in
let true_,_ = X.make T.true_ in
let false_, _ = X.make T.false_ in
fun env r ex ->
if X.equal (fst (Uf.find_r env.uf r)) vrai then
new_facts_by_contra_congruence env r T.faux ex
else if X.equal (fst (Uf.find_r env.uf r)) faux then
new_facts_by_contra_congruence env r T.vrai ex
if X.equal (fst (Uf.find_r env.uf r)) true_ then
new_facts_by_contra_congruence env r T.false_ ex
else if X.equal (fst (Uf.find_r env.uf r)) false_ then
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

18
smt/literal.ml
View file

@ -168,8 +168,8 @@ module type S_Term = sig
val mk_pred : Term.t -> t
val vrai : t
val faux : t
val true_ : 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 faux = mk_pred Term.faux
let true_ = mk_pred Term.true_
let false_ = mk_pred Term.false_
let neg a = match view a with
| Eq(t1, t2) when Term.equal t2 Term.faux ->
make (Eq (t1, Term.vrai))
| Eq(t1, t2) when Term.equal t2 Term.vrai ->
make (Eq (t1, Term.faux))
| Eq(t1, t2) when Term.equal t2 Term.false_ ->
make (Eq (t1, Term.true_))
| Eq(t1, t2) when Term.equal t2 Term.true_ ->
make (Eq (t1, Term.false_))
| _ -> L.neg a
(* let terms_of a =

4
smt/literal.mli
View file

@ -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 faux : t
val true_ : t
val false_ : t
end

10
smt/smt.ml
View file

@ -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_false = T AETerm.faux
let t_true = T AETerm.true_
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_false = Lit Literal.LT.faux
let f_true = Lit Literal.LT.true_
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 []

4
smt/term.ml
View file

@ -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 faux = make (Sy.False) [] Ty.Tbool
let true_ = make (Sy.True) [] 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

4
smt/term.mli
View file

@ -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 faux : t
val true_ : t
val false_ : t
val int : string -> t
val real : string -> t