mirror of
https://github.com/c-cube/sidekick.git
synced 2025-12-08 12:15:48 -05:00
45 lines
1.5 KiB
OCaml
45 lines
1.5 KiB
OCaml
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)
|
|
| 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
|