simon/sidekick
1
0
Fork 0
mirror of https://github.com/c-cube/sidekick.git synced 2025-12-06 11:15:43 -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: doc:
$(COMP) $(FLAGS) $(DIRS) $(DOC) $(COMP) $(FLAGS) $(DIRS) $(DOC)
log:
cat _build/$(LOG) || true
clean: clean:
$(COMP) -clean $(COMP) -clean

1
_tags
View file

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

17
msat.mlpack
View file

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

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/Arith
smt/Cc smt/Cc
smt/Combine smt/Combine
smt/Exception smt/Exception
smt/Explanation
smt/Fm smt/Fm
smt/Intervals smt/Intervals
smt/Literal smt/Literal
smt/Polynome smt/Polynome
smt/Smt smt/Smt
smt/Solver
smt/Solver_types
smt/Sum smt/Sum
smt/Symbols smt/Symbols
smt/Term smt/Term

1
sat/.merlin
View file

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

2
sat/explanation.ml
View file

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

7
sat/formula_intf.ml
View file

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

247
sat/solver.ml
View file

@ -12,226 +12,149 @@
open Format 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
exception Sat type env = {
exception Unsat of clause list (* si true_, les contraintes sont deja fausses *)
exception Restart
type env =
{
(* si vrai, les contraintes sont deja fausses *)
mutable is_unsat : bool; mutable is_unsat : bool;
mutable unsat_core : clause list; mutable unsat_core : clause list;
(* clauses du probleme *) (* clauses du probleme *)
mutable clauses : clause Vec.t; mutable clauses : clause Vec.t;
(* clauses apprises *) (* clauses apprises *)
mutable learnts : clause Vec.t; mutable learnts : clause Vec.t;
(* valeur de l'increment pour l'activite des clauses *) (* valeur de l'increment pour l'activite des clauses *)
mutable clause_inc : float; mutable clause_inc : float;
(* valeur de l'increment pour l'activite des variables *) (* valeur de l'increment pour l'activite des variables *)
mutable var_inc : float; mutable var_inc : float;
(* un vecteur des variables du probleme *) (* un vecteur des variables du probleme *)
mutable vars : var Vec.t; mutable vars : var Vec.t;
(* la pile de decisions avec les faits impliques *) (* la pile de decisions avec les faits impliques *)
mutable trail : atom Vec.t; mutable trail : atom Vec.t;
(* une pile qui pointe vers les niveaux de decision dans trail *) (* une pile qui pointe vers les niveaux de decision dans trail *)
mutable trail_lim : int Vec.t; mutable trail_lim : int Vec.t;
(* Tete de la File des faits unitaires a propager. (* Tete de la File des faits unitaires a propager.
C'est un index vers le trail *) C'est un index vers le trail *)
mutable qhead : int; mutable qhead : int;
(* Nombre des assignements top-level depuis la derniere (* Nombre des assignements top-level depuis la derniere
execution de 'simplify()' *) execution de 'simplify()' *)
mutable simpDB_assigns : int; mutable simpDB_assigns : int;
(* Nombre restant de propagations a faire avant la prochaine (* Nombre restant de propagations a faire avant la prochaine
execution de 'simplify()' *) execution de 'simplify()' *)
mutable simpDB_props : int; mutable simpDB_props : int;
(* Un tas ordone en fonction de l'activite des variables *) (* Un tas ordone en fonction de l'activite des variables *)
mutable order : Iheap.t; mutable order : Iheap.t;
(* estimation de progressions, mis a jour par 'search()' *) (* estimation de progressions, mis a jour par 'search()' *)
mutable progress_estimate : float; mutable progress_estimate : float;
(* *) (* *)
remove_satisfied : bool; remove_satisfied : bool;
(* inverse du facteur d'acitivte des variables, vaut 1/0.999 par defaut *) (* inverse du facteur d'acitivte des variables, vaut 1/0.999 par defaut *)
var_decay : float; var_decay : float;
(* inverse du facteur d'activite des clauses, vaut 1/0.95 par defaut *) (* inverse du facteur d'activite des clauses, vaut 1/0.95 par defaut *)
clause_decay : float; clause_decay : float;
(* la limite de restart initiale, vaut 100 par defaut *) (* la limite de restart initiale, vaut 100 par defaut *)
mutable restart_first : int; mutable restart_first : int;
(* facteur de multiplication de restart limite, vaut 1.5 par defaut*) (* facteur de multiplication de restart limite, vaut 1.5 par defaut*)
restart_inc : float; restart_inc : float;
(* limite initiale du nombre de clause apprises, vaut 1/3 (* limite initiale du nombre de clause apprises, vaut 1/3
des clauses originales par defaut *) des clauses originales par defaut *)
mutable learntsize_factor : float; mutable learntsize_factor : float;
(* multiplier learntsize_factor par cette valeur a chaque restart, (* multiplier learntsize_factor par cette valeur a chaque restart,
vaut 1.1 par defaut *) vaut 1.1 par defaut *)
learntsize_inc : float; learntsize_inc : float;
(* controler la minimisation des clauses conflit, vaut true par defaut *) (* controler la minimisation des clauses conflit, vaut true par defaut *)
expensive_ccmin : bool; expensive_ccmin : bool;
(* controle la polarite a choisir lors de la decision *) (* controle la polarite a choisir lors de la decision *)
polarity_mode : bool; polarity_mode : bool;
mutable starts : int; mutable starts : int;
mutable decisions : int; mutable decisions : int;
mutable propagations : int; mutable propagations : int;
mutable conflicts : int; mutable conflicts : int;
mutable clauses_literals : int; mutable clauses_literals : int;
mutable learnts_literals : int; mutable learnts_literals : int;
mutable max_literals : int; mutable max_literals : int;
mutable tot_literals : int; mutable tot_literals : int;
mutable nb_init_vars : int; mutable nb_init_vars : int;
mutable nb_init_clauses : int; mutable nb_init_clauses : int;
mutable model : var Vec.t; mutable model : var Vec.t;
mutable tenv : Th.t; mutable tenv : Th.t;
mutable tenv_queue : Th.t Vec.t; mutable tenv_queue : Th.t Vec.t;
mutable tatoms_queue : atom Queue.t; mutable tatoms_queue : atom Queue.t;
} }
type state = {
exception Conflict of clause
type state =
{
env : env; env : env;
st_cpt_mk_var: int; st_cpt_mk_var: int;
st_ma : var F.Map.t; st_ma : varmap;
} }
let env = {
let env =
{
is_unsat = false; is_unsat = false;
unsat_core = [] ; unsat_core = [] ;
clauses = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*) 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*) learnts = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*)
clause_inc = 1.; clause_inc = 1.;
var_inc = 1.; var_inc = 1.;
vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*) vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*)
trail = Vec.make 601 dummy_atom; trail = Vec.make 601 dummy_atom;
trail_lim = Vec.make 601 (-105); trail_lim = Vec.make 601 (-105);
qhead = 0; qhead = 0;
simpDB_assigns = -1; simpDB_assigns = -1;
simpDB_props = 0; simpDB_props = 0;
order = Iheap.init 0; (* sera mis a jour dans solve *) order = Iheap.init 0; (* sera mis a jour dans solve *)
progress_estimate = 0.; progress_estimate = 0.;
remove_satisfied = true; remove_satisfied = true;
var_decay = 1. /. 0.95; var_decay = 1. /. 0.95;
clause_decay = 1. /. 0.999; clause_decay = 1. /. 0.999;
restart_first = 100; restart_first = 100;
restart_inc = 1.5; restart_inc = 1.5;
learntsize_factor = 1. /. 3. ; learntsize_factor = 1. /. 3. ;
learntsize_inc = 1.1; learntsize_inc = 1.1;
expensive_ccmin = true; expensive_ccmin = true;
polarity_mode = false; polarity_mode = false;
starts = 0; starts = 0;
decisions = 0; decisions = 0;
propagations = 0; propagations = 0;
conflicts = 0; conflicts = 0;
clauses_literals = 0; clauses_literals = 0;
learnts_literals = 0; learnts_literals = 0;
max_literals = 0; max_literals = 0;
tot_literals = 0; tot_literals = 0;
nb_init_vars = 0; nb_init_vars = 0;
nb_init_clauses = 0; nb_init_clauses = 0;
model = Vec.make 0 dummy_var; model = Vec.make 0 dummy_var;
tenv = Th.empty(); tenv = Th.empty();
tenv_queue = Vec.make 100 (Th.empty()); tenv_queue = Vec.make 100 (Th.empty());
tatoms_queue = Queue.create (); 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 = let insert_var_order v =
Iheap.insert f_weight env.order v.vid 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 () = let clause_decay_activity () =
env.clause_inc <- env.clause_inc *. env.clause_decay env.clause_inc <- env.clause_inc *. env.clause_decay
let var_bump_activity v = let var_bump_activity v =
v.weight <- v.weight +. env.var_inc; v.weight <- v.weight +. env.var_inc;
if v.weight > 1e100 then begin if v.weight > 1e100 then begin
for i = 0 to env.vars.Vec.sz - 1 do for i = 0 to env.vars.Vec.sz - 1 do
@ -243,7 +166,7 @@ let var_bump_activity v =
Iheap.decrease f_weight env.order v.vid Iheap.decrease f_weight env.order v.vid
let clause_bump_activity c = let clause_bump_activity c =
c.activity <- c.activity +. env.clause_inc; c.activity <- c.activity +. env.clause_inc;
if c.activity > 1e20 then begin if c.activity > 1e20 then begin
for i = 0 to env.learnts.Vec.sz - 1 do for i = 0 to env.learnts.Vec.sz - 1 do
@ -253,18 +176,18 @@ let clause_bump_activity c =
env.clause_inc <- env.clause_inc *. 1e-20 env.clause_inc <- env.clause_inc *. 1e-20
end end
let decision_level () = Vec.size env.trail_lim let decision_level () = Vec.size env.trail_lim
let nb_assigns () = Vec.size env.trail let nb_assigns () = Vec.size env.trail
let nb_clauses () = Vec.size env.clauses let nb_clauses () = Vec.size env.clauses
let nb_learnts () = Vec.size env.learnts let nb_learnts () = Vec.size env.learnts
let nb_vars () = Vec.size env.vars let nb_vars () = Vec.size env.vars
let new_decision_level() = let new_decision_level() =
Vec.push env.trail_lim (Vec.size env.trail); Vec.push env.trail_lim (Vec.size env.trail);
Vec.push env.tenv_queue env.tenv (* save the current tenv *) Vec.push env.tenv_queue env.tenv (* save the current tenv *)
let attach_clause c = let attach_clause c =
Vec.push (Vec.get c.atoms 0).neg.watched c; Vec.push (Vec.get c.atoms 0).neg.watched c;
Vec.push (Vec.get c.atoms 1).neg.watched c; Vec.push (Vec.get c.atoms 1).neg.watched c;
if c.learnt then if c.learnt then
@ -272,7 +195,7 @@ let attach_clause c =
else else
env.clauses_literals <- env.clauses_literals + Vec.size c.atoms env.clauses_literals <- env.clauses_literals + Vec.size c.atoms
let detach_clause c = let detach_clause c =
c.removed <- true; c.removed <- true;
(* (*
Vec.remove (Vec.get c.atoms 0).neg.watched c; Vec.remove (Vec.get c.atoms 0).neg.watched c;
@ -283,9 +206,9 @@ let detach_clause c =
else else
env.clauses_literals <- env.clauses_literals - Vec.size c.atoms env.clauses_literals <- env.clauses_literals - Vec.size c.atoms
let remove_clause c = detach_clause c let remove_clause c = detach_clause c
let satisfied c = let satisfied c =
try try
for i = 0 to Vec.size c.atoms - 1 do for i = 0 to Vec.size c.atoms - 1 do
if (Vec.get c.atoms i).is_true then raise Exit if (Vec.get c.atoms i).is_true then raise Exit
@ -293,8 +216,8 @@ let satisfied c =
false false
with Exit -> true with Exit -> true
(* annule tout jusqu'a lvl *exclu* *) (* annule tout jusqu'a lvl *exclu* *)
let cancel_until lvl = let cancel_until lvl =
if decision_level () > lvl then begin if decision_level () > lvl then begin
env.qhead <- Vec.get env.trail_lim lvl; env.qhead <- Vec.get env.trail_lim lvl;
for c = Vec.size env.trail - 1 downto env.qhead do for c = Vec.size env.trail - 1 downto env.qhead do
@ -314,7 +237,7 @@ let cancel_until lvl =
end; end;
assert (Vec.size env.trail_lim = Vec.size env.tenv_queue) assert (Vec.size env.trail_lim = Vec.size env.tenv_queue)
let rec pick_branch_lit () = let rec pick_branch_lit () =
let max = Iheap.remove_min f_weight env.order in let max = Iheap.remove_min f_weight env.order in
let v = Vec.get env.vars max in let v = Vec.get env.vars max in
if v.level>= 0 then begin if v.level>= 0 then begin
@ -323,7 +246,7 @@ let rec pick_branch_lit () =
end end
else v else v
let enqueue a lvl reason = let enqueue a lvl reason =
assert (not a.is_true && not a.neg.is_true && assert (not a.is_true && not a.neg.is_true &&
a.var.level < 0 && a.var.reason = None && lvl >= 0); a.var.level < 0 && a.var.reason = None && lvl >= 0);
(* Garder la reason car elle est utile pour les unsat-core *) (* Garder la reason car elle est utile pour les unsat-core *)
@ -334,7 +257,7 @@ let enqueue a lvl reason =
(*eprintf "enqueue: %a@." Debug.atom a; *) (*eprintf "enqueue: %a@." Debug.atom a; *)
Vec.push env.trail a Vec.push env.trail a
let progress_estimate () = let progress_estimate () =
let prg = ref 0. in let prg = ref 0. in
let nbv = to_float (nb_vars()) in let nbv = to_float (nb_vars()) in
let lvl = decision_level () in let lvl = decision_level () in
@ -346,10 +269,10 @@ let progress_estimate () =
done; done;
!prg /. nbv !prg /. nbv
let propagate_in_clause a c i watched new_sz = let propagate_in_clause a c i watched new_sz =
let atoms = c.atoms in let atoms = c.atoms in
let first = Vec.get atoms 0 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 0 (Vec.get atoms 1);
Vec.set atoms 1 first Vec.set atoms 1 first
end; end;
@ -389,7 +312,7 @@ let propagate_in_clause a c i watched new_sz =
end end
with Exit -> () with Exit -> ()
let propagate_atom a res = let propagate_atom a res =
let watched = a.watched in let watched = a.watched in
let new_sz_w = ref 0 in let new_sz_w = ref 0 in
begin begin
@ -403,7 +326,7 @@ let propagate_atom a res =
let dead_part = Vec.size watched - !new_sz_w in let dead_part = Vec.size watched - !new_sz_w in
Vec.shrink watched dead_part Vec.shrink watched dead_part
let expensive_theory_propagate () = None let expensive_theory_propagate () = None
(* try *) (* try *)
(* if D1.d then eprintf "expensive_theory_propagate@."; *) (* if D1.d then eprintf "expensive_theory_propagate@."; *)
(* ignore(Th.expensive_processing env.tenv); *) (* ignore(Th.expensive_processing env.tenv); *)
@ -413,7 +336,7 @@ let expensive_theory_propagate () = None
(* if D1.d then eprintf "expensive_theory_propagate => Inconsistent@."; *) (* if D1.d then eprintf "expensive_theory_propagate => Inconsistent@."; *)
(* Some dep *) (* Some dep *)
let theory_propagate () = let theory_propagate () =
let facts = ref [] in let facts = ref [] in
while not (Queue.is_empty env.tatoms_queue) do while not (Queue.is_empty env.tatoms_queue) do
let a = Queue.pop env.tatoms_queue in let a = Queue.pop env.tatoms_queue in
@ -440,7 +363,7 @@ let theory_propagate () =
(* eprintf "th inconsistent : %a @." Ex.print dep; *) (* eprintf "th inconsistent : %a @." Ex.print dep; *)
Some dep Some dep
let propagate () = let propagate () =
let num_props = ref 0 in let num_props = ref 0 in
let res = ref None in let res = ref None in
(*assert (Queue.is_empty env.tqueue);*) (*assert (Queue.is_empty env.tqueue);*)
@ -456,7 +379,7 @@ let propagate () =
!res !res
let analyze c_clause = let analyze c_clause =
let pathC = ref 0 in let pathC = ref 0 in
let learnt = ref [] in let learnt = ref [] in
let cond = ref true in let cond = ref true in
@ -502,7 +425,7 @@ let analyze c_clause =
List.iter (fun q -> q.var.seen <- false) !seen; List.iter (fun q -> q.var.seen <- false) !seen;
!blevel, !learnt, !history, !size !blevel, !learnt, !history, !size
let f_sort_db c1 c2 = let f_sort_db c1 c2 =
let sz1 = Vec.size c1.atoms in let sz1 = Vec.size c1.atoms in
let sz2 = Vec.size c2.atoms in let sz2 = Vec.size c2.atoms in
let c = compare c1.activity c2.activity in let c = compare c1.activity c2.activity in
@ -511,7 +434,7 @@ let f_sort_db c1 c2 =
if sz1 > 2 && (sz2 = 2 || c < 0) then -1 if sz1 > 2 && (sz2 = 2 || c < 0) then -1
else 1 else 1
let locked c = false(* let locked c = false(*
try try
for i = 0 to Vec.size env.vars - 1 do for i = 0 to Vec.size env.vars - 1 do
match (Vec.get env.vars i).reason with match (Vec.get env.vars i).reason with
@ -521,8 +444,8 @@ let locked c = false(*
false false
with Exit -> true*) with Exit -> true*)
let reduce_db () = () let reduce_db () = ()
(* (*
let extra_lim = env.clause_inc /. (to_float (Vec.size env.learnts)) in let extra_lim = env.clause_inc /. (to_float (Vec.size env.learnts)) in
Vec.sort env.learnts f_sort_db; Vec.sort env.learnts f_sort_db;
let lim2 = Vec.size env.learnts in let lim2 = Vec.size env.learnts in
@ -543,9 +466,9 @@ let reduce_db () = ()
begin Vec.set env.learnts !j c; incr j end begin Vec.set env.learnts !j c; incr j end
done; done;
Vec.shrink env.learnts (lim2 - !j) Vec.shrink env.learnts (lim2 - !j)
*) *)
let remove_satisfied vec = let remove_satisfied vec =
let j = ref 0 in let j = ref 0 in
let k = Vec.size vec - 1 in let k = Vec.size vec - 1 in
for i = 0 to k do for i = 0 to k do
@ -559,11 +482,11 @@ let remove_satisfied vec =
Vec.shrink vec (k + 1 - !j) Vec.shrink vec (k + 1 - !j)
module HUC = Hashtbl.Make module HUC = Hashtbl.Make
(struct type t = clause let equal = (==) let hash = Hashtbl.hash end) (struct type t = clause let equal = (==) let hash = Hashtbl.hash end)
let report_b_unsat ({atoms=atoms} as confl) = let report_b_unsat ({atoms=atoms} as confl) =
let l = ref [confl] in let l = ref [confl] in
for i = 0 to Vec.size atoms - 1 do for i = 0 to Vec.size atoms - 1 do
let v = (Vec.get atoms i).var in let v = (Vec.get atoms i).var in
@ -574,7 +497,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
eprintf "@.>>UNSAT Deduction made from:@."; eprintf "@.>>UNSAT Deduction made from:@.";
List.iter List.iter
(fun hc -> (fun hc ->
eprintf " %a@." Debug.clause hc eprintf " %a@." pp_clause hc
)!l; )!l;
end; end;
let uc = HUC.create 17 in let uc = HUC.create 17 in
@ -599,7 +522,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
eprintf "@.>>UNSAT_CORE:@."; eprintf "@.>>UNSAT_CORE:@.";
List.iter List.iter
(fun hc -> (fun hc ->
eprintf " %a@." Debug.clause hc eprintf " %a@." pp_clause hc
)unsat_core; )unsat_core;
end; end;
env.is_unsat <- true; env.is_unsat <- true;
@ -607,7 +530,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
raise (Unsat unsat_core) raise (Unsat unsat_core)
let report_t_unsat dep = let report_t_unsat dep =
let l = let l =
Ex.fold_atoms Ex.fold_atoms
(fun {var=v} l -> (fun {var=v} l ->
@ -619,7 +542,7 @@ let report_t_unsat dep =
eprintf "@.>>T-UNSAT Deduction made from:@."; eprintf "@.>>T-UNSAT Deduction made from:@.";
List.iter List.iter
(fun hc -> (fun hc ->
eprintf " %a@." Debug.clause hc eprintf " %a@." pp_clause hc
)l; )l;
end; end;
let uc = HUC.create 17 in let uc = HUC.create 17 in
@ -644,14 +567,14 @@ let report_t_unsat dep =
eprintf "@.>>T-UNSAT_CORE:@."; eprintf "@.>>T-UNSAT_CORE:@.";
List.iter List.iter
(fun hc -> (fun hc ->
eprintf " %a@." Debug.clause hc eprintf " %a@." pp_clause hc
) unsat_core; ) unsat_core;
end; end;
env.is_unsat <- true; env.is_unsat <- true;
env.unsat_core <- unsat_core; env.unsat_core <- unsat_core;
raise (Unsat unsat_core) raise (Unsat unsat_core)
let simplify () = let simplify () =
assert (decision_level () = 0); assert (decision_level () = 0);
if env.is_unsat then raise (Unsat env.unsat_core); if env.is_unsat then raise (Unsat env.unsat_core);
begin begin
@ -670,7 +593,7 @@ let simplify () =
env.simpDB_props <- env.clauses_literals + env.learnts_literals; env.simpDB_props <- env.clauses_literals + env.learnts_literals;
end end
let record_learnt_clause blevel learnt history size = let record_learnt_clause blevel learnt history size =
begin match learnt with begin match learnt with
| [] -> assert false | [] -> assert false
| [fuip] -> | [fuip] ->
@ -688,7 +611,7 @@ let record_learnt_clause blevel learnt history size =
var_decay_activity (); var_decay_activity ();
clause_decay_activity() clause_decay_activity()
let check_inconsistence_of dep = let check_inconsistence_of dep =
try try
let env = ref (Th.empty()) in (); let env = ref (Th.empty()) in ();
Ex.iter_atoms Ex.iter_atoms
@ -700,7 +623,7 @@ let check_inconsistence_of dep =
assert false assert false
with Th.Inconsistent _ -> () with Th.Inconsistent _ -> ()
let theory_analyze dep = let theory_analyze dep =
let atoms, sz, max_lvl, c_hist = let atoms, sz, max_lvl, c_hist =
Ex.fold_atoms Ex.fold_atoms
(fun a (acc, sz, max_lvl, c_hist) -> (fun a (acc, sz, max_lvl, c_hist) ->
@ -768,14 +691,14 @@ let theory_analyze dep =
let add_boolean_conflict confl = let add_boolean_conflict confl =
env.conflicts <- env.conflicts + 1; env.conflicts <- env.conflicts + 1;
if decision_level() = 0 then report_b_unsat confl; (* Top-level conflict *) if decision_level() = 0 then report_b_unsat confl; (* Top-level conflict *)
let blevel, learnt, history, size = analyze confl in let blevel, learnt, history, size = analyze confl in
cancel_until blevel; cancel_until blevel;
record_learnt_clause blevel learnt history size record_learnt_clause blevel learnt history size
let search n_of_conflicts n_of_learnts = let search n_of_conflicts n_of_learnts =
let conflictC = ref 0 in let conflictC = ref 0 in
env.starts <- env.starts + 1; env.starts <- env.starts + 1;
while (true) do while (true) do
@ -818,7 +741,7 @@ let search n_of_conflicts n_of_learnts =
enqueue next.pa current_level None enqueue next.pa current_level None
done done
let check_clause c = let check_clause c =
let b = ref false in let b = ref false in
let atoms = c.atoms in let atoms = c.atoms in
for i = 0 to Vec.size atoms - 1 do for i = 0 to Vec.size atoms - 1 do
@ -827,15 +750,15 @@ let check_clause c =
done; done;
assert (!b) assert (!b)
let check_vec vec = let check_vec vec =
for i = 0 to Vec.size vec - 1 do check_clause (Vec.get vec i) done for i = 0 to Vec.size vec - 1 do check_clause (Vec.get vec i) done
let check_model () = let check_model () =
check_vec env.clauses; check_vec env.clauses;
check_vec env.learnts check_vec env.learnts
let solve () = let solve () =
if env.is_unsat then raise (Unsat env.unsat_core); if env.is_unsat then raise (Unsat env.unsat_core);
let n_of_conflicts = ref (to_float env.restart_first) in let n_of_conflicts = ref (to_float env.restart_first) in
let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in
@ -854,9 +777,9 @@ let solve () =
(* check_unsat_core cl; *) (* check_unsat_core cl; *)
raise e raise e
exception Trivial exception Trivial
let partition atoms init = let partition atoms init =
let rec partition_aux trues unassigned falses init = function let rec partition_aux trues unassigned falses init = function
| [] -> trues @ unassigned @ falses, init | [] -> trues @ unassigned @ falses, init
| a::r -> | a::r ->
@ -873,7 +796,7 @@ let partition atoms init =
partition_aux [] [] [] init atoms partition_aux [] [] [] init atoms
let add_clause ~cnumber atoms = let add_clause ~cnumber atoms =
if env.is_unsat then raise (Unsat env.unsat_core); if env.is_unsat then raise (Unsat env.unsat_core);
let init_name = string_of_int cnumber in let init_name = string_of_int cnumber in
let init0 = make_clause init_name atoms (List.length atoms) false [] in let init0 = make_clause init_name atoms (List.length atoms) false [] in
@ -915,12 +838,12 @@ let add_clause ~cnumber atoms =
None -> () | Some confl -> report_b_unsat confl None -> () | Some confl -> report_b_unsat confl
with Trivial -> () with Trivial -> ()
let add_clauses cnf ~cnumber = let add_clauses cnf ~cnumber =
List.iter (add_clause ~cnumber) cnf; List.iter (add_clause ~cnumber) cnf;
match theory_propagate () with match theory_propagate () with
None -> () | Some dep -> report_t_unsat dep None -> () | Some dep -> report_t_unsat dep
let init_solver cnf ~cnumber = let init_solver cnf ~cnumber =
let nbv, _ = made_vars_info () in let nbv, _ = made_vars_info () in
let nbc = env.nb_init_clauses + List.length cnf in let nbc = env.nb_init_clauses + List.length cnf in
Vec.grow_to_by_double env.vars nbv; Vec.grow_to_by_double env.vars nbv;
@ -940,11 +863,11 @@ let init_solver cnf ~cnumber =
add_clauses cnf ~cnumber add_clauses cnf ~cnumber
let assume 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 init_solver cnf ~cnumber
let clear () = let clear () =
let empty_theory = Th.empty () in let empty_theory = Th.empty () in
env.is_unsat <- false; env.is_unsat <- false;
env.unsat_core <- []; env.unsat_core <- [];
@ -975,20 +898,20 @@ let clear () =
env.trail_lim <- Vec.make 601 (-105); env.trail_lim <- Vec.make 601 (-105);
env.tenv_queue <- Vec.make 100 (empty_theory); env.tenv_queue <- Vec.make 100 (empty_theory);
env.tatoms_queue <- Queue.create (); env.tatoms_queue <- Queue.create ();
Solver_types.clear () St.clear ()
let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0 let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0
let save () = let save () =
let sv = let sv =
{ env = env; { 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 in
copy sv copy sv
let restore { env = s_env; st_cpt_mk_var = st_cpt_mk_var; st_ma = st_ma } = 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.is_unsat <- s_env.is_unsat;
env.unsat_core <- s_env.unsat_core; env.unsat_core <- s_env.unsat_core;
env.clauses <- s_env.clauses; env.clauses <- s_env.clauses;
@ -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.tenv_queue <- s_env.tenv_queue;
env.tatoms_queue <- s_env.tatoms_queue; env.tatoms_queue <- s_env.tatoms_queue;
env.learntsize_factor <- s_env.learntsize_factor; 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 eval lit =
let var, negated = make_var lit in 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 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 Sat
exception Unsat of St.clause list 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 val restore : state -> unit
end 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_lt n = Hstring.compare n alt = 0
let is_gt n = Hstring.compare n agt = 0 let is_gt n = Hstring.compare n agt = 0
module type S = Solver_types_intf.S
module Make (F : Formula_intf.S) = struct module Make (F : Formula_intf.S) = struct
type formula = F.t
type var = type var =
{ vid : int; { vid : int;
pa : atom; pa : atom;
@ -35,7 +39,7 @@ type var =
and atom = and atom =
{ var : var; { var : var;
lit : F.t; lit : formula;
neg : atom; neg : atom;
mutable watched : clause Vec.t; mutable watched : clause Vec.t;
mutable is_true : bool; mutable is_true : bool;
@ -80,6 +84,7 @@ and dummy_clause =
cpremise = [] } cpremise = [] }
module MA = F.Map module MA = F.Map
type varmap = var MA.t
let ale = Hstring.make "<=" let ale = Hstring.make "<="
let alt = Hstring.make "<" let alt = Hstring.make "<"
@ -174,8 +179,6 @@ let clear () =
cpt_mk_var := 0; cpt_mk_var := 0;
ma := MA.empty ma := MA.empty
module Debug = struct
let sign a = if a==a.var.pa then "" else "-" let sign a = if a==a.var.pa then "" else "-"
let level a = let level a =
@ -196,25 +199,23 @@ module Debug = struct
else if a.neg.is_true then sprintf ":0%s" (level a) else if a.neg.is_true then sprintf ":0%s" (level a)
else ":X" else ":X"
let premise fmt v = let pp_premise fmt v =
List.iter (fun {name=name} -> fprintf fmt "%s," name) 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}}" fprintf fmt "%s%d%s [lit:%a] vpremise={{%a}}"
(sign a) (a.var.vid+1) (value a) F.print a.lit (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 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 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 end

4
sat/solver_types_intf.ml
View file

@ -48,8 +48,8 @@ module type S = sig
and premise = clause list and premise = clause list
val cpt_mk_var : int ref 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_var : var
val dummy_atom : atom val dummy_atom : atom

8
sat/theory_intf.ml
View file

@ -15,13 +15,11 @@
module type S = sig module type S = sig
type t type t
type formula 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 empty : unit -> t
val assume : cs:bool -> formula -> Ex.t -> t -> t val assume : cs:bool -> formula -> explanation -> t -> t
end end

14
smt/cc.ml
View file

@ -189,13 +189,13 @@ module Make (X : Sig.X) = struct
| _ -> [] | _ -> []
let contra_congruence = 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 -> 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 [] else []
let clean_use = let clean_use =
@ -518,7 +518,7 @@ module Make (X : Sig.X) = struct
let t = { gamma = env; gamma_finite = env; choices = [] } in let t = { gamma = env; gamma_finite = env; choices = [] } in
let t, _, _ = let t, _, _ =
assume ~cs:false 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 in t
end end

18
smt/literal.ml
View file

@ -168,8 +168,8 @@ module type S_Term = sig
val mk_pred : Term.t -> t 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 terms_of : t -> Term.Set.t
val vars_of : t -> Symbols.Set.t val vars_of : t -> Symbols.Set.t
@ -182,16 +182,16 @@ module LT : S_Term = struct
module L = Make(Term) module L = Make(Term)
include L 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 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 | _ -> L.neg a
(* let terms_of 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 include S with type elt = Term.t
val mk_pred : Term.t -> t val mk_pred : Term.t -> t
val vrai : t val true_ : t
val faux : t val false_ : t
end end

10
smt/smt.ml
View file

@ -274,8 +274,8 @@ end
lift_ite sb l ty lift_ite sb l ty
with Not_found -> raise (Error (UnknownSymb s)) 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 let rec is_int = function
| T t -> AETerm.is_int t | T t -> AETerm.is_int t
@ -365,8 +365,8 @@ end
| [f] -> print fmt f | [f] -> print fmt f
| f::l -> fprintf fmt "%a %s %a" print f sep (print_list sep) l | 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) let make comb l = Comb (comb, l)
@ -565,7 +565,7 @@ end
[] Ty.Tbool [] Ty.Tbool
in in
incr cpt; incr cpt;
Literal.LT.make (Literal.Eq (t, AETerm.vrai)) Literal.LT.make (Literal.Eq (t, AETerm.true_))
module Tseitin (Dummy : sig end)= struct module Tseitin (Dummy : sig end)= struct
let acc_or = ref [] 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 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 int i = make (Sy.int i) [] Ty.Tint
let real r = make (Sy.real r) [] Ty.Treal 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 view : t -> view
val make : Symbols.t -> t list -> Ty.t -> t 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 int : string -> t
val real : string -> t val real : string -> t