mirror of
https://github.com/c-cube/sidekick.git
synced 2025-12-06 03:05:31 -05:00
9f01b98cde
- getting closer to having the SMT solver compile again - dummy proof implementation - DRUP proof implementation for pure SAT solver
1961 lines
68 KiB
OCaml
1961 lines
68 KiB
OCaml
|
||
module type PLUGIN = sig
|
||
val has_theory : bool
|
||
(** [true] iff the solver is parametrized by a theory, not just
|
||
pure SAT. *)
|
||
|
||
include Solver_intf.PLUGIN_CDCL_T
|
||
end
|
||
|
||
module type S = Solver_intf.S
|
||
module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T
|
||
|
||
let invalid_argf fmt =
|
||
Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt
|
||
|
||
module type INT_ID = sig
|
||
type t = private int
|
||
val equal : t -> t -> bool
|
||
val compare : t -> t -> int
|
||
val hash : t -> int
|
||
val to_int : t -> int
|
||
val of_int_unsafe : int -> t
|
||
end
|
||
|
||
module Mk_int_id() = struct
|
||
type t = int
|
||
let equal : t -> t -> bool = (=)
|
||
let compare : t -> t -> int = compare
|
||
let hash = CCHash.int
|
||
let[@inline] to_int i = i
|
||
external of_int_unsafe : int -> t = "%identity"
|
||
end
|
||
|
||
module Make(Plugin : PLUGIN)
|
||
= struct
|
||
type formula = Plugin.formula
|
||
type theory = Plugin.t
|
||
type proof = Plugin.proof
|
||
type dproof = proof -> unit
|
||
|
||
module Formula = Plugin.Formula
|
||
module Proof = Plugin.Proof
|
||
|
||
(* ### types ### *)
|
||
|
||
(* a boolean variable (positive int) *)
|
||
module Var0 : sig
|
||
include INT_ID
|
||
module Set : Set.S with type elt = t
|
||
end = struct
|
||
include Mk_int_id()
|
||
module Set = Util.Int_set
|
||
end
|
||
type var = Var0.t
|
||
|
||
(* a signed atom. +v is (v << 1), -v is (v<<1 | 1) *)
|
||
module Atom0 : sig
|
||
include INT_ID
|
||
val neg : t -> t
|
||
val sign : t -> bool
|
||
|
||
val of_var : var -> t
|
||
val var : t -> var
|
||
val abs : t -> t
|
||
val pa : var -> t
|
||
val na : var -> t
|
||
module Set : CCSet.S with type elt = t
|
||
end = struct
|
||
include Mk_int_id()
|
||
let[@inline] neg i = (i lxor 1)
|
||
let[@inline] sign i = (i land 1) = 0
|
||
|
||
let[@inline] pa v = (v:var:>int) lsl 1
|
||
let of_var = pa
|
||
let[@inline] abs a = a land (lnot 1)
|
||
let[@inline] var a = Var0.of_int_unsafe (a lsr 1)
|
||
let[@inline] na v = (((v:var:>int) lsl 1) lor 1)
|
||
module Set = Util.Int_set
|
||
end
|
||
type atom = Atom0.t
|
||
|
||
module Clause0 : sig
|
||
include INT_ID
|
||
module Tbl : Hashtbl.S with type key = t
|
||
end = struct
|
||
include Mk_int_id()
|
||
module Tbl = Util.Int_tbl
|
||
end
|
||
type clause = Clause0.t
|
||
|
||
and reason =
|
||
| Decision
|
||
| Bcp of clause
|
||
| Bcp_lazy of clause lazy_t
|
||
|
||
(* ### stores ### *)
|
||
|
||
module Form_tbl = Hashtbl.Make(Formula)
|
||
|
||
(* variable/atom store *)
|
||
module Store = struct
|
||
type cstore = {
|
||
c_lits: atom array Vec.t; (* storage for clause content *)
|
||
c_activity: Vec_float.t;
|
||
c_recycle_idx: VecI32.t; (* recycle clause numbers that were GC'd *)
|
||
c_attached: Bitvec.t;
|
||
c_marked: Bitvec.t; (* TODO : remove *)
|
||
c_removable: Bitvec.t;
|
||
c_dead: Bitvec.t;
|
||
}
|
||
|
||
type t = {
|
||
(* variables *)
|
||
v_of_form: var Form_tbl.t;
|
||
v_level: int Vec.t;
|
||
v_heap_idx: int Vec.t;
|
||
v_weight: Vec_float.t;
|
||
v_reason: reason option Vec.t;
|
||
v_seen: Bitvec.t;
|
||
v_default_polarity: Bitvec.t;
|
||
mutable v_count : int;
|
||
|
||
(* atoms *)
|
||
a_is_true: Bitvec.t;
|
||
a_seen: Bitvec.t;
|
||
a_form: formula Vec.t;
|
||
(* TODO: store watches in clauses instead *)
|
||
a_watched: clause Vec.t Vec.t;
|
||
|
||
(* clauses *)
|
||
c_store: cstore;
|
||
}
|
||
type store = t
|
||
|
||
let create ?(size=`Big) () : t =
|
||
let size_map = match size with
|
||
| `Tiny -> 8
|
||
| `Small -> 16
|
||
| `Big -> 4096
|
||
in
|
||
{ v_of_form = Form_tbl.create size_map;
|
||
v_level = Vec.create();
|
||
v_heap_idx = Vec.create();
|
||
v_weight = Vec_float.create();
|
||
v_reason = Vec.create();
|
||
v_seen = Bitvec.create();
|
||
v_default_polarity = Bitvec.create();
|
||
v_count = 0;
|
||
a_is_true=Bitvec.create();
|
||
a_form=Vec.create();
|
||
a_watched=Vec.create();
|
||
a_seen=Bitvec.create();
|
||
c_store={
|
||
c_lits=Vec.create();
|
||
c_activity=Vec_float.create();
|
||
c_recycle_idx=VecI32.create ~cap:0 ();
|
||
c_dead=Bitvec.create();
|
||
c_attached=Bitvec.create();
|
||
c_removable=Bitvec.create();
|
||
c_marked=Bitvec.create();
|
||
}
|
||
}
|
||
|
||
(** Number of variables *)
|
||
let[@inline] n_vars self : int = Vec.size self.v_level
|
||
|
||
(** iterate on variables *)
|
||
let iter_vars self f =
|
||
Vec.iteri (fun i _ -> f (Var0.of_int_unsafe i)) self.v_level
|
||
|
||
module Var = struct
|
||
include Var0
|
||
let[@inline] level self v = Vec.get self.v_level (v:var:>int)
|
||
let[@inline] set_level self v l = Vec.set self.v_level (v:var:>int) l
|
||
let[@inline] reason self v = Vec.get self.v_reason (v:var:>int)
|
||
let[@inline] set_reason self v r = Vec.set self.v_reason (v:var:>int) r
|
||
let[@inline] weight self v = Vec_float.get self.v_weight (v:var:>int)
|
||
let[@inline] set_weight self v w = Vec_float.set self.v_weight (v:var:>int) w
|
||
let[@inline] mark self v = Bitvec.set self.v_seen (v:var:>int) true
|
||
let[@inline] unmark self v = Bitvec.set self.v_seen (v:var:>int) false
|
||
let[@inline] marked self v = Bitvec.get self.v_seen (v:var:>int)
|
||
let[@inline] set_default_pol self v b = Bitvec.set self.v_default_polarity (v:var:>int) b
|
||
let[@inline] default_pol self v = Bitvec.get self.v_default_polarity (v:var:>int)
|
||
let[@inline] heap_idx self v = Vec.get self.v_heap_idx (v:var:>int)
|
||
let[@inline] set_heap_idx self v i = Vec.set self.v_heap_idx (v:var:>int) i
|
||
end
|
||
|
||
module Atom = struct
|
||
include Atom0
|
||
let[@inline] lit self a = Vec.get self.a_form (a:atom:>int)
|
||
let formula = lit
|
||
let[@inline] mark self a = Bitvec.set self.a_seen (a:atom:>int) true
|
||
let[@inline] unmark self a = Bitvec.set self.a_seen (a:atom:>int) false
|
||
let[@inline] marked self a = Bitvec.get self.a_seen (a:atom:>int)
|
||
let[@inline] watched self a = Vec.get self.a_watched (a:atom:>int)
|
||
let[@inline] is_true self a = Bitvec.get self.a_is_true (a:atom:>int)
|
||
let[@inline] set_is_true self a b = Bitvec.set self.a_is_true (a:atom:>int) b
|
||
|
||
let[@inline] is_false self a = is_true self (neg a)
|
||
let[@inline] has_value self a = is_true self a || is_false self a
|
||
|
||
let[@inline] reason self a = Var.reason self (var a)
|
||
let[@inline] level self a = Var.level self (var a)
|
||
let[@inline] marked_both self a = marked self a && marked self (neg a)
|
||
|
||
let pp self fmt a = Formula.pp fmt (lit self a)
|
||
|
||
let pp_a self fmt v =
|
||
if Array.length v = 0 then (
|
||
Format.fprintf fmt "@<1>∅"
|
||
) else (
|
||
pp self fmt v.(0);
|
||
if (Array.length v) > 1 then begin
|
||
for i = 1 to (Array.length v) - 1 do
|
||
Format.fprintf fmt " @<1>∨ %a" (pp self) v.(i)
|
||
done
|
||
end
|
||
)
|
||
|
||
(* Complete debug printing *)
|
||
|
||
let[@inline] pp_sign a = if sign a then "+" else "-"
|
||
|
||
(* print level+reason of assignment *)
|
||
let debug_reason self out = function
|
||
| n, _ when n < 0 -> Format.fprintf out "%%"
|
||
| n, None -> Format.fprintf out "%d" n
|
||
| n, Some Decision -> Format.fprintf out "@@%d" n
|
||
| n, Some Bcp c ->
|
||
Format.fprintf out "->%d/%d" n (c:>int)
|
||
| n, Some (Bcp_lazy _) -> Format.fprintf out "->%d/<lazy>" n
|
||
|
||
let pp_level self out a =
|
||
let v = var a in
|
||
debug_reason self out (Var.level self v, Var.reason self v)
|
||
|
||
let debug_value self out (a:atom) =
|
||
if is_true self a then Format.fprintf out "T%a" (pp_level self) a
|
||
else if is_false self a then Format.fprintf out "F%a" (pp_level self) a
|
||
else ()
|
||
|
||
let debug self out a =
|
||
Format.fprintf out "%s%d[%a][atom:@[<hov>%a@]]"
|
||
(pp_sign a) (var a:var:>int) (debug_value self) a
|
||
Formula.pp (lit self a)
|
||
|
||
let debug_a self out vec =
|
||
Array.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) vec
|
||
let debug_l self out l =
|
||
List.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) l
|
||
end
|
||
|
||
module Clause : sig
|
||
include module type of Clause0 with type t = Clause0.t
|
||
|
||
(** Make a clause with the given atoms *)
|
||
|
||
val make_a : store -> removable:bool -> atom array -> t
|
||
val make_l : store -> removable:bool -> atom list -> t
|
||
val make_vec : store -> removable:bool -> atom Vec.t -> t
|
||
|
||
val n_atoms : store -> t -> int
|
||
|
||
val marked : store -> t -> bool
|
||
val set_marked : store -> t -> bool -> unit
|
||
val attached : store -> t -> bool
|
||
val set_attached : store -> t -> bool -> unit
|
||
val removable : store -> t -> bool
|
||
val set_removable : store -> t -> bool -> unit
|
||
|
||
val dead : store -> t -> bool
|
||
val set_dead : store -> t -> bool -> unit
|
||
val dealloc : store -> t -> unit
|
||
(** Delete the clause *)
|
||
|
||
val activity : store -> t -> float
|
||
val set_activity : store -> t -> float -> unit
|
||
|
||
val iter : store -> f:(atom -> unit) -> t -> unit
|
||
val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a
|
||
val for_all : store -> f:(atom -> bool) -> t -> bool
|
||
val exists : store -> f:(atom -> bool) -> t -> bool
|
||
|
||
val atoms_a : store -> t -> atom array
|
||
val atoms_l : store -> t -> atom list (* allocates *)
|
||
val atoms_iter : store -> t -> atom Iter.t
|
||
|
||
val short_name : store -> t -> string
|
||
val pp : store -> Format.formatter -> t -> unit
|
||
val debug : store -> Format.formatter -> t -> unit
|
||
end = struct
|
||
include Clause0
|
||
|
||
(* TODO: store watch lists inside clauses *)
|
||
|
||
let make_a (store:store) ~removable (atoms:atom array) : t =
|
||
let {
|
||
c_recycle_idx; c_lits; c_activity;
|
||
c_attached; c_dead; c_removable; c_marked;
|
||
} = store.c_store in
|
||
(* allocate new ID *)
|
||
let cid =
|
||
if VecI32.is_empty c_recycle_idx then (
|
||
Vec.size c_lits
|
||
) else VecI32.pop c_recycle_idx
|
||
in
|
||
|
||
(* allocate space *)
|
||
begin
|
||
let new_len = cid + 1 in
|
||
Vec.ensure_size c_lits [||] new_len;
|
||
Vec_float.ensure_size c_activity new_len;
|
||
Bitvec.ensure_size c_attached new_len;
|
||
Bitvec.ensure_size c_dead new_len;
|
||
Bitvec.ensure_size c_removable new_len;
|
||
Bitvec.ensure_size c_marked new_len;
|
||
|
||
Bitvec.set c_removable cid removable;
|
||
end;
|
||
|
||
Vec.set c_lits cid atoms;
|
||
|
||
let c = of_int_unsafe cid in
|
||
c
|
||
|
||
let make_l store ~removable atoms : t =
|
||
make_a store ~removable (Array.of_list atoms)
|
||
|
||
let make_vec store ~removable atoms : t =
|
||
make_a store ~removable (Vec.to_array atoms)
|
||
|
||
let[@inline] n_atoms (store:store) (c:t) : int =
|
||
Array.length (Vec.get store.c_store.c_lits (c:t:>int))
|
||
|
||
let[@inline] iter (store:store) ~f c =
|
||
let {c_lits; _} = store.c_store in
|
||
Array.iter f (Vec.get c_lits (c:t:>int))
|
||
|
||
exception Early_exit
|
||
|
||
let for_all store ~f c =
|
||
try
|
||
iter store c ~f:(fun x -> if not (f x) then raise_notrace Early_exit);
|
||
true
|
||
with Early_exit -> false
|
||
|
||
let exists store ~f c =
|
||
try
|
||
iter store c ~f:(fun x -> if f x then raise_notrace Early_exit);
|
||
false
|
||
with Early_exit -> true
|
||
|
||
let fold (store:store) ~f acc c =
|
||
let {c_lits; _} = store.c_store in
|
||
Array.fold_left f acc (Vec.get c_lits (c:t:>int))
|
||
|
||
let[@inline] marked store c = Bitvec.get store.c_store.c_marked (c:t:>int)
|
||
let[@inline] set_marked store c b = Bitvec.set store.c_store.c_marked (c:t:>int) b
|
||
let[@inline] attached store c = Bitvec.get store.c_store.c_attached (c:t:>int)
|
||
let[@inline] set_attached store c b = Bitvec.set store.c_store.c_attached (c:t:>int) b
|
||
let[@inline] dead store c = Bitvec.get store.c_store.c_dead (c:t:>int)
|
||
let[@inline] set_dead store c b = Bitvec.set store.c_store.c_dead (c:t:>int) b
|
||
let[@inline] removable store c = Bitvec.get store.c_store.c_removable (c:t:>int)
|
||
let[@inline] set_removable store c b = Bitvec.set store.c_store.c_removable (c:t:>int) b
|
||
|
||
let dealloc store c : unit =
|
||
assert (dead store c);
|
||
let {c_lits; c_recycle_idx; c_activity;
|
||
c_dead; c_removable; c_attached; c_marked; } = store.c_store in
|
||
|
||
(* clear data *)
|
||
let cid = (c:t:>int) in
|
||
Bitvec.set c_attached cid false;
|
||
Bitvec.set c_dead cid false;
|
||
Bitvec.set c_removable cid false;
|
||
Bitvec.set c_marked cid false;
|
||
Vec.set c_lits cid [||];
|
||
Vec_float.set c_activity cid 0.;
|
||
|
||
VecI32.push c_recycle_idx cid; (* recycle idx *)
|
||
()
|
||
|
||
let copy_flags store c1 c2 : unit =
|
||
set_removable store c2 (removable store c1);
|
||
()
|
||
|
||
let[@inline] activity store c = Vec_float.get store.c_store.c_activity (c:t:>int)
|
||
let[@inline] set_activity store c f = Vec_float.set store.c_store.c_activity (c:t:>int) f
|
||
|
||
let[@inline] make_removable store l =
|
||
make_l store ~removable:true l
|
||
|
||
let[@inline] make_removable_a store a =
|
||
make_a store ~removable:true a
|
||
|
||
let[@inline] make_permanent store l =
|
||
let c = make_l store ~removable:false l in
|
||
assert (not (removable store c)); (* permanent by default *)
|
||
c
|
||
|
||
let[@inline] atoms_a store c : atom array =
|
||
Vec.get store.c_store.c_lits (c:t:>int)
|
||
let atoms_l store c : _ list = Array.to_list (atoms_a store c)
|
||
let atoms_iter store c = fun k -> iter store c ~f:k
|
||
|
||
let short_name _store c = Printf.sprintf "cl[%d]" (c:t:>int)
|
||
|
||
let pp store fmt c =
|
||
Format.fprintf fmt "(cl[%d] : %a" (c:t:>int)
|
||
(Atom.pp_a store) (atoms_a store c)
|
||
|
||
let debug store out c =
|
||
let atoms = atoms_a store c in
|
||
Format.fprintf out
|
||
"(@[cl[%d]@ {@[<hov>%a@]}@])"
|
||
(c:t:>int)
|
||
(Atom.debug_a store) atoms
|
||
end
|
||
|
||
(* allocate new variable *)
|
||
let alloc_var_uncached_ ?default_pol:(pol=true) self (form:formula) : var =
|
||
let {v_count; v_of_form; v_level; v_heap_idx; v_weight;
|
||
v_reason; v_seen; v_default_polarity;
|
||
a_is_true; a_seen; a_watched; a_form; c_store=_;
|
||
} = self in
|
||
|
||
let v_idx = v_count in
|
||
let v = Var.of_int_unsafe v_idx in
|
||
|
||
self.v_count <- 1 + v_idx;
|
||
Form_tbl.add v_of_form form v;
|
||
Vec.push v_level (-1);
|
||
Vec.push v_heap_idx (-1);
|
||
Vec.push v_reason None;
|
||
Vec_float.push v_weight 0.;
|
||
Bitvec.ensure_size v_seen v_idx;
|
||
Bitvec.ensure_size v_default_polarity v_idx;
|
||
Bitvec.set v_default_polarity v_idx pol;
|
||
|
||
assert (Vec.size a_form = 2 * (v:var:>int));
|
||
Bitvec.ensure_size a_is_true (2*(v:var:>int));
|
||
Bitvec.ensure_size a_seen (2*(v:var:>int));
|
||
Vec.push a_form form;
|
||
Vec.push a_watched (Vec.create());
|
||
Vec.push a_form (Formula.neg form);
|
||
Vec.push a_watched (Vec.create());
|
||
assert (Vec.get a_form (Atom.of_var v:atom:>int) == form);
|
||
|
||
v
|
||
|
||
(* create new variable *)
|
||
let alloc_var (self:t) ?default_pol (t:formula) : var * Solver_intf.negated =
|
||
let form, negated = Formula.norm t in
|
||
try Form_tbl.find self.v_of_form form, negated
|
||
with Not_found ->
|
||
let v = alloc_var_uncached_ ?default_pol self form in
|
||
v, negated
|
||
|
||
let clear_var (self:t) (v:var) : unit =
|
||
Var.unmark self v;
|
||
Atom.unmark self (Atom.pa v);
|
||
Atom.unmark self (Atom.na v);
|
||
()
|
||
|
||
let alloc_atom (self:t) ?default_pol lit : atom =
|
||
let var, negated = alloc_var self ?default_pol lit in
|
||
match negated with
|
||
| Solver_intf.Same_sign -> Atom.pa var
|
||
| Solver_intf.Negated -> Atom.na var
|
||
end
|
||
type store = Store.t
|
||
|
||
module Atom = Store.Atom
|
||
module Var = Store.Var
|
||
module Clause = Store.Clause
|
||
|
||
module H = (Heap.Make [@specialise]) (struct
|
||
type store = Store.t
|
||
type t = var
|
||
let[@inline] cmp store i j =
|
||
Var.weight store j < Var.weight store i (* comparison by weight *)
|
||
let heap_idx = Var.heap_idx
|
||
let set_heap_idx = Var.set_heap_idx
|
||
let of_int_unsafe = Var.of_int_unsafe
|
||
end)
|
||
|
||
(* cause of "unsat", possibly conditional to local assumptions *)
|
||
type unsat_cause =
|
||
| US_local of {
|
||
first: atom; (* assumption which was found to be proved false *)
|
||
core: atom list; (* the set of assumptions *)
|
||
}
|
||
| US_false of clause (* true unsat *)
|
||
|
||
exception E_sat
|
||
exception E_unsat of unsat_cause
|
||
exception UndecidedLit
|
||
exception Restart
|
||
exception Conflict of clause
|
||
|
||
let var_decay : float = 1. /. 0.95
|
||
(* inverse of the activity factor for variables *)
|
||
|
||
let clause_decay : float = 1. /. 0.999
|
||
(* inverse of the activity factor for clauses *)
|
||
|
||
let restart_inc : float = 1.5
|
||
(* multiplicative factor for restart limit *)
|
||
|
||
let learntsize_inc : float = 1.1
|
||
(* multiplicative factor for [learntsize_factor] at each restart *)
|
||
|
||
(* Singleton type containing the current state *)
|
||
type t = {
|
||
store : store;
|
||
(* atom/var/clause store *)
|
||
|
||
th: theory;
|
||
(* user defined theory *)
|
||
|
||
proof: Proof.t; (* the proof object *)
|
||
|
||
(* Clauses are simplified for efficiency purposes. In the following
|
||
vectors, the comments actually refer to the original non-simplified
|
||
clause. *)
|
||
|
||
(* TODO: this should be a veci32 *)
|
||
clauses_hyps : clause Vec.t;
|
||
(* clauses added by the user *)
|
||
|
||
clauses_learnt : clause Vec.t;
|
||
(* learnt clauses (tautologies true at any time, whatever the user level) *)
|
||
|
||
clauses_to_add : clause Vec.t;
|
||
(* Clauses either assumed or pushed by the theory, waiting to be added. *)
|
||
|
||
mutable unsat_at_0: clause option;
|
||
(* conflict at level 0, if any *)
|
||
|
||
mutable next_decisions : atom list;
|
||
(* When the last conflict was a semantic one (mcsat),
|
||
this stores the next decision to make;
|
||
if some theory wants atoms to be decided on (for theory combination),
|
||
store them here. *)
|
||
|
||
trail : atom Vec.t;
|
||
(* decision stack + propagated elements (atoms or assignments). *)
|
||
|
||
var_levels : int Vec.t;
|
||
(* decision levels in [trail] *)
|
||
|
||
mutable assumptions: atom Vec.t;
|
||
(* current assumptions *)
|
||
|
||
mutable th_head : int;
|
||
(* Start offset in the queue {!trail} of
|
||
unit facts not yet seen by the theory. *)
|
||
mutable elt_head : int;
|
||
(* Start offset in the queue {!trail} of
|
||
unit facts to propagate, within the trail *)
|
||
|
||
(* invariant:
|
||
- during propagation, th_head <= elt_head
|
||
- then, once elt_head reaches length trail, Th.assume is
|
||
called so that th_head can catch up with elt_head
|
||
- this is repeated until a fixpoint is reached;
|
||
- before a decision (and after the fixpoint),
|
||
th_head = elt_head = length trail
|
||
*)
|
||
|
||
order : H.t;
|
||
(* Heap ordered by variable activity *)
|
||
|
||
to_clear: var Vec.t;
|
||
(* variables to unmark *)
|
||
|
||
(* temporaries *)
|
||
|
||
temp_atom_vec : atom Vec.t;
|
||
temp_clause_vec : clause Vec.t;
|
||
|
||
mutable var_incr : float;
|
||
(* increment for variables' activity *)
|
||
|
||
mutable clause_incr : float;
|
||
(* increment for clauses' activity *)
|
||
|
||
mutable on_conflict : (t -> atom array -> unit) option;
|
||
mutable on_decision : (t -> atom -> unit) option;
|
||
mutable on_new_atom: (t -> atom -> unit) option;
|
||
mutable on_learnt : (t -> atom array -> unit) option;
|
||
mutable on_gc : (t -> atom array -> unit) option;
|
||
|
||
mutable n_conflicts : int;
|
||
mutable n_propagations : int;
|
||
mutable n_decisions : int;
|
||
mutable n_restarts : int;
|
||
}
|
||
type solver = t
|
||
|
||
(* intial restart limit *)
|
||
let restart_first = 100
|
||
|
||
(* initial limit for the number of learnt clauses, 1/3 of initial
|
||
number of clauses by default *)
|
||
let learntsize_factor = 1. /. 3.
|
||
|
||
let _nop_on_conflict (_:atom array) = ()
|
||
|
||
(* Starting environment. *)
|
||
let create_ ~store ~proof (th:theory) : t = {
|
||
store; th;
|
||
unsat_at_0=None;
|
||
next_decisions = [];
|
||
|
||
clauses_hyps = Vec.create();
|
||
clauses_learnt = Vec.create();
|
||
|
||
clauses_to_add = Vec.create ();
|
||
to_clear=Vec.create();
|
||
temp_clause_vec=Vec.create();
|
||
temp_atom_vec=Vec.create();
|
||
|
||
th_head = 0;
|
||
elt_head = 0;
|
||
|
||
trail = Vec.create ();
|
||
var_levels = Vec.create();
|
||
assumptions= Vec.create();
|
||
|
||
order = H.create store;
|
||
|
||
var_incr = 1.;
|
||
clause_incr = 1.;
|
||
|
||
proof;
|
||
|
||
n_conflicts = 0;
|
||
n_decisions = 0;
|
||
n_propagations = 0;
|
||
n_restarts = 0;
|
||
|
||
on_conflict = None;
|
||
on_decision= None;
|
||
on_new_atom = None;
|
||
on_learnt = None;
|
||
on_gc = None;
|
||
}
|
||
|
||
let create
|
||
?on_conflict ?on_decision ?on_new_atom ?on_learnt ?on_gc
|
||
?(size=`Big) ~proof
|
||
(th:theory) : t =
|
||
let store = Store.create ~size () in
|
||
let self = create_ ~store ~proof th in
|
||
self.on_new_atom <- on_new_atom;
|
||
self.on_decision <- on_decision;
|
||
self.on_conflict <- on_conflict;
|
||
self.on_learnt <- on_learnt;
|
||
self.on_gc <- on_gc;
|
||
self
|
||
|
||
let[@inline] decision_level st = Vec.size st.var_levels
|
||
|
||
let[@inline] nb_clauses st = Vec.size st.clauses_hyps
|
||
let n_propagations self = self.n_propagations
|
||
let n_decisions self = self.n_decisions
|
||
let n_conflicts self = self.n_conflicts
|
||
let n_restarts self = self.n_restarts
|
||
|
||
(* Do we have a level-0 empty clause? *)
|
||
let[@inline] check_unsat_ st =
|
||
match st.unsat_at_0 with
|
||
| Some c -> raise (E_unsat (US_false c))
|
||
| None -> ()
|
||
|
||
(* Variable and literal activity.
|
||
Activity is used to decide on which variable to decide when propagation
|
||
is done. Uses a heap (implemented in Iheap), to keep track of variable activity.
|
||
To be more general, the heap only stores the variable/literal id (i.e an int).
|
||
*)
|
||
let[@inline] insert_var_order st (v:var) : unit =
|
||
H.insert st.order v
|
||
|
||
(* create a new atom, pushing it into the decision queue if needed *)
|
||
let make_atom (self:t) ?default_pol (p:formula) : atom =
|
||
let a = Store.alloc_atom self.store ?default_pol p in
|
||
if Atom.level self.store a < 0 then (
|
||
insert_var_order self (Atom.var a);
|
||
(match self.on_new_atom with Some f -> f self a | None -> ());
|
||
) else (
|
||
assert (Atom.is_true self.store a || Atom.is_false self.store a);
|
||
);
|
||
a
|
||
|
||
(* Rather than iterate over all the heap when we want to decrease all the
|
||
variables/literals activity, we instead increase the value by which
|
||
we increase the activity of 'interesting' var/lits. *)
|
||
let[@inline] var_decay_activity st =
|
||
st.var_incr <- st.var_incr *. var_decay
|
||
|
||
let[@inline] clause_decay_activity st =
|
||
st.clause_incr <- st.clause_incr *. clause_decay
|
||
|
||
(* increase activity of [v] *)
|
||
let var_bump_activity self v =
|
||
let store = self.store in
|
||
Var.set_weight store v (Var.weight store v +. self.var_incr);
|
||
if Var.weight store v > 1e100 then (
|
||
Store.iter_vars store
|
||
(fun v ->
|
||
Var.set_weight store v (Var.weight store v *. 1e-100));
|
||
self.var_incr <- self.var_incr *. 1e-100;
|
||
);
|
||
if H.in_heap self.order v then (
|
||
H.decrease self.order v
|
||
)
|
||
|
||
(* increase activity of clause [c] *)
|
||
let clause_bump_activity self (c:clause) : unit =
|
||
let store = self.store in
|
||
Clause.set_activity store c (Clause.activity store c +. self.clause_incr);
|
||
if Clause.activity store c > 1e20 then (
|
||
Vec.iter
|
||
(fun c -> Clause.set_activity store c (Clause.activity store c *. 1e-20))
|
||
self.clauses_learnt;
|
||
self.clause_incr <- self.clause_incr *. 1e-20
|
||
)
|
||
|
||
(* Simplification of clauses.
|
||
|
||
When adding new clauses, it is desirable to 'simplify' them, i.e
|
||
minimize the amount of literals in it, because it greatly reduces
|
||
the search space for new watched literals during propagation.
|
||
Additionally, we have to partition the lits, to ensure the watched
|
||
literals (which are the first two lits of the clause) are appropriate.
|
||
Indeed, it is better to watch true literals, and then unassigned literals.
|
||
Watching false literals should be a last resort, and come with constraints
|
||
(see {!add_clause}).
|
||
*)
|
||
exception Trivial
|
||
|
||
(* [arr_to_list a i] converts [a.(i), ... a.(length a-1)] into a list *)
|
||
let arr_to_list arr i : _ list =
|
||
if i >= Array.length arr then []
|
||
else Array.to_list (Array.sub arr i (Array.length arr - i))
|
||
|
||
(* Eliminates atom duplicates in clauses *)
|
||
let eliminate_duplicates store clause : clause =
|
||
let trivial = ref false in
|
||
let duplicates = ref [] in
|
||
let res = ref [] in
|
||
Clause.iter store clause
|
||
~f:(fun a ->
|
||
if Atom.marked store a then duplicates := a :: !duplicates
|
||
else (
|
||
Atom.mark store a;
|
||
res := a :: !res
|
||
));
|
||
List.iter
|
||
(fun a ->
|
||
if Atom.marked_both store a then trivial := true;
|
||
Store.clear_var store (Atom.var a))
|
||
!res;
|
||
if !trivial then (
|
||
raise Trivial
|
||
) else if !duplicates = [] then (
|
||
clause
|
||
) else (
|
||
let removable = Clause.removable store clause in
|
||
Clause.make_l store ~removable !res
|
||
)
|
||
|
||
(* TODO: do it in place in a vec? *)
|
||
(* Partition literals for new clauses, into:
|
||
- true literals (maybe makes the clause trivial if the lit is proved true at level 0)
|
||
- unassigned literals, yet to be decided
|
||
- false literals (not suitable to watch, those at level 0 can be removed from the clause)
|
||
|
||
Clauses that propagated false lits are remembered to reconstruct resolution proofs.
|
||
*)
|
||
let partition store atoms : atom list * clause list =
|
||
let rec partition_aux trues unassigned falses history i =
|
||
if i >= Array.length atoms then (
|
||
trues @ unassigned @ falses, history
|
||
) else (
|
||
let a = atoms.(i) in
|
||
if Atom.is_true store a then (
|
||
let l = Atom.level store a in
|
||
if l = 0 then
|
||
raise_notrace Trivial (* Atom var true at level 0 gives a trivially true clause *)
|
||
else
|
||
(a :: trues) @ unassigned @ falses @
|
||
(arr_to_list atoms (i + 1)), history
|
||
) else if Atom.is_false store a then (
|
||
let l = Atom.level store a in
|
||
if l = 0 then (
|
||
match Atom.reason store a with
|
||
| Some (Bcp cl | Bcp_lazy (lazy cl)) ->
|
||
partition_aux trues unassigned falses (cl :: history) (i + 1)
|
||
(* Atom var false at level 0 can be eliminated from the clause,
|
||
but we need to kepp in mind that we used another clause to simplify it. *)
|
||
(* TODO: get a proof of the propagation. *)
|
||
| None | Some Decision -> assert false
|
||
(* The var must have a reason, and it cannot be a decision/assumption,
|
||
since its level is 0. *)
|
||
) else (
|
||
partition_aux trues unassigned (a::falses) history (i + 1)
|
||
)
|
||
) else (
|
||
partition_aux trues (a::unassigned) falses history (i + 1)
|
||
)
|
||
)
|
||
in
|
||
partition_aux [] [] [] [] 0
|
||
|
||
|
||
(* Making a decision.
|
||
Before actually creatig a new decision level, we check that
|
||
all propagations have been done and propagated to the theory,
|
||
i.e that the theoriy state indeed takes into account the whole
|
||
stack of literals
|
||
i.e we have indeed reached a propagation fixpoint before making
|
||
a new decision *)
|
||
let new_decision_level st =
|
||
assert (st.th_head = Vec.size st.trail);
|
||
assert (st.elt_head = Vec.size st.trail);
|
||
Vec.push st.var_levels (Vec.size st.trail);
|
||
Plugin.push_level st.th;
|
||
()
|
||
|
||
(* Attach/Detach a clause.
|
||
|
||
Atom clause is attached (to its watching lits) when it is first added,
|
||
either because it is assumed or learnt.
|
||
|
||
*)
|
||
let attach_clause (self:t) c =
|
||
let store = self.store in
|
||
assert (not @@ Clause.attached store c);
|
||
Log.debugf 20 (fun k -> k "(@[sat.attach-clause@ %a@])" (Clause.debug store) c);
|
||
(* TODO: change when watchlist are updated *)
|
||
Vec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(0))) c;
|
||
Vec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(1))) c;
|
||
Clause.set_attached store c true;
|
||
()
|
||
|
||
(* Backtracking.
|
||
Used to backtrack, i.e cancel down to [lvl] excluded,
|
||
i.e we want to go back to the state the solver was in
|
||
when decision level [lvl] was created. *)
|
||
let cancel_until (self:t) lvl =
|
||
let store = self.store in
|
||
assert (lvl >= 0);
|
||
(* Nothing to do if we try to backtrack to a non-existent level. *)
|
||
if decision_level self <= lvl then (
|
||
Log.debugf 20 (fun k -> k "(@[sat.cancel-until.nop@ :already-at-level <= %d@])" lvl)
|
||
) else (
|
||
Log.debugf 5 (fun k -> k "(@[sat.cancel-until %d@])" lvl);
|
||
(* We set the head of the solver and theory queue to what it was. *)
|
||
let head = ref (Vec.get self.var_levels lvl) in
|
||
self.elt_head <- !head;
|
||
self.th_head <- !head;
|
||
(* Now we need to cleanup the vars that are not valid anymore
|
||
(i.e to the right of elt_head in the queue. *)
|
||
for c = self.elt_head to Vec.size self.trail - 1 do
|
||
let a = Vec.get self.trail c in
|
||
(* Atom literal is unassigned, we nedd to add it back to
|
||
the heap of potentially assignable literals, unless it has
|
||
a level lower than [lvl], in which case we just move it back. *)
|
||
(* Atom variable is not true/false anymore, one of two things can happen: *)
|
||
if Atom.level store a <= lvl then (
|
||
(* It is a late propagation, which has a level
|
||
lower than where we backtrack, so we just move it to the head
|
||
of the queue, to be propagated again. *)
|
||
Vec.set self.trail !head a;
|
||
head := !head + 1
|
||
) else (
|
||
(* it is a result of bolean propagation, or a semantic propagation
|
||
with a level higher than the level to which we backtrack,
|
||
in that case, we simply unset its value and reinsert it into the heap. *)
|
||
Atom.set_is_true store a false;
|
||
Atom.set_is_true store (Atom.neg a) false;
|
||
Var.set_level store (Atom.var a) (-1);
|
||
Var.set_reason store (Atom.var a) None;
|
||
insert_var_order self (Atom.var a)
|
||
)
|
||
done;
|
||
(* Recover the right theory state. *)
|
||
let n = decision_level self - lvl in
|
||
assert (n>0);
|
||
(* Resize the vectors according to their new size. *)
|
||
Vec.shrink self.trail !head;
|
||
Vec.shrink self.var_levels lvl;
|
||
Plugin.pop_levels self.th n;
|
||
self.next_decisions <- [];
|
||
);
|
||
()
|
||
|
||
let pp_unsat_cause self out = function
|
||
| US_local {first=_; core} ->
|
||
Format.fprintf out "(@[unsat-cause@ :false-assumptions %a@])"
|
||
(Format.pp_print_list (Atom.pp self.store)) core
|
||
| US_false c ->
|
||
Format.fprintf out "(@[unsat-cause@ :false %a@])" (Clause.debug self.store) c
|
||
|
||
(* Unsatisfiability is signaled through an exception, since it can happen
|
||
in multiple places (adding new clauses, or solving for instance). *)
|
||
let report_unsat self (us:unsat_cause) : _ =
|
||
Log.debugf 3 (fun k -> k "(@[sat.unsat-conflict@ %a@])" (pp_unsat_cause self) us);
|
||
let us = match us with
|
||
| US_false c ->
|
||
self.unsat_at_0 <- Some c;
|
||
(match self.on_learnt with Some f -> f self (Clause.atoms_a self.store c) | None -> ());
|
||
US_false c
|
||
| _ -> us
|
||
in
|
||
raise (E_unsat us)
|
||
|
||
(* TODO: remove when we use DRUP *)
|
||
(* Simplification of boolean propagation reasons.
|
||
When doing boolean propagation *at level 0*, it can happen
|
||
that the clause cl, which propagates a formula, also contains
|
||
other formulas, but has been simplified. in which case, we
|
||
need to rebuild a clause with correct history, in order to
|
||
be able to build a correct proof at the end of proof search. *)
|
||
let simpl_reason (self:t) (r:reason) : reason =
|
||
match r with
|
||
| (Bcp cl | Bcp_lazy (lazy cl)) as r ->
|
||
let l, history = partition self.store (Clause.atoms_a self.store cl) in
|
||
begin match l with
|
||
| [_] ->
|
||
if history = [] then (
|
||
(* no simplification has been done, so [cl] is actually a clause with only
|
||
[a], so it is a valid reason for propagating [a]. *)
|
||
r
|
||
) else (
|
||
(* Clauses in [history] have been used to simplify [cl] into a clause [tmp_cl]
|
||
with only one formula (which is [a]). So we explicitly create that clause
|
||
and set it as the cause for the propagation of [a], that way we can
|
||
rebuild the whole resolution tree when we want to prove [a]. *)
|
||
let removable = Clause.removable self.store cl in
|
||
let c' = Clause.make_l self.store ~removable l in
|
||
Log.debugf 3
|
||
(fun k -> k "(@[<hv>sat.simplified-reason@ %a@ %a@])"
|
||
(Clause.debug self.store) cl (Clause.debug self.store) c');
|
||
Bcp c'
|
||
)
|
||
| _ ->
|
||
Log.debugf 0
|
||
(fun k ->
|
||
k "(@[<v2>sat.simplify-reason.failed@ :at %a@ %a@]"
|
||
(Vec.pp ~sep:"" (Atom.debug self.store)) (Vec.of_list l)
|
||
(Clause.debug self.store) cl);
|
||
assert false
|
||
end
|
||
| Decision as r -> r
|
||
|
||
(* Boolean propagation.
|
||
Wrapper function for adding a new propagated formula. *)
|
||
let enqueue_bool (self:t) a ~level:lvl reason : unit =
|
||
let store = self.store in
|
||
if Atom.is_false store a then (
|
||
Log.debugf 0
|
||
(fun k->k "(@[sat.error.trying to enqueue a false literal %a@])" (Atom.debug store) a);
|
||
assert false
|
||
);
|
||
assert (not (Atom.is_true store a) &&
|
||
Atom.level store a < 0 &&
|
||
Atom.reason store a == None && lvl >= 0);
|
||
let reason =
|
||
if lvl > 0 then reason
|
||
else simpl_reason self reason
|
||
in
|
||
Atom.set_is_true store a true;
|
||
Var.set_level store (Atom.var a) lvl;
|
||
Var.set_reason store (Atom.var a) (Some reason);
|
||
Vec.push self.trail a;
|
||
Log.debugf 20
|
||
(fun k->k "(@[sat.enqueue[%d]@ %a@])"
|
||
(Vec.size self.trail) (Atom.debug store) a);
|
||
()
|
||
|
||
(* swap elements of array *)
|
||
let[@inline] swap_arr a i j =
|
||
if i<>j then (
|
||
let tmp = a.(i) in
|
||
a.(i) <- a.(j);
|
||
a.(j) <- tmp;
|
||
)
|
||
|
||
(* move atoms assigned at high levels first *)
|
||
let put_high_level_atoms_first (store:store) (arr:atom array) : unit =
|
||
Array.iteri
|
||
(fun i a ->
|
||
if i>0 && Atom.level store a > Atom.level store arr.(0) then (
|
||
(* move first to second, [i]-th to first, second to [i] *)
|
||
if i=1 then (
|
||
swap_arr arr 0 1;
|
||
) else (
|
||
let tmp = arr.(1) in
|
||
arr.(1) <- arr.(0);
|
||
arr.(0) <- arr.(i);
|
||
arr.(i) <- tmp;
|
||
);
|
||
) else if i>1 &&
|
||
Atom.level store a > Atom.level store arr.(1)
|
||
then (
|
||
swap_arr arr 1 i;
|
||
))
|
||
arr
|
||
|
||
(* find which level to backtrack to, given a conflict clause
|
||
and a boolean stating whether it is
|
||
a UIP ("Unique Implication Point")
|
||
precond: the atom list is sorted by decreasing decision level *)
|
||
let backtrack_lvl (self:t) (arr: atom array) : int * bool =
|
||
let store = self.store in
|
||
if Array.length arr <= 1 then (
|
||
0, true
|
||
) else (
|
||
let a = arr.(0) in
|
||
let b = arr.(1) in
|
||
assert (Atom.level store a > 0);
|
||
if Atom.level store a > Atom.level store b then (
|
||
(* backtrack below [a], so we can propagate [not a] *)
|
||
Atom.level store b, true
|
||
) else (
|
||
assert (Atom.level store a = Atom.level store b);
|
||
assert (Atom.level store a >= 0);
|
||
max (Atom.level store a - 1) 0, false
|
||
)
|
||
)
|
||
|
||
(* result of conflict analysis, containing the learnt clause and some
|
||
additional info.
|
||
|
||
invariant: cr_history's order matters, as its head is later used
|
||
during pop operations to determine the origin of a clause/conflict
|
||
(boolean conflict i.e hypothesis, or theory lemma) *)
|
||
type conflict_res = {
|
||
cr_backtrack_lvl : int; (* level to backtrack to *)
|
||
cr_learnt: atom array; (* lemma learnt from conflict *)
|
||
cr_history: clause array; (* justification *)
|
||
cr_is_uip: bool; (* conflict is UIP? *)
|
||
}
|
||
|
||
(* conflict analysis, starting with top of trail and conflict clause *)
|
||
let analyze (self:t) c_clause : conflict_res =
|
||
let store = self.store in
|
||
|
||
let to_unmark = self.to_clear in (* for cleanup *)
|
||
Vec.clear to_unmark;
|
||
let learnt = self.temp_atom_vec in
|
||
Vec.clear learnt;
|
||
let history = self.temp_clause_vec in
|
||
Vec.clear history;
|
||
|
||
(* loop variables *)
|
||
let pathC = ref 0 in
|
||
let continue = ref true in
|
||
let blevel = ref 0 in
|
||
let c = ref (Some c_clause) in (* current clause to analyze/resolve *)
|
||
let tr_ind = ref (Vec.size self.trail - 1) in (* pointer in trail *)
|
||
|
||
(* conflict level *)
|
||
assert (decision_level self > 0);
|
||
let conflict_level =
|
||
if Plugin.has_theory then (
|
||
Clause.fold store 0 c_clause
|
||
~f:(fun acc p -> max acc (Atom.level store p))
|
||
) else (
|
||
decision_level self
|
||
)
|
||
in
|
||
Log.debugf 30
|
||
(fun k -> k "(@[sat.analyze-conflict@ :c-level %d@ :clause %a@])"
|
||
conflict_level (Clause.debug store) c_clause);
|
||
|
||
while !continue do
|
||
begin match !c with
|
||
| None ->
|
||
Log.debug 30
|
||
"(@[sat.analyze-conflict: skipping resolution for semantic propagation@])"
|
||
| Some clause ->
|
||
Log.debugf 30
|
||
(fun k->k"(@[sat.analyze-conflict.resolve@ %a@])" (Clause.debug store) clause);
|
||
if Clause.removable store clause then (
|
||
clause_bump_activity self clause;
|
||
);
|
||
Vec.push history clause;
|
||
(* visit the current predecessors *)
|
||
let atoms = Clause.atoms_a store clause in
|
||
for j = 0 to Array.length atoms - 1 do
|
||
let q = atoms.(j) in
|
||
assert (Atom.is_true store q ||
|
||
Atom.is_false store q &&
|
||
Atom.level store q >= 0); (* unsure? *)
|
||
if Atom.level store q <= 0 then (
|
||
assert (Atom.is_false store q);
|
||
match Atom.reason store q with
|
||
| Some (Bcp cl | Bcp_lazy (lazy cl)) ->
|
||
Vec.push history cl
|
||
| Some Decision | None -> assert false
|
||
);
|
||
if not (Var.marked store (Atom.var q)) then (
|
||
Var.mark store (Atom.var q);
|
||
Vec.push to_unmark (Atom.var q);
|
||
if Atom.level store q > 0 then (
|
||
var_bump_activity self (Atom.var q);
|
||
if Atom.level store q >= conflict_level then (
|
||
incr pathC;
|
||
) else (
|
||
Vec.push learnt q;
|
||
blevel := max !blevel (Atom.level store q)
|
||
)
|
||
)
|
||
)
|
||
done
|
||
end;
|
||
|
||
(* look for the next node to expand *)
|
||
while
|
||
let a = Vec.get self.trail !tr_ind in
|
||
Log.debugf 30
|
||
(fun k -> k "(@[sat.analyze-conflict.at-trail-elt@ %a@])" (Atom.debug store) a);
|
||
(not (Var.marked store (Atom.var a))) ||
|
||
(Atom.level store a < conflict_level)
|
||
do
|
||
decr tr_ind;
|
||
done;
|
||
let p = Vec.get self.trail !tr_ind in
|
||
decr pathC;
|
||
decr tr_ind;
|
||
match !pathC, Atom.reason store p with
|
||
| 0, _ ->
|
||
continue := false;
|
||
Vec.push learnt (Atom.neg p)
|
||
| n, Some (Bcp cl | Bcp_lazy (lazy cl)) ->
|
||
assert (n > 0);
|
||
assert (Atom.level store p >= conflict_level);
|
||
c := Some cl
|
||
| _, (None | Some Decision) -> assert false
|
||
done;
|
||
|
||
Vec.iter (Store.clear_var store) to_unmark;
|
||
Vec.clear to_unmark;
|
||
|
||
(* put high-level literals first, so that:
|
||
- they make adequate watch lits
|
||
- the first literal is the UIP, if any *)
|
||
let cr_learnt = Vec.to_array learnt in
|
||
Vec.clear learnt;
|
||
Array.sort (fun p q -> compare (Atom.level store q) (Atom.level store p)) cr_learnt;
|
||
|
||
let cr_history = Vec.to_array history in
|
||
Vec.clear history;
|
||
|
||
(* put_high_level_atoms_first a; *)
|
||
let level, is_uip = backtrack_lvl self cr_learnt in
|
||
{ cr_backtrack_lvl = level;
|
||
cr_learnt;
|
||
cr_history;
|
||
cr_is_uip = is_uip;
|
||
}
|
||
|
||
(* add the learnt clause to the clause database, propagate, etc. *)
|
||
let record_learnt_clause (self:t) (confl:clause) (cr:conflict_res): unit =
|
||
let store = self.store in
|
||
begin match cr.cr_learnt with
|
||
| [| |] -> assert false
|
||
| [|fuip|] ->
|
||
assert (cr.cr_backtrack_lvl = 0 && decision_level self = 0);
|
||
if Atom.is_false store fuip then (
|
||
(* incompatible at level 0 *)
|
||
report_unsat self (US_false confl)
|
||
) else (
|
||
let uclause =
|
||
Clause.make_a store ~removable:true cr.cr_learnt in
|
||
(match self.on_learnt with Some f -> f self cr.cr_learnt | None -> ());
|
||
(* no need to attach [uclause], it is true at level 0 *)
|
||
enqueue_bool self fuip ~level:0 (Bcp uclause)
|
||
)
|
||
| _ ->
|
||
let fuip = cr.cr_learnt.(0) in
|
||
let lclause = Clause.make_a store ~removable:true cr.cr_learnt in
|
||
if Clause.n_atoms store lclause > 2 then (
|
||
Vec.push self.clauses_learnt lclause; (* potentially gc'able *)
|
||
);
|
||
attach_clause self lclause;
|
||
clause_bump_activity self lclause;
|
||
(match self.on_learnt with Some f -> f self cr.cr_learnt | None -> ());
|
||
assert (cr.cr_is_uip);
|
||
enqueue_bool self fuip ~level:cr.cr_backtrack_lvl (Bcp lclause)
|
||
end;
|
||
var_decay_activity self;
|
||
clause_decay_activity self
|
||
|
||
(* process a conflict:
|
||
- learn clause
|
||
- backtrack
|
||
- report unsat if conflict at level 0
|
||
*)
|
||
let add_boolean_conflict (self:t) (confl:clause): unit =
|
||
let store = self.store in
|
||
Log.debugf 5 (fun k -> k "(@[sat.add-bool-conflict@ %a@])" (Clause.debug store) confl);
|
||
self.next_decisions <- [];
|
||
assert (decision_level self >= 0);
|
||
if decision_level self = 0 ||
|
||
Clause.for_all store confl ~f:(fun a -> Atom.level store a <= 0) then (
|
||
(* Top-level conflict *)
|
||
report_unsat self (US_false confl);
|
||
);
|
||
let cr = analyze self confl in
|
||
cancel_until self (max cr.cr_backtrack_lvl 0);
|
||
record_learnt_clause self confl cr
|
||
|
||
(* Get the correct vector to insert a clause in. *)
|
||
let[@inline] add_clause_to_vec self c =
|
||
if Clause.removable self.store c then (
|
||
Vec.push self.clauses_learnt c
|
||
) else (
|
||
Vec.push self.clauses_hyps c
|
||
)
|
||
|
||
(* Add a new clause, simplifying, propagating, and backtracking if
|
||
the clause is false in the current trail *)
|
||
let add_clause_ (self:t) (init:clause) : unit =
|
||
let store = self.store in
|
||
Log.debugf 30 (fun k -> k "(@[sat.add-clause@ @[<hov>%a@]@])" (Clause.debug store) init);
|
||
(* Insertion of new lits is done before simplification. Indeed, else a lit in a
|
||
trivial clause could end up being not decided on, which is a bug. *)
|
||
Clause.iter store init ~f:(fun x -> insert_var_order self (Atom.var x));
|
||
try
|
||
let c = eliminate_duplicates store init in
|
||
Log.debugf 30 (fun k -> k "(@[sat.dups-removed@ %a@])" (Clause.debug store) c);
|
||
let atoms, history = partition store (Clause.atoms_a store c) in
|
||
let clause =
|
||
if history = [] then (
|
||
(* just update order of atoms *)
|
||
let c_atoms = Clause.atoms_a store c in
|
||
List.iteri (fun i a -> c_atoms.(i) <- a) atoms;
|
||
c
|
||
) else (
|
||
let removable = Clause.removable store c in
|
||
Clause.make_l store ~removable atoms
|
||
)
|
||
in
|
||
assert (Clause.removable store clause = Clause.removable store init);
|
||
Log.debugf 5 (fun k->k "(@[sat.new-clause@ @[<hov>%a@]@])" (Clause.debug store) clause);
|
||
match atoms with
|
||
| [] ->
|
||
report_unsat self @@ US_false clause
|
||
| [a] ->
|
||
cancel_until self 0;
|
||
if Atom.is_false store a then (
|
||
(* cannot recover from this *)
|
||
report_unsat self @@ US_false clause
|
||
) else if Atom.is_true store a then (
|
||
() (* atom is already true, nothing to do *)
|
||
) else (
|
||
Log.debugf 40
|
||
(fun k->k "(@[sat.add-clause.unit-clause@ :propagating %a@])" (Atom.debug store) a);
|
||
add_clause_to_vec self clause;
|
||
enqueue_bool self a ~level:0 (Bcp clause)
|
||
)
|
||
| a::b::_ ->
|
||
add_clause_to_vec self clause;
|
||
if Atom.is_false store a then (
|
||
(* Atom need to be sorted in decreasing order of decision level,
|
||
or we might watch the wrong literals. *)
|
||
put_high_level_atoms_first store (Clause.atoms_a store clause);
|
||
attach_clause self clause;
|
||
add_boolean_conflict self clause
|
||
) else (
|
||
attach_clause self clause;
|
||
if Atom.is_false store b &&
|
||
not (Atom.is_true store a) &&
|
||
not (Atom.is_false store a) then (
|
||
let lvl = List.fold_left (fun m a -> max m (Atom.level store a)) 0 atoms in
|
||
cancel_until self lvl;
|
||
enqueue_bool self a ~level:lvl (Bcp clause)
|
||
)
|
||
)
|
||
with Trivial ->
|
||
Log.debugf 5
|
||
(fun k->k "(@[sat.add-clause@ :ignore-trivial @[%a@]@])" (Clause.debug store) init)
|
||
|
||
let[@inline never] flush_clauses_ st =
|
||
while not @@ Vec.is_empty st.clauses_to_add do
|
||
let c = Vec.pop_exn st.clauses_to_add in
|
||
add_clause_ st c
|
||
done
|
||
|
||
let[@inline] flush_clauses st =
|
||
if not @@ Vec.is_empty st.clauses_to_add then flush_clauses_ st
|
||
|
||
type watch_res =
|
||
| Watch_kept
|
||
| Watch_removed
|
||
|
||
(* boolean propagation.
|
||
[a] is the false atom, one of [c]'s two watch literals
|
||
[i] is the index of [c] in [a.watched]
|
||
@return whether [c] was removed from [a.watched]
|
||
*)
|
||
let propagate_in_clause (self:t) (a:atom) (c:clause) (i:int): watch_res =
|
||
let store = self.store in
|
||
let atoms = Clause.atoms_a store c in
|
||
let first = atoms.(0) in
|
||
if first = Atom.neg a then (
|
||
(* false lit must be at index 1 *)
|
||
atoms.(0) <- atoms.(1);
|
||
atoms.(1) <- first
|
||
) else (
|
||
assert (Atom.neg a = atoms.(1))
|
||
);
|
||
let first = atoms.(0) in
|
||
if Atom.is_true store first then (
|
||
Watch_kept (* true clause, keep it in watched *)
|
||
) else (
|
||
try (* look for another watch lit *)
|
||
for k = 2 to Array.length atoms - 1 do
|
||
let ak = atoms.(k) in
|
||
if not (Atom.is_false store ak) then (
|
||
(* watch lit found: update and exit *)
|
||
atoms.(1) <- ak;
|
||
atoms.(k) <- Atom.neg a;
|
||
(* remove [c] from [a.watched], add it to [ak.neg.watched] *)
|
||
Vec.push (Atom.watched store (Atom.neg ak)) c;
|
||
assert (Vec.get (Atom.watched store a) i == c);
|
||
Vec.fast_remove (Atom.watched store a) i;
|
||
raise_notrace Exit
|
||
)
|
||
done;
|
||
(* no watch lit found *)
|
||
if Atom.is_false store first then (
|
||
(* clause is false *)
|
||
self.elt_head <- Vec.size self.trail;
|
||
raise_notrace (Conflict c)
|
||
) else (
|
||
self.n_propagations <- 1 + self.n_propagations;
|
||
enqueue_bool self first ~level:(decision_level self) (Bcp c)
|
||
);
|
||
Watch_kept
|
||
with Exit ->
|
||
Watch_removed
|
||
)
|
||
|
||
(* propagate atom [a], which was just decided. This checks every
|
||
clause watching [a] to see if the clause is false, unit, or has
|
||
other possible watches
|
||
@param res the optional conflict clause that the propagation might trigger *)
|
||
let propagate_atom (self:t) a : unit =
|
||
let store = self.store in
|
||
let watched = Atom.watched store a in
|
||
let rec aux i =
|
||
if i >= Vec.size watched then ()
|
||
else (
|
||
let c = Vec.get watched i in
|
||
assert (Clause.attached store c);
|
||
assert (not (Clause.dead store c));
|
||
let j =
|
||
match propagate_in_clause self a c i with
|
||
| Watch_kept -> i+1
|
||
| Watch_removed -> i (* clause at this index changed *)
|
||
in
|
||
aux j
|
||
)
|
||
in
|
||
aux 0
|
||
|
||
exception Th_conflict of Clause.t
|
||
|
||
let[@inline] slice_get st i = Vec.get st.trail i
|
||
|
||
let acts_add_clause self ?(keep=false) (l:formula list) (dp:dproof): unit =
|
||
let atoms = List.rev_map (make_atom self) l in
|
||
let removable = not keep in
|
||
let c = Clause.make_l self.store ~removable atoms in
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
Log.debugf 5 (fun k->k "(@[sat.th.add-clause@ %a@])" (Clause.debug self.store) c);
|
||
Vec.push self.clauses_to_add c
|
||
|
||
let acts_add_decision_lit (self:t) (f:formula) (sign:bool) : unit =
|
||
let store = self.store in
|
||
let a = make_atom self f in
|
||
let a = if sign then a else Atom.neg a in
|
||
if not (Atom.has_value store a) then (
|
||
Log.debugf 10 (fun k->k "(@[sat.th.add-decision-lit@ %a@])" (Atom.debug store) a);
|
||
self.next_decisions <- a :: self.next_decisions
|
||
)
|
||
|
||
let acts_raise self (l:formula list) (pr:dproof) : 'a =
|
||
let atoms = List.rev_map (make_atom self) l in
|
||
(* conflicts can be removed *)
|
||
let c = Clause.make_l self.store ~removable:true atoms in
|
||
if Proof.enabled self.proof then pr self.proof;
|
||
Log.debugf 5 (fun k->k "(@[@{<yellow>sat.th.raise-conflict@}@ %a@])"
|
||
(Clause.debug self.store) c);
|
||
raise_notrace (Th_conflict c)
|
||
|
||
let check_consequence_lits_false_ self l : unit =
|
||
let store = self.store in
|
||
match List.find (Atom.is_true store) l with
|
||
| a ->
|
||
invalid_argf
|
||
"slice.acts_propagate:@ Consequence should contain only true literals, but %a isn't"
|
||
(Atom.debug store) (Atom.neg a)
|
||
| exception Not_found -> ()
|
||
|
||
let acts_propagate (self:t) f expl =
|
||
let store = self.store in
|
||
match expl with
|
||
| Solver_intf.Consequence mk_expl ->
|
||
let p = make_atom self f in
|
||
if Atom.is_true store p then ()
|
||
else if Atom.is_false store p then (
|
||
let lits, dp = mk_expl() in
|
||
let l = List.rev_map (fun f -> Atom.neg @@ make_atom self f) lits in
|
||
check_consequence_lits_false_ self l;
|
||
let c = Clause.make_l store ~removable:true (p :: l) in
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
raise_notrace (Th_conflict c)
|
||
) else (
|
||
insert_var_order self (Atom.var p);
|
||
let c = lazy (
|
||
let lits, dp = mk_expl () in
|
||
let l = List.rev_map (fun f -> Atom.neg @@ make_atom self f) lits in
|
||
(* note: we can check that invariant here in the [lazy] block,
|
||
as conflict analysis will run in an environment where
|
||
the literals should be true anyway, since it's an extension of the
|
||
current trail
|
||
(otherwise the propagated lit would have been backtracked and
|
||
discarded already.) *)
|
||
check_consequence_lits_false_ self l;
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
Clause.make_l store ~removable:true (p :: l)
|
||
) in
|
||
let level = decision_level self in
|
||
self.n_propagations <- 1 + self.n_propagations;
|
||
enqueue_bool self p ~level (Bcp_lazy c)
|
||
)
|
||
|
||
let[@specialise] acts_iter self ~full head f : unit =
|
||
for i = (if full then 0 else head) to Vec.size self.trail-1 do
|
||
let a = Vec.get self.trail i in
|
||
f (Atom.lit self.store a);
|
||
done
|
||
|
||
let eval_atom_ self a =
|
||
if Atom.is_true self.store a then Solver_intf.L_true
|
||
else if Atom.is_false self.store a then Solver_intf.L_false
|
||
else Solver_intf.L_undefined
|
||
|
||
let[@inline] acts_eval_lit self (f:formula) : Solver_intf.lbool =
|
||
let a = make_atom self f in
|
||
eval_atom_ self a
|
||
|
||
let[@inline] acts_mk_lit self ?default_pol f : unit =
|
||
ignore (make_atom ?default_pol self f : atom)
|
||
|
||
let[@inline] current_slice st : _ Solver_intf.acts =
|
||
let module M = struct
|
||
type nonrec proof = proof
|
||
type dproof = proof -> unit
|
||
type nonrec formula = formula
|
||
let iter_assumptions=acts_iter st ~full:false st.th_head
|
||
let eval_lit= acts_eval_lit st
|
||
let mk_lit=acts_mk_lit st
|
||
let add_clause = acts_add_clause st
|
||
let propagate = acts_propagate st
|
||
let raise_conflict c pr=acts_raise st c pr
|
||
let add_decision_lit=acts_add_decision_lit st
|
||
end in
|
||
(module M)
|
||
|
||
(* full slice, for [if_sat] final check *)
|
||
let[@inline] full_slice st : _ Solver_intf.acts =
|
||
let module M = struct
|
||
type nonrec proof = proof
|
||
type dproof = proof -> unit
|
||
type nonrec formula = formula
|
||
let iter_assumptions=acts_iter st ~full:true st.th_head
|
||
let eval_lit= acts_eval_lit st
|
||
let mk_lit=acts_mk_lit st
|
||
let add_clause = acts_add_clause st
|
||
let propagate = acts_propagate st
|
||
let raise_conflict c pr=acts_raise st c pr
|
||
let add_decision_lit=acts_add_decision_lit st
|
||
end in
|
||
(module M)
|
||
|
||
(* Assert that the conflict is indeeed a conflict *)
|
||
let check_is_conflict_ self (c:Clause.t) : unit =
|
||
if not @@ Clause.for_all self.store c ~f:(Atom.is_false self.store) then (
|
||
Log.debugf 0 (fun k->k"conflict should be false: %a" (Clause.debug self.store) c);
|
||
assert false
|
||
)
|
||
|
||
(* some boolean literals were decided/propagated within Msat. Now we
|
||
need to inform the theory of those assumptions, so it can do its job.
|
||
@return the conflict clause, if the theory detects unsatisfiability *)
|
||
let rec theory_propagate self : clause option =
|
||
assert (self.elt_head = Vec.size self.trail);
|
||
assert (self.th_head <= self.elt_head);
|
||
if self.th_head = self.elt_head then (
|
||
None (* fixpoint/no propagation *)
|
||
) else (
|
||
let slice = current_slice self in
|
||
self.th_head <- self.elt_head; (* catch up *)
|
||
match Plugin.partial_check self.th slice with
|
||
| () ->
|
||
flush_clauses self;
|
||
propagate self
|
||
| exception Th_conflict c ->
|
||
check_is_conflict_ self c;
|
||
Clause.iter self.store c ~f:(fun a -> insert_var_order self (Atom.var a));
|
||
Some c
|
||
)
|
||
|
||
(* fixpoint between boolean propagation and theory propagation
|
||
@return a conflict clause, if any *)
|
||
and propagate (st:t) : clause option =
|
||
(* First, treat the stack of lemmas added by the theory, if any *)
|
||
flush_clauses st;
|
||
(* Now, check that the situation is sane *)
|
||
assert (st.elt_head <= Vec.size st.trail);
|
||
if st.elt_head = Vec.size st.trail then (
|
||
theory_propagate st
|
||
) else (
|
||
match
|
||
while st.elt_head < Vec.size st.trail do
|
||
let a = Vec.get st.trail st.elt_head in
|
||
propagate_atom st a;
|
||
st.elt_head <- st.elt_head + 1;
|
||
done;
|
||
with
|
||
| () -> theory_propagate st
|
||
| exception Conflict c -> Some c
|
||
)
|
||
|
||
(* compute unsat core from assumption [a] *)
|
||
let analyze_final (self:t) (a:atom) : atom list =
|
||
let store = self.store in
|
||
Log.debugf 5 (fun k->k "(@[sat.analyze-final@ :lit %a@])" (Atom.debug store) a);
|
||
assert (Atom.is_false store a);
|
||
let core = ref [a] in
|
||
let idx = ref (Vec.size self.trail - 1) in
|
||
Var.mark store (Atom.var a);
|
||
let seen = ref [Atom.var a] in
|
||
while !idx >= 0 do
|
||
let a' = Vec.get self.trail !idx in
|
||
if Var.marked store (Atom.var a') then (
|
||
match Atom.reason store a' with
|
||
| Some Decision -> core := a' :: !core
|
||
| Some (Bcp c | Bcp_lazy (lazy c)) ->
|
||
Clause.iter store c
|
||
~f:(fun a ->
|
||
let v = Atom.var a in
|
||
if not (Var.marked store v) then (
|
||
seen := v :: !seen;
|
||
Var.mark store v;
|
||
))
|
||
| None -> ()
|
||
);
|
||
decr idx
|
||
done;
|
||
List.iter (Var.unmark store) !seen;
|
||
Log.debugf 5 (fun k->k "(@[sat.analyze-final.done@ :core %a@])"
|
||
(Format.pp_print_list (Atom.debug store)) !core);
|
||
!core
|
||
|
||
(* GC: remove some learnt clauses.
|
||
This works even during the proof with a non empty trail. *)
|
||
let reduce_clause_db (self:t) (n_of_learnts: int) : unit =
|
||
let store = self.store in
|
||
|
||
Log.debugf 3 (fun k->k "(@[sat.gc.start :keep %d :out-of %d@])"
|
||
n_of_learnts (Vec.size self.clauses_learnt));
|
||
assert (Vec.size self.clauses_learnt > n_of_learnts);
|
||
|
||
(* sort by decreasing activity *)
|
||
Vec.sort self.clauses_learnt
|
||
(fun c1 c2 -> compare (Clause.activity store c2) (Clause.activity store c1));
|
||
|
||
let dirty_atoms = self.temp_atom_vec in
|
||
let to_be_gc = self.temp_clause_vec in (* clauses to collect *)
|
||
let to_be_pushed_back = Vec.create() in (* clauses we need to keep *)
|
||
assert (Vec.is_empty dirty_atoms);
|
||
assert (Vec.is_empty to_be_gc);
|
||
|
||
(* [a] is watching at least one removed clause, we'll need to
|
||
trim its watchlist *)
|
||
let mark_dirty_atom a =
|
||
if not (Atom.marked store a) then (
|
||
Atom.mark store a;
|
||
Vec.push dirty_atoms a;
|
||
)
|
||
in
|
||
|
||
(* first, mark clauses used on the trail, we cannot GC them.
|
||
TODO: once we use DRUP, we can avoid marking level-0 explanations
|
||
as they will never participate in resolution. *)
|
||
Vec.iter
|
||
(fun a ->
|
||
match Atom.reason store a with
|
||
| Some (Bcp c) -> Clause.set_marked store c true
|
||
| Some (Bcp_lazy lc) when Lazy.is_val lc ->
|
||
Clause.set_marked store (Lazy.force lc) true
|
||
| _ -> ())
|
||
self.trail;
|
||
|
||
(* GC the clause [c] *)
|
||
let flag_clause_for_gc c =
|
||
assert (Clause.removable store c);
|
||
Vec.push to_be_gc c;
|
||
Clause.set_dead store c true;
|
||
let atoms = Clause.atoms_a store c in
|
||
mark_dirty_atom (Atom.neg atoms.(0)); (* need to remove from watchlists *)
|
||
mark_dirty_atom (Atom.neg atoms.(1));
|
||
(match self.on_gc with Some f -> f self atoms | None -> ());
|
||
in
|
||
|
||
(* find clauses to GC *)
|
||
while Vec.size self.clauses_learnt > n_of_learnts do
|
||
let c = Vec.pop_exn self.clauses_learnt in
|
||
if Clause.marked store c then (
|
||
Vec.push to_be_pushed_back c; (* must keep it, it's on the trail *)
|
||
) else (
|
||
flag_clause_for_gc c;
|
||
Log.debugf 10 (fun k->k"(@[sat.gc.will-collect@ %a@])" (Clause.debug store) c);
|
||
)
|
||
done;
|
||
let n_collected = Vec.size to_be_gc in
|
||
|
||
(* update watchlist of dirty atoms *)
|
||
Vec.iter
|
||
(fun a ->
|
||
assert (Atom.marked store a);
|
||
Atom.unmark store a;
|
||
let w = Atom.watched store a in
|
||
Vec.filter_in_place (fun c -> not (Clause.dead store c)) w)
|
||
dirty_atoms;
|
||
Vec.clear dirty_atoms;
|
||
|
||
(* actually remove the clauses now that they are detached *)
|
||
Vec.iter (Clause.dealloc store) to_be_gc;
|
||
Vec.clear to_be_gc;
|
||
(* restore other clauses *)
|
||
Vec.iter
|
||
(fun c ->
|
||
Clause.set_marked store c false;
|
||
Vec.push self.clauses_learnt c)
|
||
to_be_pushed_back;
|
||
|
||
Log.debugf 3 (fun k->k "(@[sat.gc.done :collected %d@])" n_collected);
|
||
()
|
||
|
||
(* Decide on a new literal, and enqueue it into the trail *)
|
||
let rec pick_branch_aux self atom : unit =
|
||
let v = Atom.var atom in
|
||
if Var.level self.store v >= 0 then (
|
||
assert (Atom.is_true self.store (Atom.pa v) ||
|
||
Atom.is_true self.store (Atom.na v));
|
||
pick_branch_lit self
|
||
) else (
|
||
new_decision_level self;
|
||
let current_level = decision_level self in
|
||
enqueue_bool self atom ~level:current_level Decision;
|
||
self.n_decisions <- 1 + self.n_decisions;
|
||
(match self.on_decision with Some f -> f self atom | None -> ());
|
||
)
|
||
|
||
and pick_branch_lit self : unit =
|
||
match self.next_decisions with
|
||
| atom :: tl ->
|
||
self.next_decisions <- tl;
|
||
pick_branch_aux self atom
|
||
| [] when decision_level self < Vec.size self.assumptions ->
|
||
(* use an assumption *)
|
||
let a = Vec.get self.assumptions (decision_level self) in
|
||
if Atom.is_true self.store a then (
|
||
new_decision_level self; (* pseudo decision level, [a] is already true *)
|
||
pick_branch_lit self
|
||
) else if Atom.is_false self.store a then (
|
||
(* root conflict, find unsat core *)
|
||
let core = analyze_final self a in
|
||
raise (E_unsat (US_local {first=a; core}))
|
||
) else (
|
||
pick_branch_aux self a
|
||
)
|
||
| [] ->
|
||
begin match H.remove_min self.order with
|
||
| v ->
|
||
pick_branch_aux self
|
||
(if Var.default_pol self.store v then Atom.pa v else Atom.na v)
|
||
| exception Not_found -> raise_notrace E_sat
|
||
end
|
||
|
||
(* do some amount of search, until the number of conflicts or clause learnt
|
||
reaches the given parameters *)
|
||
let search (st:t) n_of_conflicts n_of_learnts : unit =
|
||
Log.debugf 3
|
||
(fun k->k "(@[sat.search@ :n-conflicts %d@ :n-learnt %d@])" n_of_conflicts n_of_learnts);
|
||
let conflictC = ref 0 in
|
||
while true do
|
||
match propagate st with
|
||
| Some confl -> (* Conflict *)
|
||
incr conflictC;
|
||
(* When the theory has raised Unsat, add_boolean_conflict
|
||
might 'forget' the initial conflict clause, and only add the
|
||
analyzed backtrack clause. So in those case, we use add_clause
|
||
to make sure the initial conflict clause is also added. *)
|
||
if Clause.attached st.store confl then (
|
||
add_boolean_conflict st confl
|
||
) else (
|
||
add_clause_ st confl
|
||
);
|
||
st.n_conflicts <- 1 + st.n_conflicts;
|
||
(match st.on_conflict with Some f -> f st (Clause.atoms_a st.store confl) | None -> ());
|
||
|
||
| None -> (* No Conflict *)
|
||
assert (st.elt_head = Vec.size st.trail);
|
||
assert (st.elt_head = st.th_head);
|
||
if n_of_conflicts > 0 && !conflictC >= n_of_conflicts then (
|
||
Log.debug 1 "(sat.restarting)";
|
||
cancel_until st 0;
|
||
st.n_restarts <- 1 + st.n_restarts;
|
||
raise_notrace Restart
|
||
);
|
||
(* if decision_level() = 0 then simplify (); *)
|
||
|
||
if n_of_learnts > 0 &&
|
||
Vec.size st.clauses_learnt - Vec.size st.trail > n_of_learnts then (
|
||
reduce_clause_db st n_of_learnts;
|
||
);
|
||
|
||
pick_branch_lit st
|
||
done
|
||
|
||
let eval_level (self:t) (a:atom) =
|
||
let lvl = Atom.level self.store a in
|
||
if Atom.is_true self.store a then (
|
||
assert (lvl >= 0);
|
||
true, lvl
|
||
) else if Atom.is_false self.store a then (
|
||
false, lvl
|
||
) else (
|
||
raise UndecidedLit
|
||
)
|
||
|
||
let[@inline] eval st lit = fst @@ eval_level st lit
|
||
|
||
let[@inline] unsat_conflict st = st.unsat_at_0
|
||
|
||
(* fixpoint of propagation and decisions until a model is found, or a
|
||
conflict is reached *)
|
||
let solve_ (self:t) : unit =
|
||
Log.debugf 5 (fun k->k "(@[sat.solve :assms %d@])" (Vec.size self.assumptions));
|
||
check_unsat_ self;
|
||
try
|
||
flush_clauses self; (* add initial clauses *)
|
||
let n_of_conflicts = ref (float_of_int restart_first) in
|
||
let n_of_learnts = ref ((float_of_int (nb_clauses self)) *. learntsize_factor) in
|
||
while true do
|
||
begin try
|
||
search self (int_of_float !n_of_conflicts) (int_of_float !n_of_learnts)
|
||
with
|
||
| Restart ->
|
||
n_of_conflicts := !n_of_conflicts *. restart_inc;
|
||
n_of_learnts := !n_of_learnts *. learntsize_inc
|
||
| E_sat ->
|
||
assert (self.elt_head = Vec.size self.trail &&
|
||
Vec.is_empty self.clauses_to_add &&
|
||
self.next_decisions=[]);
|
||
begin match Plugin.final_check self.th (full_slice self) with
|
||
| () ->
|
||
if self.elt_head = Vec.size self.trail &&
|
||
Vec.is_empty self.clauses_to_add &&
|
||
self.next_decisions = []
|
||
then (
|
||
raise_notrace E_sat
|
||
);
|
||
(* otherwise, keep on *)
|
||
flush_clauses self;
|
||
| exception Th_conflict c ->
|
||
check_is_conflict_ self c;
|
||
Clause.iter self.store c
|
||
~f:(fun a -> insert_var_order self (Atom.var a));
|
||
Log.debugf 5 (fun k -> k "(@[sat.theory-conflict-clause@ %a@])"
|
||
(Clause.debug self.store) c);
|
||
self.n_conflicts <- 1 + self.n_conflicts;
|
||
(match self.on_conflict with
|
||
Some f -> f self (Clause.atoms_a self.store c) | None -> ());
|
||
Vec.push self.clauses_to_add c;
|
||
flush_clauses self;
|
||
end;
|
||
end
|
||
done
|
||
with E_sat -> ()
|
||
|
||
let assume self cnf dp : unit =
|
||
List.iter
|
||
(fun l ->
|
||
let atoms = List.rev_map (make_atom self) l in
|
||
let c = Clause.make_l self.store ~removable:false atoms in
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
Log.debugf 10 (fun k -> k "(@[sat.assume-clause@ @[<hov 2>%a@]@])"
|
||
(Clause.debug self.store) c);
|
||
Vec.push self.clauses_to_add c)
|
||
cnf
|
||
|
||
(* Check satisfiability *)
|
||
let check_clause self c =
|
||
let res = Clause.exists self.store c ~f:(Atom.is_true self.store) in
|
||
if not res then (
|
||
Log.debugf 30
|
||
(fun k -> k "(@[sat.check-clause@ :not-satisfied @[<hov>%a@]@])"
|
||
(Clause.debug self.store) c);
|
||
false
|
||
) else
|
||
true
|
||
|
||
let check_vec self v = Vec.for_all (check_clause self) v
|
||
let check self : bool =
|
||
Vec.is_empty self.clauses_to_add &&
|
||
check_vec self self.clauses_hyps &&
|
||
check_vec self self.clauses_learnt
|
||
|
||
let[@inline] theory st = st.th
|
||
let[@inline] store st = st.store
|
||
|
||
(* Result type *)
|
||
type res =
|
||
| Sat of Formula.t Solver_intf.sat_state
|
||
| Unsat of (atom,clause) Solver_intf.unsat_state
|
||
|
||
let pp_all self lvl status =
|
||
Log.debugf lvl
|
||
(fun k -> k
|
||
"(@[<v>sat.full-state :res %s - Full summary:@,@[<hov 2>Trail:@\n%a@]@,\
|
||
@[<hov 2>Hyps:@\n%a@]@,@[<hov 2>Lemmas:@\n%a@]@,@]@."
|
||
status
|
||
(Vec.pp ~sep:"" @@ Atom.debug self.store) self.trail
|
||
(Vec.pp ~sep:"" @@ Clause.debug self.store) self.clauses_hyps
|
||
(Vec.pp ~sep:"" @@ Clause.debug self.store) self.clauses_learnt)
|
||
|
||
let mk_sat (self:t) : Formula.t Solver_intf.sat_state =
|
||
pp_all self 99 "SAT";
|
||
let t = self.trail in
|
||
let module M = struct
|
||
type formula = Formula.t
|
||
let iter_trail f = Vec.iter (fun a -> f (Atom.lit self.store a)) t
|
||
let[@inline] eval f = eval self (make_atom self f)
|
||
let[@inline] eval_level f = eval_level self (make_atom self f)
|
||
end in
|
||
(module M)
|
||
|
||
let mk_unsat (self:t) (us: unsat_cause) : _ Solver_intf.unsat_state =
|
||
pp_all self 99 "UNSAT";
|
||
let unsat_assumptions () = match us with
|
||
| US_local {first=_; core} -> core
|
||
| _ -> []
|
||
in
|
||
let unsat_conflict = match us with
|
||
| US_false c -> fun() -> c
|
||
| US_local {core=[]; _} -> assert false
|
||
| US_local {first; core} ->
|
||
let c = lazy (
|
||
let core = List.rev core in (* increasing trail order *)
|
||
assert (Atom.equal first @@ List.hd core);
|
||
Clause.make_l self.store ~removable:false []
|
||
) in
|
||
fun () -> Lazy.force c
|
||
in
|
||
let module M = struct
|
||
type nonrec atom = atom
|
||
type clause = Clause.t
|
||
type proof = Proof.t
|
||
let unsat_conflict = unsat_conflict
|
||
let unsat_assumptions = unsat_assumptions
|
||
end in
|
||
(module M)
|
||
|
||
let add_clause_a self c dp : unit =
|
||
try
|
||
let c = Clause.make_a self.store ~removable:false c in
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
add_clause_ self c
|
||
with
|
||
| E_unsat (US_false c) ->
|
||
self.unsat_at_0 <- Some c
|
||
|
||
let add_clause self c dp : unit =
|
||
try
|
||
let c = Clause.make_l self.store ~removable:false c in
|
||
if Proof.enabled self.proof then dp self.proof;
|
||
add_clause_ self c
|
||
with
|
||
| E_unsat (US_false c) ->
|
||
self.unsat_at_0 <- Some c
|
||
|
||
(* FIXME: take lits, not atoms *)
|
||
let add_input_clause self c =
|
||
let emit_proof p =
|
||
let lits = Iter.of_list c |> Iter.map (Atom.formula (store self)) in
|
||
Proof.emit_input_clause p lits
|
||
in
|
||
add_clause self c emit_proof
|
||
|
||
let add_input_clause_a self c =
|
||
let emit_proof p =
|
||
let lits = Iter.of_array c |> Iter.map (Atom.formula (store self)) in
|
||
Proof.emit_input_clause p lits
|
||
in
|
||
add_clause_a self c emit_proof
|
||
|
||
let solve ?(assumptions=[]) (st:t) : res =
|
||
cancel_until st 0;
|
||
Vec.clear st.assumptions;
|
||
List.iter (Vec.push st.assumptions) assumptions;
|
||
try
|
||
solve_ st;
|
||
Sat (mk_sat st)
|
||
with E_unsat us ->
|
||
Unsat (mk_unsat st us)
|
||
|
||
let true_at_level0 st a =
|
||
try
|
||
let b, lev = eval_level st a in
|
||
b && lev = 0
|
||
with UndecidedLit -> false
|
||
|
||
let[@inline] eval_atom self a : Solver_intf.lbool = eval_atom_ self a
|
||
end
|
||
[@@inline][@@specialise]
|
||
|
||
|
||
module Make_cdcl_t(Plugin : Solver_intf.PLUGIN_CDCL_T) =
|
||
Make(struct
|
||
include Plugin
|
||
let has_theory = true
|
||
end)
|
||
[@@inline][@@specialise]
|
||
|
||
module Make_pure_sat(Plugin : Solver_intf.PLUGIN_SAT) =
|
||
Make(struct
|
||
type formula = Plugin.formula
|
||
type proof = Plugin.proof
|
||
module Formula = Plugin.Formula
|
||
module Proof = Plugin.Proof
|
||
type t = unit
|
||
let push_level () = ()
|
||
let pop_levels _ _ = ()
|
||
let partial_check () _ = ()
|
||
let final_check () _ = ()
|
||
let has_theory = false
|
||
end)
|
||
[@@inline][@@specialise]
|
||
|