diff --git a/src/abstract-solver/check_res.ml b/src/abstract-solver/check_res.ml index 77522244..2572a29f 100644 --- a/src/abstract-solver/check_res.ml +++ b/src/abstract-solver/check_res.ml @@ -1,16 +1,29 @@ (** Result of solving for the current set of clauses *) -module Model = Sidekick_model +type value = Term.t + +type sat_result = { + get_value: Term.t -> value option; (** Value for this term *) + iter_classes: (Term.t Iter.t * value) Iter.t; + (** All equivalence classes in the congruence closure *) + eval_lit: Lit.t -> bool option; (** Evaluate literal *) + iter_true_lits: Lit.t Iter.t; + (** Iterate on literals that are true in the trail *) +} +(** Satisfiable *) + +type unsat_result = { + unsat_core: unit -> Lit.t Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_proof: unit -> Sidekick_proof.Step.id option; + (** Proof step for the empty clause *) +} +(** Unsatisfiable *) (** Result of calling "check" *) type t = - | Sat of Model.t (** Satisfiable *) - | Unsat of { - unsat_core: unit -> Lit.t Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_proof: unit -> Sidekick_proof.Step.id option; - (** Proof step for the empty clause *) - } (** Unsatisfiable *) + | Sat of sat_result + | Unsat of unsat_result | Unknown of Unknown.t (** Unknown, obtained after a timeout, memory limit, etc. *) diff --git a/src/abstract-solver/dune b/src/abstract-solver/dune index 2e32b504..fe436265 100644 --- a/src/abstract-solver/dune +++ b/src/abstract-solver/dune @@ -2,4 +2,4 @@ (name sidekick_abstract_solver) (public_name sidekick.abstract-solver) (flags :standard -open Sidekick_util -open Sidekick_core) - (libraries containers iter sidekick.core sidekick.model sidekick.proof)) + (libraries containers iter sidekick.core sidekick.proof)) diff --git a/src/base/Statement.ml b/src/base/Statement.ml index 22abe1aa..222facdb 100644 --- a/src/base/Statement.ml +++ b/src/base/Statement.ml @@ -5,8 +5,9 @@ type t = statement = | Stmt_set_option of string list | Stmt_set_info of string * string | Stmt_data of data list - | Stmt_ty_decl of ID.t * int (* new atomic cstor *) - | Stmt_decl of ID.t * ty list * ty + | Stmt_ty_decl of { name: ID.t; arity: int; ty_const: ty } + (** new atomic cstor *) + | Stmt_decl of { name: ID.t; ty_args: ty list; ty_ret: ty; const: term } | Stmt_define of definition list | Stmt_assert of term | Stmt_assert_clause of term list @@ -30,10 +31,11 @@ let pp out = function Fmt.fprintf out "(@[not %a@])" Term.pp_debug t in Fmt.fprintf out "(@[check-sat-assuming@ (@[%a@])@])" (Fmt.list pp_pair) l - | Stmt_ty_decl (s, n) -> Fmt.fprintf out "(@[declare-sort@ %a %d@])" ID.pp s n - | Stmt_decl (id, args, ret) -> - Fmt.fprintf out "(@[<1>declare-fun@ %a (@[%a@])@ %a@])" ID.pp id - (Util.pp_list Ty.pp) args Ty.pp ret + | Stmt_ty_decl { name; arity; ty_const = _ } -> + Fmt.fprintf out "(@[declare-sort@ %a %d@])" ID.pp name arity + | Stmt_decl { name; ty_args; ty_ret; const = _ } -> + Fmt.fprintf out "(@[<1>declare-fun@ %a (@[%a@])@ %a@])" ID.pp name + (Util.pp_list Ty.pp) ty_args Ty.pp ty_ret | Stmt_assert t -> Fmt.fprintf out "(@[assert@ %a@])" Term.pp_debug t | Stmt_assert_clause c -> Fmt.fprintf out "(@[assert-clause@ %a@])" (Util.pp_list Term.pp_debug) c diff --git a/src/base/Statement.mli b/src/base/Statement.mli index eb917451..4ce18caf 100644 --- a/src/base/Statement.mli +++ b/src/base/Statement.mli @@ -11,8 +11,9 @@ type t = statement = | Stmt_set_option of string list | Stmt_set_info of string * string | Stmt_data of data list - | Stmt_ty_decl of ID.t * int (* new atomic cstor *) - | Stmt_decl of ID.t * ty list * ty + | Stmt_ty_decl of { name: ID.t; arity: int; ty_const: ty } + (** new atomic cstor *) + | Stmt_decl of { name: ID.t; ty_args: ty list; ty_ret: ty; const: term } | Stmt_define of definition list | Stmt_assert of term | Stmt_assert_clause of term list diff --git a/src/base/types_.ml b/src/base/types_.ml index 31b31f89..58e0e1a1 100644 --- a/src/base/types_.ml +++ b/src/base/types_.ml @@ -66,8 +66,9 @@ type statement = | Stmt_set_option of string list | Stmt_set_info of string * string | Stmt_data of data list - | Stmt_ty_decl of ID.t * int (* new atomic cstor *) - | Stmt_decl of ID.t * ty list * ty + | Stmt_ty_decl of { name: ID.t; arity: int; ty_const: ty } + (** new atomic cstor *) + | Stmt_decl of { name: ID.t; ty_args: ty list; ty_ret: ty; const: term } | Stmt_define of definition list | Stmt_assert of term | Stmt_assert_clause of term list diff --git a/src/main/main.ml b/src/main/main.ml index d1466275..58b05399 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -25,7 +25,6 @@ let p_model = ref false let check = ref false let time_limit = ref 300. let mem_limit = ref 1_000_000_000. -let restarts = ref true let p_stat = ref false let p_gc_stat = ref false let p_progress = ref false @@ -74,8 +73,6 @@ let argspec = Arg.Set check, " build, check and print the proof (if output is set), if unsat" ); "--no-check", Arg.Clear check, " inverse of -check"; - "--restarts", Arg.Set restarts, " enable restarts"; - "--no-restarts", Arg.Clear restarts, " disable restarts"; "--stat", Arg.Set p_stat, " print statistics"; "--proof", Arg.Set p_proof, " print proof"; "--no-proof", Arg.Clear p_proof, " do not print proof"; @@ -220,9 +217,8 @@ let main_smt ~config () : _ result = parse_res >>= fun input -> let driver = let asolver = Solver.Smt_solver.Solver.as_asolver solver in - Driver.create ~restarts:!restarts ~pp_cnf:!p_cnf ~time:!time_limit - ~memory:!mem_limit ~pp_model:!p_model ?proof_file ~check:!check - ~progress:!p_progress asolver + Driver.create ~pp_cnf:!p_cnf ~time:!time_limit ~memory:!mem_limit + ~pp_model:!p_model ?proof_file ~check:!check ~progress:!p_progress asolver in (* process statements *) diff --git a/src/model/dune b/src/model/dune deleted file mode 100644 index c3ffcaf7..00000000 --- a/src/model/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_model) - (public_name sidekick.model) - (synopsis "Finite models for Sidekick") - (libraries sidekick.sigs sidekick.util sidekick.core) - (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/model/sidekick_model.ml b/src/model/sidekick_model.ml deleted file mode 100644 index 7a1e90de..00000000 --- a/src/model/sidekick_model.ml +++ /dev/null @@ -1,24 +0,0 @@ -open Sidekick_core -module T = Term - -type t = { m: Term.t T.Map.t } [@@unboxed] - -let empty : t = { m = T.Map.empty } -let is_empty self = T.Map.is_empty self.m -let mem self t = T.Map.mem t self.m -let find self t = T.Map.find_opt t self.m -let eval = find -let add t v self : t = { m = T.Map.add t v self.m } -let keys self = T.Map.keys self.m -let to_iter self = T.Map.to_iter self.m - -let pp out (self : t) = - if is_empty self then - Fmt.string out "(model)" - else ( - let pp_pair out (t, v) = - Fmt.fprintf out "(@[<1>%a@ := %a@])" Term.pp t Term.pp v - in - Fmt.fprintf out "(@[model@ %a@])" (Util.pp_iter pp_pair) - (T.Map.to_iter self.m) - ) diff --git a/src/model/sidekick_model.mli b/src/model/sidekick_model.mli deleted file mode 100644 index 3f0574a9..00000000 --- a/src/model/sidekick_model.mli +++ /dev/null @@ -1,19 +0,0 @@ -(** Models - - A model can be produced when the solver is found to be in a - satisfiable state after a call to {!solve}. *) - -open Sidekick_core - -type t - -val empty : t -val is_empty : t -> bool -val mem : t -> Term.t -> bool -val find : t -> Term.t -> Term.t option -val eval : t -> Term.t -> Term.t option -val add : Term.t -> Term.t -> t -> t -val keys : t -> Term.t Iter.t -val to_iter : t -> (Term.t * Term.t) Iter.t - -include Sidekick_sigs.PRINT with type t := t diff --git a/src/sat/sigs.ml b/src/sat/sigs.ml index 5cb71d1e..dcff8d53 100644 --- a/src/sat/sigs.ml +++ b/src/sat/sigs.ml @@ -9,6 +9,8 @@ Copyright 2016 Simon Cruanes open Sidekick_core module Proof = Sidekick_proof +exception UndecidedLit + (** Solver in a "SATISFIABLE" state *) module type SAT_STATE = sig val eval : Lit.t -> bool diff --git a/src/sat/solver.ml b/src/sat/solver.ml index 061eb332..b3fd08e5 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -36,7 +36,7 @@ type unsat_cause = exception E_sat exception E_unsat of unsat_cause -exception UndecidedLit +exception UndecidedLit = Sigs.UndecidedLit exception Restart exception Conflict of clause diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index b1452b9b..61914980 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -7,7 +7,6 @@ *) module Sigs = Sigs -module Model = Sidekick_model module Model_builder = Model_builder module Registry = Registry module Solver_internal = Solver_internal diff --git a/src/smt/dune b/src/smt/dune index 3474e024..599e1ae8 100644 --- a/src/smt/dune +++ b/src/smt/dune @@ -3,6 +3,6 @@ (public_name sidekick.smt-solver) (synopsis "main SMT solver") (libraries containers iter sidekick.core sidekick.util sidekick.cc - sidekick.sat sidekick.abstract-solver sidekick.simplify sidekick.model - sidekick.proof sidekick.trace) + sidekick.sat sidekick.abstract-solver sidekick.simplify sidekick.proof + sidekick.trace) (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/smt/model_builder.ml b/src/smt/model_builder.ml index 0c2ec0ce..28a3dfc6 100644 --- a/src/smt/model_builder.ml +++ b/src/smt/model_builder.ml @@ -1,24 +1,23 @@ open Sigs module T = Term +module TM = Term.Map type t = { tst: Term.store; - mutable m: Model.t; + mutable m: Term.t TM.t; required: Term.t Queue.t; gensym: Gensym.t; } let create tst : t = - { - tst; - m = Model.empty; - required = Queue.create (); - gensym = Gensym.create tst; - } + { tst; m = TM.empty; required = Queue.create (); gensym = Gensym.create tst } let pp out (self : t) : unit = - Fmt.fprintf out "(@[model-builder@ :model %a@ :q (@[%a@])@])" Model.pp self.m - (Util.pp_iter T.pp) + let pp_kv out (k, v) = + Fmt.fprintf out "(@[%a@ := %a@])" Term.pp k Term.pp v + in + Fmt.fprintf out "(@[model-builder@ :model %a@ :q (@[%a@])@])" + (Util.pp_iter pp_kv) (TM.to_iter self.m) (Util.pp_iter T.pp) (Iter.of_queue self.required) let gensym self ~pre ~ty : Term.t = Gensym.fresh_term self.gensym ~pre ty @@ -26,33 +25,33 @@ let gensym self ~pre ~ty : Term.t = Gensym.fresh_term self.gensym ~pre ty let rec pop_required (self : t) : _ option = match Queue.take_opt self.required with | None -> None - | Some t when Model.mem self.m t -> pop_required self + | Some t when TM.mem t self.m -> pop_required self | Some t -> Some t let require_eval (self : t) t : unit = - if not @@ Model.mem self.m t then Queue.push t self.required + if not @@ TM.mem t self.m then Queue.push t self.required -let[@inline] mem self t : bool = Model.mem self.m t +let[@inline] mem self t : bool = TM.mem t self.m let add (self : t) ?(subs = []) t v : unit = if not @@ mem self t then ( - self.m <- Model.add t v self.m; + self.m <- TM.add t v self.m; List.iter (fun u -> require_eval self u) subs ) type eval_cache = Term.Internal_.cache let eval ?(cache = Term.Internal_.create_cache 8) (self : t) (t : Term.t) = - let t = Model.find self.m t |> Option.value ~default:t in + let t = TM.get t self.m |> Option.value ~default:t in T.Internal_.replace_ ~cache self.tst ~recursive:true t ~f:(fun ~recurse:_ u -> - Model.find self.m u) + TM.get u self.m) -let to_model (self : t) : Model.t = +let to_map (self : t) : _ TM.t = (* ensure we evaluate each term only once *) let cache = T.Internal_.create_cache 8 in let m = - Model.keys self.m + TM.keys self.m |> Iter.map (fun t -> t, eval ~cache self t) - |> Iter.fold (fun m (t, v) -> Model.add t v m) Model.empty + |> Iter.fold (fun m (t, v) -> TM.add t v m) TM.empty in m diff --git a/src/smt/model_builder.mli b/src/smt/model_builder.mli index 592a73c9..965ad71f 100644 --- a/src/smt/model_builder.mli +++ b/src/smt/model_builder.mli @@ -33,4 +33,4 @@ val eval : ?cache:eval_cache -> t -> Term.t -> value val pop_required : t -> Term.t option (** gives the next subterm that is required but has no value yet *) -val to_model : t -> Model.t +val to_map : t -> Term.t Term.Map.t diff --git a/src/smt/sigs.ml b/src/smt/sigs.ml index cc4732d3..9dbbdfd3 100644 --- a/src/smt/sigs.ml +++ b/src/smt/sigs.ml @@ -13,7 +13,6 @@ *) include Sidekick_core -module Model = Sidekick_model module Simplify = Sidekick_simplify module CC = Sidekick_cc.CC module E_node = Sidekick_cc.E_node diff --git a/src/smt/solver.ml b/src/smt/solver.ml index c7fff0d6..5f05640b 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -11,14 +11,30 @@ module Sat_solver = Sidekick_sat module Unknown = Sidekick_abstract_solver.Unknown [@@ocaml.warning "-37"] +type value = Term.t + +type sat_result = Check_res.sat_result = { + get_value: Term.t -> value option; (** Value for this term *) + iter_classes: (Term.t Iter.t * value) Iter.t; + (** All equivalence classes in the congruence closure *) + eval_lit: Lit.t -> bool option; (** Evaluate literal *) + iter_true_lits: Lit.t Iter.t; + (** Iterate on literals that are true in the trail *) +} +(** Satisfiable *) + +type unsat_result = Check_res.unsat_result = { + unsat_core: unit -> Lit.t Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_proof: unit -> Sidekick_proof.Step.id option; + (** Proof step for the empty clause *) +} +(** Unsatisfiable *) + +(** Result of solving for the current set of clauses *) type res = Check_res.t = - | Sat of Model.t (** Satisfiable *) - | Unsat of { - unsat_core: unit -> lit Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_proof: unit -> step_id option; - (** Proof step for the empty clause *) - } (** Unsatisfiable *) + | Sat of sat_result + | Unsat of unsat_result | Unknown of Unknown.t (** Unknown, obtained after a timeout, memory limit, etc. *) @@ -188,26 +204,57 @@ let solve ?(on_exit = []) ?(on_progress = fun _ -> ()) "(@[sidekick.smt-solver: SAT@ actual: UNKNOWN@ :reason \ incomplete-fragment@])"); Unknown Unknown.U_incomplete - | Sat_solver.Sat _ -> + | Sat_solver.Sat (module SAT) -> Log.debug 1 "(sidekick.smt-solver: SAT)"; - Log.debugf 5 (fun k -> - let ppc out n = - Fmt.fprintf out "{@[class@ %a@]}" - (Util.pp_iter ~sep:";" E_node.pp) - (E_node.iter_class n) - in - k "(@[sidekick.smt-solver.classes@ (@[%a@])@])" (Util.pp_iter ppc) - (CC.all_classes @@ Solver_internal.cc self.si)); - let m = match SI.last_model self.si with | Some m -> m | None -> assert false in + let iter_classes = + CC.all_classes (Solver_internal.cc self.si) + |> Iter.filter (fun repr -> + not @@ Term.is_pi (Term.ty @@ E_node.term repr)) + |> Iter.map (fun repr -> + let v = + match + (* find value for this class *) + Iter.find_map + (fun en -> Term.Map.get (E_node.term en) m) + (E_node.iter_class repr) + with + | None -> + Error.errorf + "(@[solver.mk-model.no-value-for-repr@ %a@ :ty %a@])" + E_node.pp repr Term.pp + (Term.ty @@ E_node.term repr) + | Some v -> v + in + let terms = E_node.iter_class repr |> Iter.map E_node.term in + terms, v) + in + + Log.debugf 5 (fun k -> + let ppc out (cls, v) = + Fmt.fprintf out "{@[class@ :value %a@ %a@]}" Term.pp v + (Util.pp_iter ~sep:";" Term.pp) + cls + in + k "(@[sidekick.smt-solver.classes@ (@[%a@])@])" (Util.pp_iter ppc) + iter_classes); + do_on_exit (); - Sat m + Sat + { + get_value = (fun t -> Term.Map.get t m); + iter_classes; + eval_lit = + (fun l -> + try Some (SAT.eval l) with Sat_solver.UndecidedLit -> None); + iter_true_lits = SAT.iter_trail; + } | Sat_solver.Unsat (module UNSAT) -> let unsat_core () = UNSAT.unsat_assumptions () in let unsat_proof () = Some (UNSAT.unsat_proof ()) in diff --git a/src/smt/solver.mli b/src/smt/solver.mli index b4be6b68..b399a077 100644 --- a/src/smt/solver.mli +++ b/src/smt/solver.mli @@ -102,15 +102,30 @@ val assert_term : t -> term -> unit val add_ty : t -> ty -> unit +type value = Term.t + +type sat_result = Check_res.sat_result = { + get_value: Term.t -> value option; (** Value for this term *) + iter_classes: (Term.t Iter.t * value) Iter.t; + (** All equivalence classes in the congruence closure *) + eval_lit: Lit.t -> bool option; (** Evaluate literal *) + iter_true_lits: Lit.t Iter.t; + (** Iterate on literals that are true in the trail *) +} +(** Satisfiable *) + +type unsat_result = Check_res.unsat_result = { + unsat_core: unit -> Lit.t Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_proof: unit -> Sidekick_proof.Step.id option; + (** Proof step for the empty clause *) +} +(** Unsatisfiable *) + (** Result of solving for the current set of clauses *) type res = Check_res.t = - | Sat of Model.t (** Satisfiable *) - | Unsat of { - unsat_core: unit -> lit Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_proof: unit -> step_id option; - (** Proof step for the empty clause *) - } (** Unsatisfiable *) + | Sat of sat_result + | Unsat of unsat_result | Unknown of Unknown.t (** Unknown, obtained after a timeout, memory limit, etc. *) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index a47e1f99..34351ee6 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -53,7 +53,7 @@ type t = { mutable model_complete: model_completion_hook list; simp: Simplify.t; delayed_actions: delayed_action Queue.t; - mutable last_model: Model.t option; + mutable last_model: Term.t Term.Map.t option; mutable th_states: th_states; (** Set of theories *) mutable level: int; mutable complete: bool; @@ -327,7 +327,7 @@ let rec pop_lvls_theories_ n = function (** {2 Model construction and theory combination} *) (* make model from the congruence closure *) -let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = +let mk_model_ (self : t) (lits : lit Iter.t) : Term.t Term.Map.t = let@ () = Profile.with_ "smt-solver.mk-model" in Log.debug 1 "(smt.solver.mk-model)"; let module MB = Model_builder in @@ -395,7 +395,7 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = in compute_fixpoint (); - MB.to_model model + MB.to_map model (* call congruence closure, perform the actions it scheduled *) let check_cc_with_acts_ (self : t) (acts : theory_actions) = diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index 479d3b1c..09f0fe74 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -270,7 +270,7 @@ val on_progress : t -> (unit, unit) Event.t val is_complete : t -> bool (** Are we still in a complete logic fragment? *) -val last_model : t -> Model.t option +val last_model : t -> Term.t Term.Map.t option (** {2 Delayed actions} *) diff --git a/src/smtlib/Driver.ml b/src/smtlib/Driver.ml index b197f0c3..e3c2b673 100644 --- a/src/smtlib/Driver.ml +++ b/src/smtlib/Driver.ml @@ -1,4 +1,3 @@ -open Sidekick_core module Profile = Sidekick_util.Profile module Proof = Sidekick_proof module Asolver = Solver.Asolver @@ -12,52 +11,10 @@ type 'a or_error = ('a, string) CCResult.t module E = CCResult module Fmt = CCFormat -(* TODO: use external proof checker instead: check-sat(φ + model) - (* check SMT model *) - let check_smt_model (solver:Solver.Sat_solver.t) (hyps:_ Vec.t) (m:Model.t) : unit = - Log.debug 1 "(smt.check-smt-model)"; - let module S = Solver.Sat_solver in - let check_atom (lit:Lit.t) : Msat.lbool = - Log.debugf 5 (fun k->k "(@[smt.check-smt-model.atom@ %a@])" Lit.pp lit); - let a = S.make_atom solver lit in - let sat_value = S.eval_atom solver a in - let t, sign = Lit.as_atom lit in - begin match Model.eval m t with - | Some (V_bool b) -> - let b = if sign then b else not b in - if (sat_value <> Msat.L_undefined) && - ((b && sat_value=Msat.L_false) || (not b && sat_value=Msat.L_true)) then ( - Error.errorf "(@[check-model.error@ :atom %a@ :model-val %B@ :sat-val %a@])" - S.Atom.pp a b Msat.pp_lbool sat_value - ) else ( - Log.debugf 5 - (fun k->k "(@[check-model@ :atom %a@ :model-val %B@ :sat-val %a@])" - S.Atom.pp a b Msat.pp_lbool sat_value); - ) - | Some v -> - Error.errorf "(@[check-model.error@ :atom %a@ :non-bool-value %a@])" - S.Atom.pp a Value.pp v - | None -> - if sat_value <> Msat.L_undefined then ( - Error.errorf "(@[check-model.error@ :atom %a@ :no-smt-value@ :sat-val %a@])" - S.Atom.pp a Msat.pp_lbool sat_value - ); - end; - sat_value - in - let check_c c = - let bs = List.map check_atom c in - if List.for_all (function Msat.L_true -> false | _ -> true) bs then ( - Error.errorf "(@[check-model.error.none-true@ :clause %a@ :vals %a@])" - (Fmt.Dump.list Lit.pp) c Fmt.(Dump.list @@ Msat.pp_lbool) bs - ); - in - Vec.iter check_c hyps -*) - type t = { progress: Progress_bar.t option; solver: Asolver.t; + build_model: Build_model.t; time_start: float; time_limit: float; memory_limit: float; @@ -65,13 +22,11 @@ type t = { pp_model: bool; pp_cnf: bool; check: bool; - restarts: bool; } (* call the solver to check-sat *) -let create ?(restarts = true) ?(pp_cnf = false) ?proof_file ?(pp_model = false) - ?(check = false) ?time ?memory ?(progress = false) (solver : Asolver.t) : t - = +let create ?(pp_cnf = false) ?proof_file ?(pp_model = false) ?(check = false) + ?time ?memory ?(progress = false) (solver : Asolver.t) : t = let time_start = now () in let progress = if progress then @@ -86,7 +41,7 @@ let create ?(restarts = true) ?(pp_cnf = false) ?proof_file ?(pp_model = false) { time_start; - restarts; + build_model = Build_model.create (); progress; solver; proof_file; @@ -97,15 +52,20 @@ let create ?(restarts = true) ?(pp_cnf = false) ?proof_file ?(pp_model = false) memory_limit; } -let decl_sort (_self : t) c n : unit = - (* TODO: more? pass to abstract solver? *) - Log.debugf 1 (fun k -> k "(@[declare-sort %a@ :arity %d@])" ID.pp c n) - -let decl_fun (_self : t) id args ret : unit = - (* TODO: more? record for model building *) +let decl_sort (self : t) c n ty_const : unit = Log.debugf 1 (fun k -> - k "(@[declare-fun %a@ :args (@[%a@])@ :ret %a@])" ID.pp id - (Util.pp_list Ty.pp) args Ty.pp ret) + k "(@[declare-sort %a@ :arity %d@ :ty-const %a@])" ID.pp c n Term.pp + ty_const); + Build_model.add_ty self.build_model ty_const + +let decl_fun (self : t) f args ret const : unit = + Log.debugf 1 (fun k -> + k "(@[declare-fun %a@ :args (@[%a@])@ :ret %a@ :const %a@])" ID.pp f + (Util.pp_list Ty.pp) args Ty.pp ret Term.pp const); + Build_model.add_fun self.build_model const + +let build_model (self : t) (sat : Solver.sat_result) : Model.t = + Build_model.build self.build_model sat (* call the solver to check satisfiability *) let solve (self : t) ~assumptions () : Solver.res = @@ -133,10 +93,12 @@ let solve (self : t) ~assumptions () : Solver.res = let t2 = now () in flush stdout; (match res with - | Asolver.Check_res.Sat m -> - if self.pp_model then + | Asolver.Check_res.Sat sat -> + if self.pp_model then ( + let m = build_model self sat in (* TODO: use actual {!Model} in the solver? or build it afterwards *) - Format.printf "(@[model@ %a@])@." Sidekick_smt_solver.Model.pp m; + Format.printf "(@[model@ %a@])@." Model.pp m + ); (* TODO if check then ( Solver.check_model s; @@ -194,8 +156,6 @@ let process_stmt (self : t) (stmt : Statement.t) : unit or_error = Log.debugf 5 (fun k -> k "(@[smtlib.process-statement@ %a@])" Statement.pp stmt); - let add_step r = Proof.Tracer.add_step (Asolver.proof self.solver) r in - match stmt with | Statement.Stmt_set_logic logic -> if not @@ List.mem logic known_logics then @@ -216,17 +176,17 @@ let process_stmt (self : t) (stmt : Statement.t) : unit or_error = in ignore (solve self ~assumptions () : Solver.res); E.return () - | Statement.Stmt_ty_decl (id, n) -> - decl_sort self id n; + | Statement.Stmt_ty_decl { name; arity; ty_const } -> + decl_sort self name arity ty_const; E.return () - | Statement.Stmt_decl (f, ty_args, ty_ret) -> - decl_fun self f ty_args ty_ret; + | Statement.Stmt_decl { name; ty_args; ty_ret; const } -> + decl_fun self name ty_args ty_ret const; E.return () | Statement.Stmt_assert t -> if self.pp_cnf then Format.printf "(@[assert@ %a@])@." Term.pp t; let lit = Asolver.lit_of_term self.solver t in - Asolver.assert_clause self.solver [| lit |] - (fun () -> Proof.Sat_rules.sat_input_clause [ lit ]); + Asolver.assert_clause self.solver [| lit |] (fun () -> + Proof.Sat_rules.sat_input_clause [ lit ]); E.return () | Statement.Stmt_assert_clause c_ts -> if self.pp_cnf then @@ -235,8 +195,7 @@ let process_stmt (self : t) (stmt : Statement.t) : unit or_error = let c = CCList.map (fun t -> Asolver.lit_of_term self.solver t) c_ts in (* proof of assert-input + preprocessing *) - let pr = - fun () -> + let pr () = let lits = List.map (Asolver.lit_of_term self.solver) c_ts in Proof.Sat_rules.sat_input_clause lits in @@ -245,16 +204,19 @@ let process_stmt (self : t) (stmt : Statement.t) : unit or_error = E.return () | Statement.Stmt_get_model -> (match Asolver.last_res self.solver with - | Some (Solver.Sat m) -> Fmt.printf "%a@." Sidekick_smt_solver.Model.pp m + | Some (Solver.Sat sat) -> + let m = build_model self sat in + Fmt.printf "%a@." Model.pp m | _ -> Error.errorf "cannot access model"); E.return () | Statement.Stmt_get_value l -> (match Asolver.last_res self.solver with - | Some (Solver.Sat m) -> + | Some (Solver.Sat sat) -> + let m = build_model self sat in let l = List.map (fun t -> - match Sidekick_smt_solver.Model.eval m t with + match Model.eval t m with | None -> Error.errorf "cannot evaluate %a" Term.pp t | Some u -> t, u) l diff --git a/src/smtlib/Driver.mli b/src/smtlib/Driver.mli index c17d061c..8ebe0292 100644 --- a/src/smtlib/Driver.mli +++ b/src/smtlib/Driver.mli @@ -21,7 +21,6 @@ type t (** The SMTLIB driver *) val create : - ?restarts:bool -> ?pp_cnf:bool -> ?proof_file:string -> ?pp_model:bool -> diff --git a/src/smtlib/Sidekick_smtlib.ml b/src/smtlib/Sidekick_smtlib.ml index cd022f0f..6bd9dea2 100644 --- a/src/smtlib/Sidekick_smtlib.ml +++ b/src/smtlib/Sidekick_smtlib.ml @@ -5,6 +5,7 @@ module Solver = Solver module Term = Sidekick_base.Term module Stmt = Sidekick_base.Statement module Check_cc = Check_cc +module Model = Model type 'a or_error = ('a, string) CCResult.t diff --git a/src/smtlib/Sidekick_smtlib.mli b/src/smtlib/Sidekick_smtlib.mli index 563d5f45..9ab2b279 100644 --- a/src/smtlib/Sidekick_smtlib.mli +++ b/src/smtlib/Sidekick_smtlib.mli @@ -11,6 +11,7 @@ module Stmt = Sidekick_base.Statement module Driver = Driver module Solver = Solver module Check_cc = Check_cc +module Model = Model val parse : Term.store -> string -> Stmt.t list or_error val parse_stdin : Term.store -> Stmt.t list or_error diff --git a/src/smtlib/Typecheck.ml b/src/smtlib/Typecheck.ml index c54a7de6..85b22398 100644 --- a/src/smtlib/Typecheck.ml +++ b/src/smtlib/Typecheck.ml @@ -457,13 +457,13 @@ and conv_statement_aux (ctx : Ctx.t) (stmt : PA.statement) : Stmt.t list = let id = ID.make s in let ty = Ty.uninterpreted tst id in Ctx.add_id_ ctx s id (Ctx.K_ty (Ctx.K_atomic ty)); - [ Stmt.Stmt_ty_decl (id, n) ] + [ Stmt.Stmt_ty_decl { name = id; arity = n; ty_const = ty } ] | PA.Stmt_decl fr -> let f, args, ret = conv_fun_decl ctx fr in let id = ID.make f in let c_f = Uconst.uconst_of_id' tst id args ret in Ctx.add_id_ ctx f id (Ctx.K_fun c_f); - [ Stmt.Stmt_decl (id, args, ret) ] + [ Stmt.Stmt_decl { name = id; ty_args = args; ty_ret = ret; const = c_f } ] | PA.Stmt_data l -> (* first, read and declare each datatype (it can occur in the other datatypes' constructors) *) @@ -572,7 +572,10 @@ and conv_statement_aux (ctx : Ctx.t) (stmt : PA.statement) : Stmt.t list = let f = Uconst.uconst_of_id tst id ret in Ctx.add_id_ ctx fun_name id (Ctx.K_fun f); let rhs = conv_term ctx fr_body in - [ Stmt.Stmt_decl (id, [], ret); Stmt.Stmt_assert (Form.eq tst f rhs) ] + [ + Stmt.Stmt_decl { name = id; ty_args = []; ty_ret = ret; const = f }; + Stmt.Stmt_assert (Form.eq tst f rhs); + ] | PA.Stmt_fun_rec _ | PA.Stmt_fun_def _ -> errorf_ctx ctx "unsupported definition: %a" PA.pp_stmt stmt | PA.Stmt_assert t -> diff --git a/src/smtlib/build_model.ml b/src/smtlib/build_model.ml new file mode 100644 index 00000000..2a5bb1ea --- /dev/null +++ b/src/smtlib/build_model.ml @@ -0,0 +1,46 @@ +open Common_ +open! Sidekick_base + +type t = { fun_symbols: unit Term.Tbl.t; ty_symbols: unit Term.Tbl.t } + +let create () : t = + { fun_symbols = Term.Tbl.create 32; ty_symbols = Term.Tbl.create 32 } + +let add_ty (self : t) ty_const : unit = Term.Tbl.add self.ty_symbols ty_const () +let add_fun (self : t) const : unit = Term.Tbl.add self.fun_symbols const () + +let build (self : t) (sat : Solver.sat_result) : Model.t = + let m = ref Model.empty in + + (* process [t], whose value is [value] in the model *) + let examine_term t ~value : unit = + let f, args = Term.unfold_app t in + + (* TODO: types *) + if Term.Tbl.mem self.fun_symbols f then ( + (* add entry for [f], to build a if-then-else tree *) + match List.map (fun t -> sat.get_value t |> Option.get) args with + | exception _ -> + Log.debugf 1 (fun k -> + k "(@[build-model.warn@ :no-entry-for %a@])" Term.pp t); + () (* TODO: warning? *) + | v_args -> + (* see if [v_args] already maps to a value *) + let other_v = Model.get_fun_entry f v_args !m in + Option.iter + (fun v' -> + if not (Term.equal value v') then + Error.errorf + "Inconsistent model@ for fun `%a`,@ values %a@ map to `%a` and \ + `%a`" + Term.pp f (Fmt.Dump.list Term.pp) v_args Term.pp value Term.pp + v') + other_v; + (* save mapping *) + m := Model.add_fun_entry f v_args value !m + ) + in + + sat.iter_classes (fun (cls, v) -> cls (fun t -> examine_term t ~value:v)); + + !m diff --git a/src/smtlib/build_model.mli b/src/smtlib/build_model.mli new file mode 100644 index 00000000..448d70e7 --- /dev/null +++ b/src/smtlib/build_model.mli @@ -0,0 +1,9 @@ +open Common_ +open! Sidekick_base + +type t + +val create : unit -> t +val add_ty : t -> Term.t -> unit +val add_fun : t -> Term.t -> unit +val build : t -> Solver.sat_result -> Model.t diff --git a/src/smtlib/dune b/src/smtlib/dune index d401450a..c2be7ab2 100644 --- a/src/smtlib/dune +++ b/src/smtlib/dune @@ -4,6 +4,5 @@ (synopsis "SMTLIB 2.6 driver for Sidekick") (private_modules Common_) (libraries containers zarith sidekick.core sidekick.util sidekick-base - sidekick.abstract-solver - sidekick.mini-cc smtlib-utils sidekick.tef) + sidekick.abstract-solver sidekick.mini-cc smtlib-utils sidekick.tef) (flags :standard -warn-error -a+8 -open Sidekick_util)) diff --git a/src/smtlib/model.ml b/src/smtlib/model.ml new file mode 100644 index 00000000..141a8fa4 --- /dev/null +++ b/src/smtlib/model.ml @@ -0,0 +1,77 @@ +open Sidekick_core +module T = Term +module TM = Term.Map + +type value = Term.t +type fun_ = Term.t + +module TL_map = CCMap.Make (struct + type t = value list + + let compare = CCList.compare Term.compare +end) + +type t = { m: value TL_map.t TM.t } [@@unboxed] + +let empty : t = { m = T.Map.empty } +let is_empty self = T.Map.is_empty self.m +let iter_fun_entries (self : t) = TM.to_iter self.m +let get_fun_entries f self = TM.get f self.m + +let get_fun_entry f vs self = + match get_fun_entries f self with + | None -> None + | Some tm -> TL_map.get vs tm + +let add_fun_entry f vs v self = + let m = TM.get_or ~default:TL_map.empty f self.m in + { m = TM.add f (TL_map.add vs v m) self.m } + +let rec eval t (self : t) : value option = + let eval_exn t = + match eval t self with + | Some v -> v + | None -> raise Not_found + in + + let f, args = Term.unfold_app t in + match List.map eval_exn args with + | exception Not_found -> None + | v_args -> get_fun_entry f v_args self + +let pp out (self : t) = + if is_empty self then + Fmt.string out "(model)" + else ( + let rec pp_entries out = function + | [] -> () + | ([], v) :: _ | [ (_, v) ] -> Term.pp out v + | ((_ :: _ as vs), v) :: tl -> + let pp_guard out () = + match vs with + | [] -> () + | [ t ] -> Fmt.fprintf out "(@[= x0 %a@])" Term.pp t + | _ -> + Fmt.fprintf out "(@[and@ "; + List.iteri + (fun i t -> Fmt.fprintf out "(@[= x%d %a@])" i Term.pp t) + vs; + Fmt.fprintf out "@])" + in + + Fmt.fprintf out "(@[ite %a@ %a@ %a@])" pp_guard () Term.pp v pp_entries + tl + in + let pp_fun out (f, entries) = + match TL_map.choose_opt entries with + | None -> () + | Some (args, v) -> + let pp_arg out (i, ty) = Fmt.fprintf out "(@[x%d %a@])" i Term.pp ty in + Fmt.fprintf out "(@[<1>define-fun %a (@[%a@])@ %a@ %a@])" Term.pp f + (Util.pp_list ~sep:"" pp_arg) + (List.mapi (fun i v -> i, Term.ty v) args) + Term.pp (Term.ty v) pp_entries (TL_map.to_list entries) + in + Fmt.fprintf out "(@[model@ %a@])" (Util.pp_iter pp_fun) + (TM.to_iter self.m) + ) diff --git a/src/smtlib/model.mli b/src/smtlib/model.mli new file mode 100644 index 00000000..39c14653 --- /dev/null +++ b/src/smtlib/model.mli @@ -0,0 +1,22 @@ +(** Models + + A model can be produced when the solver is found to be in a + satisfiable state after a call to {!solve}. *) + +open Sidekick_core + +type t +type value = Term.t +type fun_ = Term.t + +module TL_map : CCMap.S with type key = value list + +val empty : t +val is_empty : t -> bool +val add_fun_entry : fun_ -> value list -> value -> t -> t +val get_fun_entry : fun_ -> value list -> t -> value option +val get_fun_entries : fun_ -> t -> value TL_map.t option +val iter_fun_entries : t -> (fun_ * value TL_map.t) Iter.t +val eval : Term.t -> t -> value option + +include Sidekick_sigs.PRINT with type t := t