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

Simpler representation of solver types

Browse source
This commit is contained in:
Guillaume Bury 2015-06-26 12:58:00 +02:00
parent 898cfee53e
commit ce05d8fe62
4 changed files with 225 additions and 204 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

209
solver/internal.ml
View file

@ -43,7 +43,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
mutable var_inc : float; mutable var_inc : float;
(* increment for variables' activity *) (* increment for variables' activity *)
trail : (semantic var, atom) Either.t Vec.t; trail : (lit, atom) Either.t Vec.t;
(* decision stack + propagated atoms *) (* decision stack + propagated atoms *)
trail_lim : int Vec.t; trail_lim : int Vec.t;
@ -152,16 +152,22 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let get_var_id v = v.vid let get_var_id v = v.vid
let get_var_level v = v.level let get_var_level v = v.level
let get_var_weight v = v.weight let get_var_weight v = v.weight
let set_var_weight v w = v.weight <- w let set_var_weight v w = v.weight <- w
let set_var_level v l = v.level <- l let set_var_level v l = v.level <- l
let get_elt_id e = Either.destruct e get_var_id get_var_id (* Accessors for litterals *)
let get_elt_weight e = Either.destruct e get_var_weight get_var_weight let get_lit_id v = v.lid
let get_elt_level e = Either.destruct e get_var_level get_var_level let get_lit_level (v : lit) = v.level
let get_lit_weight (v : lit) = v.weight
let set_lit_weight (v : lit) w = v.weight <- w
let set_lit_level (v : lit) l = v.level <- l
let set_elt_weight e = Either.destruct e set_var_weight set_var_weight let get_elt_id e = Either.destruct e get_lit_id get_var_id
let set_elt_level e = Either.destruct e set_var_level set_var_level let get_elt_weight e = Either.destruct e get_lit_weight get_var_weight
let get_elt_level e = Either.destruct e get_lit_level get_var_level
let set_elt_weight e = Either.destruct e set_lit_weight set_var_weight
let set_elt_level e = Either.destruct e set_lit_level set_var_level
let f_weight i j = let f_weight i j =
get_elt_weight (St.get_var j) < get_elt_weight (St.get_var i) get_elt_weight (St.get_var j) < get_elt_weight (St.get_var i)
@ -171,10 +177,10 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
(* Var/clause activity *) (* Var/clause activity *)
let insert_var_order e = Either.destruct e let insert_var_order e = Either.destruct e
(fun v -> Iheap.insert f_weight env.order v.vid) (fun v -> Iheap.insert f_weight env.order v.lid)
(fun v -> (fun v ->
Iheap.insert f_weight env.order v.vid; Iheap.insert f_weight env.order v.vid;
iter_sub (fun t -> Iheap.insert f_weight env.order t.vid) v iter_sub (fun t -> Iheap.insert f_weight env.order t.lid) v
) )
let var_decay_activity () = let var_decay_activity () =
@ -194,9 +200,20 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
if Iheap.in_heap env.order v.vid then if Iheap.in_heap env.order v.vid then
Iheap.decrease f_weight env.order v.vid Iheap.decrease f_weight env.order v.vid
let lit_bump_activity_aux (v : lit) =
v.weight <- v.weight +. env.var_inc;
if v.weight > 1e100 then begin
for i = 0 to (St.nb_vars ()) - 1 do
set_elt_weight (St.get_var i) ((get_elt_weight (St.get_var i)) *. 1e-100)
done;
env.var_inc <- env.var_inc *. 1e-100;
end;
if Iheap.in_heap env.order v.lid then
Iheap.decrease f_weight env.order v.lid
let var_bump_activity v = let var_bump_activity v =
var_bump_activity_aux v; var_bump_activity_aux v;
iter_sub (fun t -> var_bump_activity_aux t) v iter_sub lit_bump_activity_aux v
let clause_bump_activity c = let clause_bump_activity c =
c.activity <- c.activity +. env.clause_inc; c.activity <- c.activity +. env.clause_inc;
@ -258,7 +275,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
for c = env.qhead to Vec.size env.trail - 1 do for c = env.qhead to Vec.size env.trail - 1 do
Either.destruct (Vec.get env.trail c) Either.destruct (Vec.get env.trail c)
(fun v -> (fun v ->
v.tag.assigned <- None; v.assigned <- None;
v.level <- -1; v.level <- -1;
insert_var_order (Either.mk_left v) insert_var_order (Either.mk_left v)
) )
@ -270,7 +287,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
a.is_true <- false; a.is_true <- false;
a.neg.is_true <- false; a.neg.is_true <- false;
a.var.level <- -1; a.var.level <- -1;
a.var.tag.reason <- Bcp None; a.var.reason <- Bcp None;
insert_var_order (Either.mk_right a.var) insert_var_order (Either.mk_right a.var)
end) end)
done; done;
@ -292,19 +309,19 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
if a.is_true then if a.is_true then
L.debug 10 "Litteral %a already in queue" pp_atom a L.debug 10 "Litteral %a already in queue" pp_atom a
else begin else begin
assert (a.var.level < 0 && a.var.tag.reason = Bcp None && lvl >= 0); assert (a.var.level < 0 && a.var.reason = Bcp None && lvl >= 0);
a.is_true <- true; a.is_true <- true;
a.var.level <- lvl; a.var.level <- lvl;
a.var.tag.reason <- reason; a.var.reason <- reason;
Vec.push env.trail (Either.mk_right a); Vec.push env.trail (Either.mk_right a);
L.debug 2 "Enqueue (%d): %a" (nb_assigns ()) pp_atom a L.debug 2 "Enqueue (%d): %a" (nb_assigns ()) pp_atom a
end end
let enqueue_assign (v: semantic var) value lvl = let enqueue_assign v value lvl =
v.tag.assigned <- Some value; v.assigned <- Some value;
v.level <- lvl; v.level <- lvl;
Vec.push env.trail (Either.mk_left v); Vec.push env.trail (Either.mk_left v);
L.debug 2 "Enqueue (%d): %a" (nb_assigns ()) St.pp_semantic_var v L.debug 2 "Enqueue (%d): %a" (nb_assigns ()) St.pp_lit v
let th_eval a = let th_eval a =
if a.is_true || a.neg.is_true then None if a.is_true || a.neg.is_true then None
@ -334,7 +351,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let c = ref (Proof.to_list c_clause) in let c = ref (Proof.to_list c_clause) in
let history = ref [c_clause] in let history = ref [c_clause] in
clause_bump_activity c_clause; clause_bump_activity c_clause;
let is_semantic a = match a.var.tag.reason with let is_semantic a = match a.var.reason with
| Semantic _ -> true | Semantic _ -> true
| _ -> false | _ -> false
in in
@ -355,15 +372,15 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
decr tr_ind; decr tr_ind;
L.debug 20 "Looking at trail element %d" !tr_ind; L.debug 20 "Looking at trail element %d" !tr_ind;
Either.destruct (Vec.get env.trail !tr_ind) Either.destruct (Vec.get env.trail !tr_ind)
(fun v -> L.debug 15 "%a" St.pp_semantic_var v) (fun v -> L.debug 15 "%a" St.pp_lit v)
(fun a -> match a.var.tag.reason with (fun a -> match a.var.reason with
| Bcp (Some d) -> | Bcp (Some d) ->
L.debug 15 "Propagation : %a" St.pp_atom a; L.debug 15 "Propagation : %a" St.pp_atom a;
L.debug 15 " |- %a" St.pp_clause d; L.debug 15 " |- %a" St.pp_clause d;
let tmp, res = Proof.resolve (Proof.merge !c (Proof.to_list d)) in let tmp, res = Proof.resolve (Proof.merge !c (Proof.to_list d)) in
begin match tmp with begin match tmp with
| [] -> L.debug 15 "No lit to resolve over." | [] -> L.debug 15 "No lit to resolve over."
| [b] when b == a.var.tag.pa -> | [b] when b == a.var.pa ->
clause_bump_activity d; clause_bump_activity d;
var_bump_activity a.var; var_bump_activity a.var;
history := d :: !history; history := d :: !history;
@ -419,7 +436,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
decr pathC; decr pathC;
let p = get_atom !tr_ind in let p = get_atom !tr_ind in
decr tr_ind; decr tr_ind;
match !pathC, p.var.tag.reason with match !pathC, p.var.reason with
| 0, _ -> | 0, _ ->
cond := false; cond := false;
learnt := p.neg :: (List.rev !learnt) learnt := p.neg :: (List.rev !learnt)
@ -429,7 +446,11 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
List.iter (fun q -> q.var.seen <- false) !seen; List.iter (fun q -> q.var.seen <- false) !seen;
!blevel, !learnt, !history, true !blevel, !learnt, !history, true
let analyze c_clause = if St.mcsat then analyze_mcsat c_clause else analyze_sat c_clause let analyze c_clause =
if St.mcsat then
analyze_mcsat c_clause
else
analyze_sat c_clause
let record_learnt_clause confl blevel learnt history is_uip = let record_learnt_clause confl blevel learnt history is_uip =
begin match learnt with begin match learnt with
@ -437,7 +458,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
| [fuip] -> | [fuip] ->
assert (blevel = 0); assert (blevel = 0);
if fuip.neg.is_true then if fuip.neg.is_true then
report_unsat confl report_unsat confl
else begin else begin
let name = fresh_lname () in let name = fresh_lname () in
let uclause = make_clause name learnt (List.length learnt) true history in let uclause = make_clause name learnt (List.length learnt) true history in
@ -453,11 +474,11 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
attach_clause lclause; attach_clause lclause;
clause_bump_activity lclause; clause_bump_activity lclause;
if is_uip then if is_uip then
enqueue_bool fuip blevel (Bcp (Some lclause)) enqueue_bool fuip blevel (Bcp (Some lclause))
else begin else begin
env.decisions <- env.decisions + 1; env.decisions <- env.decisions + 1;
new_decision_level(); new_decision_level();
enqueue_bool fuip.neg (decision_level ()) (Bcp None) enqueue_bool fuip.neg (decision_level ()) (Bcp None)
end end
end; end;
var_decay_activity (); var_decay_activity ();
@ -466,7 +487,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let add_boolean_conflict confl = let add_boolean_conflict confl =
env.conflicts <- env.conflicts + 1; env.conflicts <- env.conflicts + 1;
if decision_level() = 0 || Vec.for_all (fun a -> a.var.level = 0) confl.atoms then if decision_level() = 0 || Vec.for_all (fun a -> a.var.level = 0) confl.atoms then
report_unsat confl; (* Top-level conflict *) report_unsat confl; (* Top-level conflict *)
let blevel, learnt, history, is_uip = analyze confl in let blevel, learnt, history, is_uip = analyze confl in
cancel_until blevel; cancel_until blevel;
record_learnt_clause confl blevel learnt (History history) is_uip record_learnt_clause confl blevel learnt (History history) is_uip
@ -475,17 +496,17 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
exception Trivial exception Trivial
let simplify_zero atoms init0 = let simplify_zero atoms init0 =
(* TODO: could be more efficient than [@] everywhere? *) (* TODO: could be more efficient than [@] everywhere? *)
assert (decision_level () = 0); assert (decision_level () = 0);
let aux (atoms, init) a = let aux (atoms, init) a =
if a.is_true then raise Trivial; if a.is_true then raise Trivial;
if a.neg.is_true then if a.neg.is_true then
atoms, false atoms, false
else else
a::atoms, init a::atoms, init
in in
let atoms, init = List.fold_left aux ([], true) atoms in let atoms, init = List.fold_left aux ([], true) atoms in
List.fast_sort (fun a b -> a.var.vid - b.var.vid) atoms, init List.fast_sort (fun a b -> a.var.vid - b.var.vid) atoms, init
let partition atoms init0 = let partition atoms init0 =
let rec partition_aux trues unassigned falses init = function let rec partition_aux trues unassigned falses init = function
@ -503,9 +524,9 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
partition_aux trues (a::unassigned) falses init r partition_aux trues (a::unassigned) falses init r
in in
if decision_level () = 0 then if decision_level () = 0 then
simplify_zero atoms init0 simplify_zero atoms init0
else else
partition_aux [] [] [] true atoms partition_aux [] [] [] true atoms
let add_clause ?tag name atoms history = let add_clause ?tag name atoms history =
if env.is_unsat then raise Unsat; (* is it necessary ? *) if env.is_unsat then raise Unsat; (* is it necessary ? *)
@ -523,8 +544,8 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
| a::b::_ -> | a::b::_ ->
let name = fresh_name () in let name = fresh_name () in
let clause = let clause =
if init then init0 if init then init0
else make_clause ?tag name atoms size true (History [init0]) else make_clause ?tag name atoms size true (History [init0])
in in
L.debug 1 "New clause : %a" St.pp_clause clause; L.debug 1 "New clause : %a" St.pp_clause clause;
attach_clause clause; attach_clause clause;
@ -627,7 +648,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
a a
let slice_get i = Either.destruct (Vec.get env.trail i) let slice_get i = Either.destruct (Vec.get env.trail i)
(function {level; tag={term; assigned = Some v}} -> Th.Assign (term, v), level | _ -> assert false) (function {level; term; assigned = Some v} -> Th.Assign (term, v), level | _ -> assert false)
(fun a -> Th.Lit a.lit, a.var.level) (fun a -> Th.Lit a.lit, a.var.level)
let slice_push l lemma = let slice_push l lemma =
@ -678,10 +699,10 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let res = ref None in let res = ref None in
while env.qhead < Vec.size env.trail do while env.qhead < Vec.size env.trail do
Either.destruct (Vec.get env.trail env.qhead) Either.destruct (Vec.get env.trail env.qhead)
(fun a -> ()) (fun a -> ())
(fun a -> (fun a ->
incr num_props; incr num_props;
propagate_atom a res); propagate_atom a res);
env.qhead <- env.qhead + 1 env.qhead <- env.qhead + 1
done; done;
env.propagations <- env.propagations + !num_props; env.propagations <- env.propagations + !num_props;
@ -702,9 +723,9 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
if sz1 > 2 && (sz2 = 2 || c < 0) then -1 if sz1 > 2 && (sz2 = 2 || c < 0) then -1
else 1 else 1
(* returns true if the clause is used as a reason for a propagation, (* returns true if the clause is used as a reason for a propagation,
and therefore can be needed in case of conflict. In this case and therefore can be needed in case of conflict. In this case
the clause can't be forgotten *) the clause can't be forgotten *)
let locked c = false (* let locked c = false (*
Vec.exists Vec.exists
(fun v -> match v.reason with (fun v -> match v.reason with
@ -767,31 +788,31 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let rec pick_branch_lit () = let rec pick_branch_lit () =
let max = Iheap.remove_min f_weight env.order in let max = Iheap.remove_min f_weight env.order in
Either.destruct (St.get_var max) Either.destruct (St.get_var max)
(fun v -> (fun v ->
if v.level >= 0 then if v.level >= 0 then
pick_branch_lit () pick_branch_lit ()
else begin else begin
let value = Th.assign v.tag.term in let value = Th.assign v.term in
env.decisions <- env.decisions + 1; env.decisions <- env.decisions + 1;
new_decision_level(); new_decision_level();
let current_level = decision_level () in let current_level = decision_level () in
L.debug 5 "Deciding on %a" St.pp_semantic_var v; L.debug 5 "Deciding on %a" St.pp_lit v;
enqueue_assign v value current_level enqueue_assign v value current_level
end) end)
(fun v -> (fun v ->
if v.level >= 0 then begin if v.level >= 0 then begin
assert (v.tag.pa.is_true || v.tag.na.is_true); assert (v.pa.is_true || v.na.is_true);
pick_branch_lit () pick_branch_lit ()
end else match Th.eval v.tag.pa.lit with end else match Th.eval v.pa.lit with
| Th.Unknown -> | Th.Unknown ->
env.decisions <- env.decisions + 1; env.decisions <- env.decisions + 1;
new_decision_level(); new_decision_level();
let current_level = decision_level () in let current_level = decision_level () in
L.debug 5 "Deciding on %a" St.pp_atom v.tag.pa; L.debug 5 "Deciding on %a" St.pp_atom v.pa;
enqueue_bool v.tag.pa current_level (Bcp None) enqueue_bool v.pa current_level (Bcp None)
| Th.Valued (b, lvl) -> | Th.Valued (b, lvl) ->
let a = if b then v.tag.pa else v.tag.na in let a = if b then v.pa else v.na in
enqueue_bool a lvl (Semantic lvl)) enqueue_bool a lvl (Semantic lvl))
let search n_of_conflicts n_of_learnts = let search n_of_conflicts n_of_learnts =
let conflictC = ref 0 in let conflictC = ref 0 in
@ -805,10 +826,10 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
| None -> (* No Conflict *) | None -> (* No Conflict *)
if nb_assigns() = St.nb_vars () (* env.nb_init_vars *) then raise Sat; if nb_assigns() = St.nb_vars () (* env.nb_init_vars *) then raise Sat;
if n_of_conflicts > 0 && !conflictC >= n_of_conflicts then begin if n_of_conflicts > 0 && !conflictC >= n_of_conflicts then begin
L.debug 1 "Restarting..."; L.debug 1 "Restarting...";
env.progress_estimate <- progress_estimate(); env.progress_estimate <- progress_estimate();
cancel_until 0; cancel_until 0;
raise Restart raise Restart
end; end;
if decision_level() = 0 then simplify (); if decision_level() = 0 then simplify ();
@ -833,9 +854,9 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let add_clauses ?tag cnf = let add_clauses ?tag cnf =
let aux cl = let aux cl =
add_clause ?tag (fresh_hname ()) cl (History []); add_clause ?tag (fresh_hname ()) cl (History []);
match propagate () with match propagate () with
| None -> () | Some confl -> report_unsat confl | None -> () | Some confl -> report_unsat confl
in in
List.iter aux cnf List.iter aux cnf
@ -872,9 +893,9 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
Vec.grow_to_by_double env.learnts nbc; Vec.grow_to_by_double env.learnts nbc;
env.nb_init_clauses <- nbc; env.nb_init_clauses <- nbc;
St.iter_vars (fun e -> Either.destruct e St.iter_vars (fun e -> Either.destruct e
(fun v -> L.debug 50 " -- %a" St.pp_semantic_var v) (fun v -> L.debug 50 " -- %a" St.pp_lit v)
(fun a -> L.debug 50 " -- %a" St.pp_atom a.tag.pa) (fun a -> L.debug 50 " -- %a" St.pp_atom a.pa)
); );
add_clauses ?tag cnf add_clauses ?tag cnf
let assume ?tag cnf = let assume ?tag cnf =
@ -883,8 +904,8 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let eval lit = let eval lit =
let var, negated = make_boolean_var lit in let var, negated = make_boolean_var lit in
assert (var.tag.pa.is_true || var.tag.na.is_true); assert (var.pa.is_true || var.na.is_true);
let truth = var.tag.pa.is_true in let truth = var.pa.is_true in
if negated then not truth else truth if negated then not truth else truth
let hyps () = env.clauses let hyps () = env.clauses
@ -896,9 +917,9 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let model () = let model () =
let opt = function Some a -> a | None -> assert false in let opt = function Some a -> a | None -> assert false in
Vec.fold (fun acc e -> Either.destruct e Vec.fold (fun acc e -> Either.destruct e
(fun (v: semantic var) -> (v.tag.term, opt v.tag.assigned) :: acc) (fun v -> (v.term, opt v.assigned) :: acc)
(fun _ -> acc) (fun _ -> acc)
) [] env.trail ) [] env.trail
(* Push/Pop *) (* Push/Pop *)
type level = int type level = int
@ -918,7 +939,7 @@ module Make (L : Log_intf.S)(St : Solver_types.S)
let pop l = let pop l =
if l > current_level() if l > current_level()
then invalid_arg "cannot pop() to level, it is too high"; then invalid_arg "cannot pop() to level, it is too high";
let ul = Vec.get env.user_levels l in let ul = Vec.get env.user_levels l in
(* see whether we can reset [env.is_unsat] *) (* see whether we can reset [env.is_unsat] *)
if env.is_unsat && not (Vec.is_empty env.trail_lim) then ( if env.is_unsat && not (Vec.is_empty env.trail_lim) then (

12
solver/res.ml
View file

@ -64,7 +64,7 @@ module Make(L : Log_intf.S)(St : Solver_types.S) = struct
if equal_atoms a b then if equal_atoms a b then
aux resolved (a :: acc) r aux resolved (a :: acc) r
else if equal_atoms St.(a.neg) b then else if equal_atoms St.(a.neg) b then
aux (St.(a.var.tag.pa) :: resolved) acc r aux (St.(a.var.pa) :: resolved) acc r
else else
aux resolved (a :: acc) (b :: r) aux resolved (a :: acc) (b :: r)
in in
@ -133,7 +133,7 @@ module Make(L : Log_intf.S)(St : Solver_types.S) = struct
diff_learnt (b :: acc) l r' diff_learnt (b :: acc) l r'
| _ -> raise (Resolution_error "Impossible to derive correct clause") | _ -> raise (Resolution_error "Impossible to derive correct clause")
let clause_unit a = match St.(a.var.level, a.var.tag.reason) with let clause_unit a = match St.(a.var.level, a.var.reason) with
| 0, St.Bcp Some c -> c, to_list c | 0, St.Bcp Some c -> c, to_list c
| _ -> | _ ->
raise (Resolution_error "Could not find a reason needed to resolve") raise (Resolution_error "Could not find a reason needed to resolve")
@ -189,7 +189,7 @@ module Make(L : Log_intf.S)(St : Solver_types.S) = struct
| [] -> true | [] -> true
| a :: r -> | a :: r ->
L.debug 2 "Eliminating %a in %a" St.pp_atom a St.pp_clause c; L.debug 2 "Eliminating %a in %a" St.pp_atom a St.pp_clause c;
let d = match St.(a.var.level, a.var.tag.reason) with let d = match St.(a.var.level, a.var.reason) with
| 0, St.Bcp Some d -> d | 0, St.Bcp Some d -> d
| _ -> raise Exit | _ -> raise Exit
in in
@ -334,10 +334,10 @@ module Make(L : Log_intf.S)(St : Solver_types.S) = struct
if f_args <> [] then if f_args <> [] then
Format.fprintf fmt "<TD>%a</TD></TR>%a%a" St.print_atom (List.hd f_args) Format.fprintf fmt "<TD>%a</TD></TR>%a%a" St.print_atom (List.hd f_args)
(fun fmt -> List.iter (fun a -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_atom a)) (List.tl f_args) (fun fmt -> List.iter (fun a -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_atom a)) (List.tl f_args)
(fun fmt -> List.iter (fun v -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_semantic_var v)) t_args (fun fmt -> List.iter (fun v -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_lit v)) t_args
else if t_args <> [] then else if t_args <> [] then
Format.fprintf fmt "<TD>%a</TD></TR>%a" St.print_semantic_var (List.hd t_args) Format.fprintf fmt "<TD>%a</TD></TR>%a" St.print_lit (List.hd t_args)
(fun fmt -> List.iter (fun v -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_semantic_var v)) (List.tl t_args) (fun fmt -> List.iter (fun v -> Format.fprintf fmt "<TR><TD>%a</TD></TR>" St.print_lit v)) (List.tl t_args)
else else
Format.fprintf fmt "<TD></TD></TR>" Format.fprintf fmt "<TD></TD></TR>"
in in

146
solver/solver_types.ml
View file

@ -27,63 +27,64 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
type formula = E.Formula.t type formula = E.Formula.t
type proof = Th.proof type proof = Th.proof
type 'a var = type lit = {
{ vid : int; lid : int;
tag : 'a; term : term;
mutable weight : float; mutable level : int;
mutable level : int; mutable weight : float;
mutable seen : bool; mutable assigned : term option;
} }
type semantic = type var = {
{ term : term; vid : int;
mutable assigned : term option; }
type boolean = {
pa : atom; pa : atom;
na : atom; na : atom;
mutable seen : bool;
mutable level : int;
mutable weight : float;
mutable reason : reason; mutable reason : reason;
} }
and atom = and atom = {
{ var : boolean var; aid : int;
lit : formula; var : var;
neg : atom; neg : atom;
mutable watched : clause Vec.t; lit : formula;
mutable is_true : bool; mutable is_true : bool;
aid : int } mutable watched : clause Vec.t;
}
and clause = and clause = {
{ name : string; name : string;
tag : int option; tag : int option;
atoms : atom Vec.t ; atoms : atom Vec.t;
mutable activity : float; learnt : bool;
mutable removed : bool; cpremise : premise;
learnt : bool; mutable activity : float;
cpremise : premise } mutable removed : bool;
}
and reason = and reason =
| Semantic of int | Semantic of int
| Bcp of clause option | Bcp of clause option
and premise = and premise =
| History of clause list | History of clause list
| Lemma of proof | Lemma of proof
type elt = (semantic var, boolean var) Either.t type elt = (lit, var) Either.t
(* Dummy values *) (* Dummy values *)
let dummy_lit = E.dummy let dummy_lit = E.dummy
let rec dummy_var = let rec dummy_var =
{ vid = -101; { vid = -101;
pa = dummy_atom;
na = dummy_atom;
seen = false;
level = -1; level = -1;
weight = -1.; weight = -1.;
seen = false; reason = Bcp None;
tag = {
pa = dummy_atom;
na = dummy_atom;
reason = Bcp None; };
} }
and dummy_atom = and dummy_atom =
{ var = dummy_var; { var = dummy_var;
@ -121,21 +122,19 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
let cpt_mk_var = ref 0 let cpt_mk_var = ref 0
let make_semantic_var t = let make_semantic_var t =
try MT.find t_map t try MT.find t_map t
with Not_found -> with Not_found ->
let res = { let res = {
vid = !cpt_mk_var; lid = !cpt_mk_var;
weight = 1.; term = t;
level = -1; weight = 1.;
seen = false; level = -1;
tag = { assigned = None;
term = t; } in
assigned = None; }; incr cpt_mk_var;
} in MT.add t_map t res;
incr cpt_mk_var; Vec.push vars (Either.mk_left res);
MT.add t_map t res; res
Vec.push vars (Either.mk_left res);
res
let make_boolean_var = let make_boolean_var =
fun lit -> fun lit ->
@ -145,13 +144,12 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
let cpt_fois_2 = !cpt_mk_var lsl 1 in let cpt_fois_2 = !cpt_mk_var lsl 1 in
let rec var = let rec var =
{ vid = !cpt_mk_var; { vid = !cpt_mk_var;
pa = pa;
na = na;
seen = false;
level = -1; level = -1;
weight = 0.; weight = 0.;
seen = false; reason = Bcp None;
tag = {
pa = pa;
na = na;
reason = Bcp None;};
} }
and pa = and pa =
{ var = var; { var = var;
@ -177,7 +175,7 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
let add_atom lit = let add_atom lit =
let var, negated = make_boolean_var lit in let var, negated = make_boolean_var lit in
if negated then var.tag.na else var.tag.pa if negated then var.na else var.pa
let make_clause ?tag name ali sz_ali is_learnt premise = let make_clause ?tag name ali sz_ali is_learnt premise =
let atoms = Vec.from_list ali sz_ali dummy_atom in let atoms = Vec.from_list ali sz_ali dummy_atom in
@ -213,21 +211,21 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
let iter_map = ref Mi.empty let iter_map = ref Mi.empty
let iter_sub f v = let iter_sub f v =
try try
List.iter f (Mi.find v.vid !iter_map) List.iter f (Mi.find v.vid !iter_map)
with Not_found -> with Not_found ->
let l = ref [] in let l = ref [] in
Th.iter_assignable (fun t -> l := add_term t :: !l) v.tag.pa.lit; Th.iter_assignable (fun t -> l := add_term t :: !l) v.pa.lit;
iter_map := Mi.add v.vid !l !iter_map; iter_map := Mi.add v.vid !l !iter_map;
List.iter f !l List.iter f !l
(* Proof debug info *) (* Proof debug info *)
let proof_debug p = let proof_debug p =
let name, l, l', color = Th.proof_debug p in let name, l, l', color = Th.proof_debug p in
name, (List.map add_atom l), (List.map add_term l'), color name, (List.map add_atom l), (List.map add_term l'), color
(* Pretty printing for atoms and clauses *) (* Pretty printing for atoms and clauses *)
let print_semantic_var fmt (v: semantic var) = E.Term.print fmt v.tag.term let print_lit fmt v = E.Term.print fmt v.term
let print_atom fmt a = E.Formula.print fmt a.lit let print_atom fmt a = E.Formula.print fmt a.lit
@ -243,10 +241,10 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
Format.fprintf fmt "%s : %a" c.name print_atoms c.atoms Format.fprintf fmt "%s : %a" c.name print_atoms c.atoms
(* Complete debug printing *) (* Complete debug printing *)
let sign a = if a==a.var.tag.pa then "" else "-" let sign a = if a == a.var.pa then "" else "-"
let level a = let level a =
match a.var.level, a.var.tag.reason with match a.var.level, a.var.reason with
| n, _ when n < 0 -> assert false | n, _ when n < 0 -> assert false
| 0, Bcp (Some c) -> sprintf "->0/%s" c.name | 0, Bcp (Some c) -> sprintf "->0/%s" c.name
| 0, Bcp None -> "@0" | 0, Bcp None -> "@0"
@ -264,12 +262,12 @@ module Make (L : Log_intf.S)(E : Expr_intf.S)(Th : Plugin_intf.S with
| Lemma _ -> bprintf b "th_lemma" | Lemma _ -> bprintf b "th_lemma"
let pp_assign b = function let pp_assign b = function
| None -> () | None -> ()
| Some t -> bprintf b "[assignment: %s]" (Log.on_fmt E.Term.print t) | Some t -> bprintf b "[assignment: %s]" (Log.on_fmt E.Term.print t)
let pp_semantic_var b v = let pp_lit b v =
bprintf b "%d [lit:%s]%a" bprintf b "%d [lit:%s]%a"
(v.vid+1) (Log.on_fmt E.Term.print v.tag.term) pp_assign v.tag.assigned (v.lid+1) (Log.on_fmt E.Term.print v.term) pp_assign v.assigned
let pp_atom b a = let pp_atom b a =
bprintf b "%s%d%s[lit:%s]" bprintf b "%s%d%s[lit:%s]"

62
solver/solver_types_intf.ml
View file

@ -20,53 +20,55 @@ module type S = sig
type formula type formula
type proof type proof
type 'a var = type lit = {
{ vid : int; lid : int;
tag : 'a; term : term;
mutable weight : float; mutable level : int;
mutable level : int; mutable weight : float;
mutable seen : bool; } mutable assigned : term option;
}
type semantic = type var = {
{ term : term; vid : int;
mutable assigned : term option; }
type boolean = {
pa : atom; pa : atom;
na : atom; na : atom;
mutable seen : bool;
mutable level : int;
mutable weight : float;
mutable reason : reason; mutable reason : reason;
} }
and atom = { and atom = {
var : boolean var; aid : int;
lit : formula; var : var;
neg : atom; neg : atom;
mutable watched : clause Vec.t; lit : formula;
mutable is_true : bool; mutable is_true : bool;
aid : int mutable watched : clause Vec.t;
} }
and clause = { and clause = {
name : string; name : string;
tag : int option; tag : int option;
atoms : atom Vec.t; atoms : atom Vec.t;
learnt : bool;
cpremise : premise;
mutable activity : float; mutable activity : float;
mutable removed : bool; mutable removed : bool;
learnt : bool;
cpremise : premise
} }
and reason = and reason =
| Semantic of int | Semantic of int
| Bcp of clause option | Bcp of clause option
and premise =
| History of clause list
| Lemma of proof
type elt = (semantic var, boolean var) Either.t and premise =
| History of clause list
| Lemma of proof
type elt = (lit, var) Either.t
(** Recursive types for literals (atoms) and clauses *) (** Recursive types for literals (atoms) and clauses *)
val dummy_var : boolean var val dummy_var : var
val dummy_atom : atom val dummy_atom : atom
val dummy_clause : clause val dummy_clause : clause
(** Dummy values for use in vector dummys *) (** Dummy values for use in vector dummys *)
@ -78,13 +80,13 @@ module type S = sig
val add_atom : formula -> atom val add_atom : formula -> atom
(** Returns the atom associated with the given formula *) (** Returns the atom associated with the given formula *)
val add_term : term -> semantic var val add_term : term -> lit
(** Returns the variable associated with the term *) (** Returns the variable associated with the term *)
val make_boolean_var : formula -> boolean var * bool val make_boolean_var : formula -> var * bool
(** Returns the variable linked with the given formula, and wether the atom associated with the formula (** Returns the variable linked with the given formula, and wether the atom associated with the formula
is [var.pa] or [var.na] *) is [var.pa] or [var.na] *)
val iter_sub : (semantic var -> unit) -> boolean var -> unit val iter_sub : (lit -> unit) -> var -> unit
(** Iterates over the semantic var corresponding to subterms of the fiven literal, according (** Iterates over the semantic var corresponding to subterms of the fiven literal, according
to Th.iter_assignable *) to Th.iter_assignable *)
@ -99,16 +101,16 @@ module type S = sig
val fresh_hname : unit -> string val fresh_hname : unit -> string
(** Fresh names for clauses *) (** Fresh names for clauses *)
val proof_debug : proof -> string * (atom list) * (semantic var list) * (string option) val proof_debug : proof -> string * (atom list) * (lit list) * (string option)
(** Debugging info for proofs (see Plugin_intf). *) (** Debugging info for proofs (see Plugin_intf). *)
val print_lit : Format.formatter -> lit -> unit
val print_atom : Format.formatter -> atom -> unit val print_atom : Format.formatter -> atom -> unit
val print_semantic_var : Format.formatter -> semantic var -> unit
val print_clause : Format.formatter -> clause -> unit val print_clause : Format.formatter -> clause -> unit
(** Pretty printing functions for atoms and clauses *) (** Pretty printing functions for atoms and clauses *)
val pp_lit : Buffer.t -> lit -> unit
val pp_atom : Buffer.t -> atom -> unit val pp_atom : Buffer.t -> atom -> unit
val pp_semantic_var : Buffer.t -> semantic var -> unit
val pp_clause : Buffer.t -> clause -> unit val pp_clause : Buffer.t -> clause -> unit
(** Debug function for atoms and clauses (very verbose) *) (** Debug function for atoms and clauses (very verbose) *)