diff --git a/src/model/dune b/src/model/dune new file mode 100644 index 00000000..c3ffcaf7 --- /dev/null +++ b/src/model/dune @@ -0,0 +1,6 @@ +(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 new file mode 100644 index 00000000..7a1e90de --- /dev/null +++ b/src/model/sidekick_model.ml @@ -0,0 +1,24 @@ +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 new file mode 100644 index 00000000..3f0574a9 --- /dev/null +++ b/src/model/sidekick_model.mli @@ -0,0 +1,19 @@ +(** 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/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index 3c0491b6..76962b08 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -7,7 +7,7 @@ *) module Sigs = Sigs -module Model = Model +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 f6d84486..ba3e9657 100644 --- a/src/smt/dune +++ b/src/smt/dune @@ -3,5 +3,5 @@ (public_name sidekick.smt-solver) (synopsis "main SMT solver") (libraries containers iter sidekick.core sidekick.util sidekick.cc - sidekick.sat sidekick.simplify) + sidekick.sat sidekick.simplify sidekick.model) (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/smt/model.ml b/src/smt/model.ml deleted file mode 100644 index d7f0ad6b..00000000 --- a/src/smt/model.ml +++ /dev/null @@ -1,28 +0,0 @@ -open Sigs - -type t = Empty | Map of term Term.Tbl.t - -let empty = Empty - -let mem = function - | Empty -> fun _ -> false - | Map tbl -> Term.Tbl.mem tbl - -let find = function - | Empty -> fun _ -> None - | Map tbl -> Term.Tbl.get tbl - -let eval = find - -let pp out = function - | Empty -> Fmt.string out "(model)" - | Map tbl -> - let pp_pair out (t, v) = - Fmt.fprintf out "(@[<1>%a@ := %a@])" Term.pp_debug t Term.pp_debug v - in - Fmt.fprintf out "(@[model@ %a@])" (Util.pp_iter pp_pair) - (Term.Tbl.to_iter tbl) - -module Internal_ = struct - let of_tbl t = Map t -end diff --git a/src/smt/model.mli b/src/smt/model.mli deleted file mode 100644 index bcabd13c..00000000 --- a/src/smt/model.mli +++ /dev/null @@ -1,18 +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 Sigs - -type t - -val empty : t -val mem : t -> term -> bool -val find : t -> term -> term option -val eval : t -> term -> term option -val pp : t Fmt.printer - -module Internal_ : sig - val of_tbl : term Term.Tbl.t -> t -end diff --git a/src/smt/model_builder.ml b/src/smt/model_builder.ml index 95995f21..0c2ec0ce 100644 --- a/src/smt/model_builder.ml +++ b/src/smt/model_builder.ml @@ -3,7 +3,7 @@ module T = Term type t = { tst: Term.store; - m: Term.t T.Tbl.t; + mutable m: Model.t; required: Term.t Queue.t; gensym: Gensym.t; } @@ -11,15 +11,14 @@ type t = { let create tst : t = { tst; - m = T.Tbl.create 8; + m = Model.empty; required = Queue.create (); gensym = Gensym.create tst; } let pp out (self : t) : unit = - let pp_pair out (t, v) = Fmt.fprintf out "(@[%a :=@ %a@])" T.pp t T.pp v in - Fmt.fprintf out "(@[model-builder@ :m (@[%a@])@ :q (@[%a@])@])" - (Util.pp_iter pp_pair) (T.Tbl.to_iter self.m) (Util.pp_iter T.pp) + Fmt.fprintf out "(@[model-builder@ :model %a@ :q (@[%a@])@])" Model.pp 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 @@ -27,33 +26,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 T.Tbl.mem self.m t -> pop_required self + | Some t when Model.mem self.m t -> pop_required self | Some t -> Some t let require_eval (self : t) t : unit = - if not @@ T.Tbl.mem self.m t then Queue.push t self.required + if not @@ Model.mem self.m t then Queue.push t self.required -let mem self t : bool = T.Tbl.mem self.m t +let[@inline] mem self t : bool = Model.mem self.m t let add (self : t) ?(subs = []) t v : unit = - if not @@ T.Tbl.mem self.m t then ( - T.Tbl.add self.m t v; + if not @@ mem self t then ( + self.m <- Model.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 = try T.Tbl.find self.m t with Not_found -> t in + let t = Model.find self.m t |> Option.value ~default:t in T.Internal_.replace_ ~cache self.tst ~recursive:true t ~f:(fun ~recurse:_ u -> - T.Tbl.find_opt self.m u) + Model.find self.m u) let to_model (self : t) : Model.t = (* ensure we evaluate each term only once *) let cache = T.Internal_.create_cache 8 in - let tbl = - T.Tbl.keys self.m + let m = + Model.keys self.m |> Iter.map (fun t -> t, eval ~cache self t) - |> T.Tbl.of_iter + |> Iter.fold (fun m (t, v) -> Model.add t v m) Model.empty in - Model.Internal_.of_tbl tbl + m diff --git a/src/smt/sigs.ml b/src/smt/sigs.ml index 9d7c871d..cdd56bea 100644 --- a/src/smt/sigs.ml +++ b/src/smt/sigs.ml @@ -13,6 +13,7 @@ *) include Sidekick_core +module Model = Sidekick_model module Simplify = Sidekick_simplify module CC = Sidekick_cc.CC module E_node = Sidekick_cc.E_node