mirror of
https://github.com/c-cube/sidekick.git
synced 2025-12-12 22:10:53 -05:00
126 lines
3.8 KiB
OCaml
126 lines
3.8 KiB
OCaml
(** {1 Theory of Booleans} *)
|
||
|
||
(** {2 Signatures for booleans} *)
|
||
module View = struct
|
||
type 'a t =
|
||
| B_not of 'a
|
||
| B_and of 'a IArray.t
|
||
| B_or of 'a IArray.t
|
||
| B_imply of 'a IArray.t * 'a
|
||
| B_atom of 'a
|
||
end
|
||
|
||
module type ARG = sig
|
||
module S : Sidekick_core.SOLVER
|
||
|
||
type term = S.A.Term.t
|
||
|
||
val view_as_bool : term -> term View.t
|
||
val mk_bool : S.A.Term.state -> term View.t -> term
|
||
end
|
||
|
||
module type S = sig
|
||
module A : ARG
|
||
|
||
val theory : A.S.theory
|
||
end
|
||
|
||
(** Theory with dynamic reduction to clauses *)
|
||
module Make_dyn_tseitin (A : ARG) = (* : S with module A = A *)
|
||
struct
|
||
(* 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 A = A
|
||
module SI = A.S.Solver_internal
|
||
module T = SI.A.Term
|
||
module Lit = SI.A.Lit
|
||
|
||
type term = T.t
|
||
|
||
module T_tbl = CCHashtbl.Make (T)
|
||
|
||
type t = { expanded: unit T_tbl.t (* set of literals already expanded *) }
|
||
|
||
let tseitin ~final (self : t) (solver : SI.t) (lit : Lit.t) (lit_t : term)
|
||
(v : term View.t) : unit =
|
||
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 ();
|
||
SI.add_persistent_axiom solver 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 = SI.mk_lit solver sub in
|
||
SI.propagate_l solver 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 (SI.mk_lit solver ~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 = SI.mk_lit solver ~sign:false sub in
|
||
SI.add_local_axiom solver [ 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 (SI.mk_lit solver ~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 =
|
||
SI.mk_lit solver concl :: Lit.neg lit
|
||
:: List.map (SI.mk_lit solver ~sign:false) guard
|
||
in
|
||
add_axiom c
|
||
) else if not @@ Lit.sign lit then (
|
||
(* propagate [¬lit => ¬concl] *)
|
||
SI.propagate_l solver (SI.mk_lit solver ~sign:false concl) [ lit ];
|
||
(* propagate [¬lit => ∧_i guard_i] *)
|
||
IArray.iter
|
||
(fun sub ->
|
||
let sublit = SI.mk_lit solver ~sign:true sub in
|
||
SI.propagate_l solver sublit [ lit ])
|
||
guard
|
||
)
|
||
|
||
let check_ ~final self solver lits =
|
||
lits (fun lit ->
|
||
let t = Lit.term lit in
|
||
match A.view_as_bool t with
|
||
| B_atom _ -> ()
|
||
| v -> tseitin ~final self solver lit t v)
|
||
|
||
let partial_check (self : t) acts (lits : Lit.t Iter.t) =
|
||
check_ ~final:false self acts lits
|
||
|
||
let final_check (self : t) acts (lits : Lit.t Iter.t) =
|
||
check_ ~final:true self acts lits
|
||
|
||
let create_and_setup (solver : SI.t) : t =
|
||
let self = { expanded = T_tbl.create 24 } in
|
||
SI.on_final_check solver (final_check self);
|
||
SI.on_partial_check solver (partial_check self);
|
||
self
|
||
|
||
let theory = A.S.mk_theory ~name:"boolean" ~create_and_setup ()
|
||
end
|