mirror of
https://github.com/c-cube/sidekick.git
synced 2025-12-10 05:03:59 -05:00
104 lines
3.3 KiB
OCaml
104 lines
3.3 KiB
OCaml
|
||
(* TODO (long term): relevancy propagation *)
|
||
|
||
(* TODO: Tseitin on the fly when a composite boolean term is asserted.
|
||
--> maybe, cache the clause inside the literal *)
|
||
|
||
module Theory = Sidekick_smt.Theory
|
||
open Bool_intf
|
||
|
||
module type ARG = Bool_intf.BOOL_TERM
|
||
with type t = Sidekick_smt.Term.t
|
||
and type state = Sidekick_smt.Term.state
|
||
|
||
module Make(Term : ARG) = struct
|
||
type term = Term.t
|
||
|
||
module T_tbl = CCHashtbl.Make(Term)
|
||
module Lit = Sidekick_smt.Lit
|
||
|
||
type t = {
|
||
tst: Term.state;
|
||
expanded: unit T_tbl.t; (* set of literals already expanded *)
|
||
}
|
||
|
||
let tseitin ~final (self:t) (acts:Theory.actions) (lit:Lit.t) (lit_t:term) (v:term view) : unit =
|
||
let (module A) = acts in
|
||
Log.debugf 5 (fun k->k "(@[th_bool.tseitin@ %a@])" Lit.pp lit);
|
||
let expanded () = T_tbl.mem self.expanded lit_t in
|
||
let add_axiom c =
|
||
T_tbl.replace self.expanded lit_t ();
|
||
A.add_persistent_axiom c
|
||
in
|
||
match v with
|
||
| B_not _ -> assert false (* normalized *)
|
||
| B_atom _ -> () (* CC will manage *)
|
||
| B_and subs ->
|
||
if Lit.sign lit then (
|
||
(* propagate [lit => subs_i] *)
|
||
IArray.iter
|
||
(fun sub ->
|
||
let sublit = Lit.atom self.tst sub in
|
||
A.propagate_l sublit [lit])
|
||
subs
|
||
) else if final && not @@ expanded () then (
|
||
(* axiom [¬lit => ∨_i ¬ subs_i] *)
|
||
let subs = IArray.to_list subs in
|
||
let c = Lit.neg lit :: List.map (Lit.atom self.tst ~sign:false) subs in
|
||
add_axiom c
|
||
)
|
||
| B_or subs ->
|
||
if not @@ Lit.sign lit then (
|
||
(* propagate [¬lit => ¬subs_i] *)
|
||
IArray.iter
|
||
(fun sub ->
|
||
let sublit = Lit.atom self.tst ~sign:false sub in
|
||
A.add_local_axiom [Lit.neg lit; sublit])
|
||
subs
|
||
) else if final && not @@ expanded () then (
|
||
(* axiom [lit => ∨_i subs_i] *)
|
||
let subs = IArray.to_list subs in
|
||
let c = Lit.neg lit :: List.map (Lit.atom self.tst ~sign:true) subs in
|
||
add_axiom c
|
||
)
|
||
| B_imply (guard,concl) ->
|
||
if Lit.sign lit && final && not @@ expanded () then (
|
||
(* axiom [lit => ∨_i ¬guard_i ∨ concl] *)
|
||
let guard = IArray.to_list guard in
|
||
let c = Lit.atom self.tst concl :: Lit.neg lit :: List.map (Lit.atom self.tst ~sign:false) guard in
|
||
add_axiom c
|
||
) else if not @@ Lit.sign lit then (
|
||
(* propagate [¬lit => ¬concl] *)
|
||
A.propagate_l (Lit.atom self.tst ~sign:false concl) [lit];
|
||
(* propagate [¬lit => ∧_i guard_i] *)
|
||
IArray.iter
|
||
(fun sub ->
|
||
let sublit = Lit.atom self.tst ~sign:true sub in
|
||
A.propagate_l sublit [lit])
|
||
guard
|
||
)
|
||
|
||
let check_ ~final self acts lits =
|
||
lits
|
||
(fun lit ->
|
||
let t = Lit.term lit in
|
||
match Term.view_as_bool t with
|
||
| B_atom _ -> ()
|
||
| v -> tseitin ~final self acts lit t v)
|
||
|
||
let partial_check (self:t) acts (lits:Lit.t Sequence.t) =
|
||
check_ ~final:false self acts lits
|
||
|
||
let final_check (self:t) acts (lits:Lit.t Sequence.t) =
|
||
check_ ~final:true self acts lits
|
||
|
||
let th =
|
||
Theory.make
|
||
~partial_check
|
||
~final_check
|
||
~name:"boolean"
|
||
~create:(fun tst -> {tst; expanded=T_tbl.create 24})
|
||
?mk_model:None (* entirely interpreted *)
|
||
()
|
||
|
||
end
|