mirror of
https://github.com/c-cube/sidekick.git
synced 2025-12-06 03:05:31 -05:00
Solver module is now functorised. 'make' now compiles.
This commit is contained in:
Guillaume Bury
parent
4acd669d6f
commit
a00506b95f
18 changed files with 931 additions and 1009 deletions
3
Makefile
3
Makefile
|
|
@ -18,6 +18,9 @@ $(LIB):
|
|||
doc:
|
||||
$(COMP) $(FLAGS) $(DIRS) $(DOC)
|
||||
|
||||
log:
|
||||
cat _build/$(LOG) || true
|
||||
|
||||
clean:
|
||||
$(COMP) -clean
|
||||
|
||||
|
|
|
|||
1
_tags
1
_tags
|
|
@ -1,2 +1,3 @@
|
|||
<smt/*.cmx>: for-pack(Msat)
|
||||
<sat/*.cmx>: for-pack(Msat)
|
||||
|
||||
|
|
|
|||
17
msat.mlpack
17
msat.mlpack
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -2,3 +2,4 @@ S ./
|
|||
S ../common/
|
||||
|
||||
B ../_build/
|
||||
B ../_build/common/
|
||||
|
|
|
|||
|
|
@ -14,6 +14,8 @@
|
|||
|
||||
open Format
|
||||
|
||||
module type S = Explanation_intf.S
|
||||
|
||||
module Make(Stypes : Solver_types.S) = struct
|
||||
|
||||
type atom = Stypes.atom
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
247
sat/solver.ml
247
sat/solver.ml
|
|
@ -12,226 +12,149 @@
|
|||
|
||||
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 St
|
||||
|
||||
open Stypes
|
||||
exception Sat
|
||||
exception Unsat of clause list
|
||||
exception Restart
|
||||
exception Conflict of clause
|
||||
|
||||
exception Sat
|
||||
exception Unsat of clause list
|
||||
exception Restart
|
||||
|
||||
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 =
|
||||
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 () =
|
||||
let clause_decay_activity () =
|
||||
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;
|
||||
if v.weight > 1e100 then begin
|
||||
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
|
||||
|
||||
|
||||
let clause_bump_activity c =
|
||||
let clause_bump_activity c =
|
||||
c.activity <- c.activity +. env.clause_inc;
|
||||
if c.activity > 1e20 then begin
|
||||
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
|
||||
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_clauses () = Vec.size env.clauses
|
||||
let nb_learnts () = Vec.size env.learnts
|
||||
let nb_vars () = Vec.size env.vars
|
||||
let nb_assigns () = Vec.size env.trail
|
||||
let nb_clauses () = Vec.size env.clauses
|
||||
let nb_learnts () = Vec.size env.learnts
|
||||
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.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 1).neg.watched c;
|
||||
if c.learnt then
|
||||
|
|
@ -272,7 +195,7 @@ let attach_clause c =
|
|||
else
|
||||
env.clauses_literals <- env.clauses_literals + Vec.size c.atoms
|
||||
|
||||
let detach_clause c =
|
||||
let detach_clause c =
|
||||
c.removed <- true;
|
||||
(*
|
||||
Vec.remove (Vec.get c.atoms 0).neg.watched c;
|
||||
|
|
@ -283,9 +206,9 @@ let detach_clause c =
|
|||
else
|
||||
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
|
||||
for i = 0 to Vec.size c.atoms - 1 do
|
||||
if (Vec.get c.atoms i).is_true then raise Exit
|
||||
|
|
@ -293,8 +216,8 @@ let satisfied c =
|
|||
false
|
||||
with Exit -> true
|
||||
|
||||
(* annule tout jusqu'a lvl *exclu* *)
|
||||
let cancel_until lvl =
|
||||
(* annule tout jusqu'a lvl *exclu* *)
|
||||
let cancel_until lvl =
|
||||
if decision_level () > lvl then begin
|
||||
env.qhead <- Vec.get env.trail_lim lvl;
|
||||
for c = Vec.size env.trail - 1 downto env.qhead do
|
||||
|
|
@ -314,7 +237,7 @@ let cancel_until lvl =
|
|||
end;
|
||||
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 v = Vec.get env.vars max in
|
||||
if v.level>= 0 then begin
|
||||
|
|
@ -323,7 +246,7 @@ let rec pick_branch_lit () =
|
|||
end
|
||||
else v
|
||||
|
||||
let enqueue a lvl reason =
|
||||
let enqueue a lvl reason =
|
||||
assert (not a.is_true && not a.neg.is_true &&
|
||||
a.var.level < 0 && a.var.reason = None && lvl >= 0);
|
||||
(* 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; *)
|
||||
Vec.push env.trail a
|
||||
|
||||
let progress_estimate () =
|
||||
let progress_estimate () =
|
||||
let prg = ref 0. in
|
||||
let nbv = to_float (nb_vars()) in
|
||||
let lvl = decision_level () in
|
||||
|
|
@ -346,10 +269,10 @@ let progress_estimate () =
|
|||
done;
|
||||
!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 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;
|
||||
|
|
@ -389,7 +312,7 @@ let propagate_in_clause a c i watched new_sz =
|
|||
end
|
||||
with Exit -> ()
|
||||
|
||||
let propagate_atom a res =
|
||||
let propagate_atom a res =
|
||||
let watched = a.watched in
|
||||
let new_sz_w = ref 0 in
|
||||
begin
|
||||
|
|
@ -403,7 +326,7 @@ let propagate_atom a res =
|
|||
let dead_part = Vec.size watched - !new_sz_w in
|
||||
Vec.shrink watched dead_part
|
||||
|
||||
let expensive_theory_propagate () = None
|
||||
let expensive_theory_propagate () = None
|
||||
(* try *)
|
||||
(* if D1.d then eprintf "expensive_theory_propagate@."; *)
|
||||
(* ignore(Th.expensive_processing env.tenv); *)
|
||||
|
|
@ -413,7 +336,7 @@ let expensive_theory_propagate () = None
|
|||
(* if D1.d then eprintf "expensive_theory_propagate => Inconsistent@."; *)
|
||||
(* Some dep *)
|
||||
|
||||
let theory_propagate () =
|
||||
let theory_propagate () =
|
||||
let facts = ref [] in
|
||||
while not (Queue.is_empty env.tatoms_queue) do
|
||||
let a = Queue.pop env.tatoms_queue in
|
||||
|
|
@ -440,7 +363,7 @@ let theory_propagate () =
|
|||
(* eprintf "th inconsistent : %a @." Ex.print dep; *)
|
||||
Some dep
|
||||
|
||||
let propagate () =
|
||||
let propagate () =
|
||||
let num_props = ref 0 in
|
||||
let res = ref None in
|
||||
(*assert (Queue.is_empty env.tqueue);*)
|
||||
|
|
@ -456,7 +379,7 @@ let propagate () =
|
|||
!res
|
||||
|
||||
|
||||
let analyze c_clause =
|
||||
let analyze c_clause =
|
||||
let pathC = ref 0 in
|
||||
let learnt = ref [] in
|
||||
let cond = ref true in
|
||||
|
|
@ -502,7 +425,7 @@ let analyze c_clause =
|
|||
List.iter (fun q -> q.var.seen <- false) !seen;
|
||||
!blevel, !learnt, !history, !size
|
||||
|
||||
let f_sort_db c1 c2 =
|
||||
let f_sort_db c1 c2 =
|
||||
let sz1 = Vec.size c1.atoms in
|
||||
let sz2 = Vec.size c2.atoms 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
|
||||
else 1
|
||||
|
||||
let locked c = false(*
|
||||
let locked c = false(*
|
||||
try
|
||||
for i = 0 to Vec.size env.vars - 1 do
|
||||
match (Vec.get env.vars i).reason with
|
||||
|
|
@ -521,8 +444,8 @@ let locked c = false(*
|
|||
false
|
||||
with Exit -> true*)
|
||||
|
||||
let reduce_db () = ()
|
||||
(*
|
||||
let reduce_db () = ()
|
||||
(*
|
||||
let extra_lim = env.clause_inc /. (to_float (Vec.size env.learnts)) in
|
||||
Vec.sort env.learnts f_sort_db;
|
||||
let lim2 = Vec.size env.learnts in
|
||||
|
|
@ -543,9 +466,9 @@ let reduce_db () = ()
|
|||
begin Vec.set env.learnts !j c; incr j end
|
||||
done;
|
||||
Vec.shrink env.learnts (lim2 - !j)
|
||||
*)
|
||||
*)
|
||||
|
||||
let remove_satisfied vec =
|
||||
let remove_satisfied vec =
|
||||
let j = ref 0 in
|
||||
let k = Vec.size vec - 1 in
|
||||
for i = 0 to k do
|
||||
|
|
@ -559,11 +482,11 @@ let remove_satisfied vec =
|
|||
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)
|
||||
|
||||
|
||||
let report_b_unsat ({atoms=atoms} as confl) =
|
||||
let report_b_unsat ({atoms=atoms} as confl) =
|
||||
let l = ref [confl] in
|
||||
for i = 0 to Vec.size atoms - 1 do
|
||||
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:@.";
|
||||
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;
|
||||
|
|
@ -607,7 +530,7 @@ let report_b_unsat ({atoms=atoms} as confl) =
|
|||
raise (Unsat unsat_core)
|
||||
|
||||
|
||||
let report_t_unsat dep =
|
||||
let report_t_unsat dep =
|
||||
let l =
|
||||
Ex.fold_atoms
|
||||
(fun {var=v} l ->
|
||||
|
|
@ -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,14 +567,14 @@ 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;
|
||||
env.unsat_core <- unsat_core;
|
||||
raise (Unsat unsat_core)
|
||||
|
||||
let simplify () =
|
||||
let simplify () =
|
||||
assert (decision_level () = 0);
|
||||
if env.is_unsat then raise (Unsat env.unsat_core);
|
||||
begin
|
||||
|
|
@ -670,7 +593,7 @@ let simplify () =
|
|||
env.simpDB_props <- env.clauses_literals + env.learnts_literals;
|
||||
end
|
||||
|
||||
let record_learnt_clause blevel learnt history size =
|
||||
let record_learnt_clause blevel learnt history size =
|
||||
begin match learnt with
|
||||
| [] -> assert false
|
||||
| [fuip] ->
|
||||
|
|
@ -688,7 +611,7 @@ let record_learnt_clause blevel learnt history size =
|
|||
var_decay_activity ();
|
||||
clause_decay_activity()
|
||||
|
||||
let check_inconsistence_of dep =
|
||||
let check_inconsistence_of dep =
|
||||
try
|
||||
let env = ref (Th.empty()) in ();
|
||||
Ex.iter_atoms
|
||||
|
|
@ -700,7 +623,7 @@ let check_inconsistence_of dep =
|
|||
assert false
|
||||
with Th.Inconsistent _ -> ()
|
||||
|
||||
let theory_analyze dep =
|
||||
let theory_analyze dep =
|
||||
let atoms, sz, max_lvl, c_hist =
|
||||
Ex.fold_atoms
|
||||
(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;
|
||||
if decision_level() = 0 then report_b_unsat confl; (* Top-level conflict *)
|
||||
let blevel, learnt, history, size = analyze confl in
|
||||
cancel_until blevel;
|
||||
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
|
||||
env.starts <- env.starts + 1;
|
||||
while (true) do
|
||||
|
|
@ -818,7 +741,7 @@ let search n_of_conflicts n_of_learnts =
|
|||
enqueue next.pa current_level None
|
||||
done
|
||||
|
||||
let check_clause c =
|
||||
let check_clause c =
|
||||
let b = ref false in
|
||||
let atoms = c.atoms in
|
||||
for i = 0 to Vec.size atoms - 1 do
|
||||
|
|
@ -827,15 +750,15 @@ let check_clause c =
|
|||
done;
|
||||
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
|
||||
|
||||
let check_model () =
|
||||
let check_model () =
|
||||
check_vec env.clauses;
|
||||
check_vec env.learnts
|
||||
|
||||
|
||||
let solve () =
|
||||
let solve () =
|
||||
if env.is_unsat then raise (Unsat env.unsat_core);
|
||||
let n_of_conflicts = ref (to_float env.restart_first) in
|
||||
let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in
|
||||
|
|
@ -854,9 +777,9 @@ let solve () =
|
|||
(* check_unsat_core cl; *)
|
||||
raise e
|
||||
|
||||
exception Trivial
|
||||
exception Trivial
|
||||
|
||||
let partition atoms init =
|
||||
let partition atoms init =
|
||||
let rec partition_aux trues unassigned falses init = function
|
||||
| [] -> trues @ unassigned @ falses, init
|
||||
| a::r ->
|
||||
|
|
@ -873,7 +796,7 @@ let partition atoms init =
|
|||
partition_aux [] [] [] init atoms
|
||||
|
||||
|
||||
let add_clause ~cnumber atoms =
|
||||
let add_clause ~cnumber atoms =
|
||||
if env.is_unsat then raise (Unsat env.unsat_core);
|
||||
let init_name = string_of_int cnumber 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
|
||||
with Trivial -> ()
|
||||
|
||||
let add_clauses cnf ~cnumber =
|
||||
let add_clauses cnf ~cnumber =
|
||||
List.iter (add_clause ~cnumber) cnf;
|
||||
match theory_propagate () with
|
||||
None -> () | Some dep -> report_t_unsat dep
|
||||
|
||||
let init_solver cnf ~cnumber =
|
||||
let init_solver cnf ~cnumber =
|
||||
let nbv, _ = made_vars_info () in
|
||||
let nbc = env.nb_init_clauses + List.length cnf in
|
||||
Vec.grow_to_by_double env.vars nbv;
|
||||
|
|
@ -940,11 +863,11 @@ let init_solver cnf ~cnumber =
|
|||
add_clauses cnf ~cnumber
|
||||
|
||||
|
||||
let assume cnf ~cnumber =
|
||||
let cnf = List.map (List.map Solver_types.add_atom) cnf in
|
||||
let assume cnf ~cnumber =
|
||||
let cnf = List.map (List.map St.add_atom) cnf in
|
||||
init_solver cnf ~cnumber
|
||||
|
||||
let clear () =
|
||||
let clear () =
|
||||
let empty_theory = Th.empty () in
|
||||
env.is_unsat <- false;
|
||||
env.unsat_core <- [];
|
||||
|
|
@ -975,20 +898,20 @@ 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
|
||||
let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0
|
||||
|
||||
let save () =
|
||||
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
|
||||
|
||||
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.unsat_core <- s_env.unsat_core;
|
||||
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.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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
14
smt/cc.ml
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
10
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_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 []
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue