From ab6bcf8cbeb03c4b7180f2754f65d03e10c04fd0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 15 Jul 2022 23:51:41 -0400 Subject: [PATCH 001/174] add many small sigs libraries --- src/sigs/cc/dune | 9 + src/sigs/cc/sidekick_sigs_cc.ml | 548 ++++++++++++++++++ src/sigs/cc/view.ml | 38 ++ src/sigs/cc/view.mli | 33 ++ src/sigs/lit/dune | 5 + src/sigs/lit/sidekick_sigs_lit.ml | 45 ++ src/sigs/proof-core/dune | 6 + .../proof-core/sidekick_sigs_proof_core.ml | 94 +++ src/sigs/proof-sat/dune | 6 + src/sigs/proof-sat/sidekick_sigs_proof_sat.ml | 24 + src/sigs/proof-trace/dune | 5 + .../proof-trace/sidekick_sigs_proof_trace.ml | 50 ++ src/sigs/sidekick_sigs.ml | 13 + src/sigs/term/dune | 5 + src/sigs/term/sidekick_sigs_term.ml | 80 +++ 15 files changed, 961 insertions(+) create mode 100644 src/sigs/cc/dune create mode 100644 src/sigs/cc/sidekick_sigs_cc.ml create mode 100644 src/sigs/cc/view.ml create mode 100644 src/sigs/cc/view.mli create mode 100644 src/sigs/lit/dune create mode 100644 src/sigs/lit/sidekick_sigs_lit.ml create mode 100644 src/sigs/proof-core/dune create mode 100644 src/sigs/proof-core/sidekick_sigs_proof_core.ml create mode 100644 src/sigs/proof-sat/dune create mode 100644 src/sigs/proof-sat/sidekick_sigs_proof_sat.ml create mode 100644 src/sigs/proof-trace/dune create mode 100644 src/sigs/proof-trace/sidekick_sigs_proof_trace.ml create mode 100644 src/sigs/term/dune create mode 100644 src/sigs/term/sidekick_sigs_term.ml diff --git a/src/sigs/cc/dune b/src/sigs/cc/dune new file mode 100644 index 00000000..a980964b --- /dev/null +++ b/src/sigs/cc/dune @@ -0,0 +1,9 @@ + +(library + (name sidekick_sigs_cc) + (public_name sidekick.sigs.cc) + (synopsis "Signatures for the congruence closure") + (flags :standard -open Sidekick_util) + (libraries containers iter sidekick.sigs sidekick.sigs.term + sidekick.sigs.lit sidekick.sigs.proof-trace sidekick.sigs.proof.core + sidekick.util)) diff --git a/src/sigs/cc/sidekick_sigs_cc.ml b/src/sigs/cc/sidekick_sigs_cc.ml new file mode 100644 index 00000000..6338b365 --- /dev/null +++ b/src/sigs/cc/sidekick_sigs_cc.ml @@ -0,0 +1,548 @@ +(** Main types for congruence closure *) + +module View = View + +module type TERM = Sidekick_sigs_term.S +module type LIT = Sidekick_sigs_lit.S +module type PROOF_TRACE = Sidekick_sigs_proof_trace.S + +(** Actions provided to the congruence closure. + + The congruence closure must be able to propagate literals when + it detects that they are true or false; it must also + be able to create conflicts when the set of (dis)equalities + is inconsistent *) +module type ACTIONS = sig + type term + type lit + type proof + type proof_step + + val proof : unit -> proof + + val raise_conflict : lit list -> proof_step -> 'a + (** [raise_conflict c pr] declares that [c] is a tautology of + the theory of congruence. This does not return (it should raise an + exception). + @param pr the proof of [c] being a tautology *) + + val raise_semantic_conflict : lit list -> (bool * term * term) list -> 'a + (** [raise_semantic_conflict lits same_val] declares that + the conjunction of all [lits] (literals true in current trail) and tuples + [{=,≠}, t_i, u_i] implies false. + + The [{=,≠}, t_i, u_i] are pairs of terms with the same value (if [=] / true) + or distinct value (if [≠] / false)) in the current model. + + This does not return. It should raise an exception. + *) + + val propagate : lit -> reason:(unit -> lit list * proof_step) -> unit + (** [propagate lit ~reason pr] declares that [reason() => lit] + is a tautology. + + - [reason()] should return a list of literals that are currently true. + - [lit] should be a literal of interest (see {!CC_S.set_as_lit}). + + This function might never be called, a congruence closure has the right + to not propagate and only trigger conflicts. *) +end + +(** Arguments to a congruence closure's implementation *) +module type ARG = sig + module T : TERM + module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE + + (** Arguments for the congruence closure *) + module CC : sig + val view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) View.t + (** View the term through the lens of the congruence closure *) + + val mk_lit_eq : ?sign:bool -> T.Term.store -> T.Term.t -> T.Term.t -> Lit.t + (** [mk_lit_eq store t u] makes the literal [t=u] *) + + module Proof_rules : + Sidekick_sigs_proof_core.S + with type term = T.Term.t + and type lit = Lit.t + and type step_id = Proof_trace.step_id + and type rule = Proof_trace.rule + end +end + +(** Main congruence closure signature. + + The congruence closure handles the theory QF_UF (uninterpreted + function symbols). + It is also responsible for {i theory combination}, and provides + a general framework for equality reasoning that other + theories piggyback on. + + For example, the theory of datatypes relies on the congruence closure + to do most of the work, and "only" adds injectivity/disjointness/acyclicity + lemmas when needed. + + Similarly, a theory of arrays would hook into the congruence closure and + assert (dis)equalities as needed. +*) +module type S = sig + (** first, some aliases. *) + + module T : TERM + module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE + + type term_store = T.Term.store + type term = T.Term.t + type value = term + type fun_ = T.Fun.t + type lit = Lit.t + type proof = Proof_trace.t + type proof_step = Proof_trace.step_id + + type actions = + (module ACTIONS + with type term = T.Term.t + and type lit = Lit.t + and type proof = proof + and type proof_step = proof_step) + (** Actions available to the congruence closure *) + + type t + (** The congruence closure object. + It contains a fair amount of state and is mutable + and backtrackable. *) + + (** Equivalence classes. + + An equivalence class is a set of terms that are currently equal + in the partial model built by the solver. + The class is represented by a collection of nodes, one of which is + distinguished and is called the "representative". + + All information pertaining to the whole equivalence class is stored + in this representative's node. + + When two classes become equal (are "merged"), one of the two + representatives is picked as the representative of the new class. + The new class contains the union of the two old classes' nodes. + + We also allow theories to store additional information in the + representative. This information can be used when two classes are + merged, to detect conflicts and solve equations à la Shostak. + *) + module Class : sig + type t + (** An equivalent class, containing terms that are proved + to be equal. + + A value of type [t] points to a particular term, but see + {!find} to get the representative of the class. *) + + val term : t -> term + (** Term contained in this equivalence class. + If [is_root n], then [term n] is the class' representative term. *) + + val equal : t -> t -> bool + (** Are two classes {b physically} equal? To check for + logical equality, use [CC.Class.equal (CC.find cc n1) (CC.find cc n2)] + which checks for equality of representatives. *) + + val hash : t -> int + (** An opaque hash of this node. *) + + val pp : t Fmt.printer + (** Unspecified printing of the node, for example its term, + a unique ID, etc. *) + + val is_root : t -> bool + (** Is the node a root (ie the representative of its class)? + See {!find} to get the root. *) + + val iter_class : t -> t Iter.t + (** Traverse the congruence class. + Precondition: [is_root n] (see {!find} below) *) + + val iter_parents : t -> t Iter.t + (** Traverse the parents of the class. + Precondition: [is_root n] (see {!find} below) *) + + type bitfield + (** A field in the bitfield of this node. This should only be + allocated when a theory is initialized. + + Bitfields are accessed using preallocated keys. + See {!CC_S.allocate_bitfield}. + + All fields are initially 0, are backtracked automatically, + and are merged automatically when classes are merged. *) + end + + (** Explanations + + Explanations are specialized proofs, created by the congruence closure + when asked to justify why twp terms are equal. *) + module Expl : sig + type t + + val pp : t Fmt.printer + + val mk_merge : Class.t -> Class.t -> t + (** Explanation: the nodes were explicitly merged *) + + val mk_merge_t : term -> term -> t + (** Explanation: the terms were explicitly merged *) + + val mk_lit : lit -> t + (** Explanation: we merged [t] and [u] because of literal [t=u], + or we merged [t] and [true] because of literal [t], + or [t] and [false] because of literal [¬t] *) + + val mk_same_value : Class.t -> Class.t -> t + + val mk_list : t list -> t + (** Conjunction of explanations *) + + val mk_theory : + term -> term -> (term * term * t list) list -> proof_step -> t + (** [mk_theory t u expl_sets pr] builds a theory explanation for + why [|- t=u]. It depends on sub-explanations [expl_sets] which + are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are + explanations that justify [t_i = u_i] in the current congruence closure. + + The proof [pr] is the theory lemma, of the form + [ (t_i = u_i)_i |- t=u ]. + It is resolved against each [expls_i |- t_i=u_i] obtained from + [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] + where [Gamma] is a subset of the literals asserted into the congruence + closure. + + For example for the lemma [a=b] deduced by injectivity + from [Some a=Some b] in the theory of datatypes, + the arguments would be + [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] + where [pr] is the injectivity lemma [Some a=Some b |- a=b]. + *) + end + + (** Resolved explanations. + + The congruence closure keeps explanations for why terms are in the same + class. However these are represented in a compact, cheap form. + To use these explanations we need to {b resolve} them into a + resolved explanation, typically a list of + literals that are true in the current trail and are responsible for + merges. + + However, we can also have merged classes because they have the same value + in the current model. *) + module Resolved_expl : sig + type t = { + lits: lit list; + same_value: (Class.t * Class.t) list; + pr: proof -> proof_step; + } + + val is_semantic : t -> bool + (** [is_semantic expl] is [true] if there's at least one + pair in [expl.same_value]. *) + + val pp : t Fmt.printer + end + + type node = Class.t + (** A node of the congruence closure *) + + type repr = Class.t + (** Node that is currently a representative *) + + type explanation = Expl.t + + (** {3 Accessors} *) + + val term_store : t -> term_store + val proof : t -> proof + + val find : t -> node -> repr + (** Current representative *) + + val add_term : t -> term -> node + (** Add the term to the congruence closure, if not present already. + Will be backtracked. *) + + val mem_term : t -> term -> bool + (** Returns [true] if the term is explicitly present in the congruence closure *) + + (** {3 Events} + + Events triggered by the congruence closure, to which + other plugins can subscribe. *) + + type ev_on_pre_merge = t -> actions -> Class.t -> Class.t -> Expl.t -> unit + (** [ev_on_pre_merge cc acts n1 n2 expl] is called right before [n1] + and [n2] are merged with explanation [expl]. *) + + type ev_on_post_merge = t -> actions -> Class.t -> Class.t -> unit + (** [ev_on_post_merge cc acts n1 n2] is called right after [n1] + and [n2] were merged. [find cc n1] and [find cc n2] will return + the same node. *) + + type ev_on_new_term = t -> Class.t -> term -> unit + (** [ev_on_new_term cc n t] is called whenever a new term [t] + is added to the congruence closure. Its node is [n]. *) + + type ev_on_conflict = t -> th:bool -> lit list -> unit + (** [ev_on_conflict acts ~th c] is called when the congruence + closure triggers a conflict by asserting the tautology [c]. + + @param th true if the explanation for this conflict involves + at least one "theory" explanation; i.e. some of the equations + participating in the conflict are purely syntactic theories + like injectivity of constructors. *) + + type ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit + (** [ev_on_propagate cc lit reason] is called whenever [reason() => lit] + is a propagated lemma. See {!CC_ACTIONS.propagate}. *) + + type ev_on_is_subterm = Class.t -> term -> unit + (** [ev_on_is_subterm n t] is called when [n] is a subterm of + another node for the first time. [t] is the term corresponding to + the node [n]. This can be useful for theory combination. *) + + val create : + ?stat:Stat.t -> + ?on_pre_merge:ev_on_pre_merge list -> + ?on_post_merge:ev_on_post_merge list -> + ?on_new_term:ev_on_new_term list -> + ?on_conflict:ev_on_conflict list -> + ?on_propagate:ev_on_propagate list -> + ?on_is_subterm:ev_on_is_subterm list -> + ?size:[ `Small | `Big ] -> + term_store -> + proof -> + t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. *) + + val allocate_bitfield : descr:string -> t -> Class.bitfield + (** Allocate a new node field (see {!Class.bitfield}). + + This field descriptor is henceforth reserved for all nodes + in this congruence closure, and can be set using {!set_bitfield} + for each node individually. + This can be used to efficiently store some metadata on nodes + (e.g. "is there a numeric value in the class" + or "is there a constructor term in the class"). + + There may be restrictions on how many distinct fields are allocated + for a given congruence closure (e.g. at most {!Sys.int_size} fields). + *) + + val get_bitfield : t -> Class.bitfield -> Class.t -> bool + (** Access the bit field of the given node *) + + val set_bitfield : t -> Class.bitfield -> bool -> Class.t -> unit + (** Set the bitfield for the node. This will be backtracked. + See {!Class.bitfield}. *) + + (* TODO: remove? this is managed by the solver anyway? *) + val on_pre_merge : t -> ev_on_pre_merge -> unit + (** Add a function to be called when two classes are merged *) + + val on_post_merge : t -> ev_on_post_merge -> unit + (** Add a function to be called when two classes are merged *) + + val on_new_term : t -> ev_on_new_term -> unit + (** Add a function to be called when a new node is created *) + + val on_conflict : t -> ev_on_conflict -> unit + (** Called when the congruence closure finds a conflict *) + + val on_propagate : t -> ev_on_propagate -> unit + (** Called when the congruence closure propagates a literal *) + + val on_is_subterm : t -> ev_on_is_subterm -> unit + (** Called on terms that are subterms of function symbols *) + + val set_as_lit : t -> Class.t -> lit -> unit + (** map the given node to a literal. *) + + val find_t : t -> term -> repr + (** Current representative of the term. + @raise Class.t_found if the term is not already {!add}-ed. *) + + val add_iter : t -> term Iter.t -> unit + (** Add a sequence of terms to the congruence closure *) + + val all_classes : t -> repr Iter.t + (** All current classes. This is costly, only use if there is no other solution *) + + val assert_lit : t -> lit -> unit + (** Given a literal, assume it in the congruence closure and propagate + its consequences. Will be backtracked. + + Useful for the theory combination or the SAT solver's functor *) + + val assert_lits : t -> lit Iter.t -> unit + (** Addition of many literals *) + + val explain_eq : t -> Class.t -> Class.t -> Resolved_expl.t + (** Explain why the two nodes are equal. + Fails if they are not, in an unspecified way. *) + + val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a + (** Raise a conflict with the given explanation. + It must be a theory tautology that [expl ==> absurd]. + To be used in theories. + + This fails in an unspecified way if the explanation, once resolved, + satisfies {!Resolved_expl.is_semantic}. *) + + val n_true : t -> Class.t + (** Node for [true] *) + + val n_false : t -> Class.t + (** Node for [false] *) + + val n_bool : t -> bool -> Class.t + (** Node for either true or false *) + + val merge : t -> Class.t -> Class.t -> Expl.t -> unit + (** Merge these two nodes given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + + val merge_t : t -> term -> term -> Expl.t -> unit + (** Shortcut for adding + merging *) + + val set_model_value : t -> term -> value -> unit + (** Set the value of a term in the model. *) + + val with_model_mode : t -> (unit -> 'a) -> 'a + (** Enter model combination mode. *) + + val get_model_for_each_class : t -> (repr * Class.t Iter.t * value) Iter.t + (** In model combination mode, obtain classes with their values. *) + + val check : t -> actions -> unit + (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. + Will use the {!actions} to propagate literals, declare conflicts, etc. *) + + val push_level : t -> unit + (** Push backtracking level *) + + val pop_levels : t -> int -> unit + (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) + + val get_model : t -> Class.t Iter.t Iter.t + (** get all the equivalence classes so they can be merged in the model *) + + (**/**) + + module Debug_ : sig + val pp : t Fmt.printer + (** Print the whole CC *) + end + + (**/**) +end + +(* TODO: full EGG, also have a function to update the value when + the subterms (produced in [of_term]) are updated *) + +(** Data attached to the congruence closure classes. + + This helps theories keeping track of some state for each class. + The state of a class is the monoidal combination of the state for each + term in the class (for example, the set of terms in the + class whose head symbol is a datatype constructor). *) +module type MONOID_ARG = sig + module CC : S + + type t + (** Some type with a monoid structure *) + + include Sidekick_sigs.PRINT with type t := t + + val name : string + (** name of the monoid structure (short) *) + + val of_term : + CC.t -> CC.Class.t -> CC.term -> t option * (CC.Class.t * t) list + (** [of_term n t], where [t] is the term annotating node [n], + must return [maybe_m, l], where: + + - [maybe_m = Some m] if [t] has monoid value [m]; + otherwise [maybe_m=None] + - [l] is a list of [(u, m_u)] where each [u]'s term + is a direct subterm of [t] + and [m_u] is the monoid value attached to [u]. + + *) + + val merge : + CC.t -> + CC.Class.t -> + t -> + CC.Class.t -> + t -> + CC.Expl.t -> + (t, CC.Expl.t) result + (** Monoidal combination of two values. + + [merge cc n1 mon1 n2 mon2 expl] returns the result of merging + monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) + when [n1] and [n2] are merged with explanation [expl]. + + @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; + or [Error expl'] if the merge is unsatisfiable. [expl'] can then be + used to trigger a conflict and undo the merge. + *) +end + +(** Stateful plugin holding a per-equivalence-class monoid. + + Helps keep track of monoid state per equivalence class. + A theory might use one or more instance(s) of this to + aggregate some theory-specific state over all terms, with + the information of what terms are already known to be equal + potentially saving work for the theory. *) +module type PLUGIN = sig + module CC : S + module M : MONOID_ARG with module CC = CC + + val push_level : unit -> unit + (** Push backtracking point *) + + val pop_levels : int -> unit + (** Pop [n] backtracking points *) + + val n_levels : unit -> int + + val mem : CC.Class.t -> bool + (** Does the CC node have a monoid value? *) + + val get : CC.Class.t -> M.t option + (** Get monoid value for this CC node, if any *) + + val iter_all : (CC.repr * M.t) Iter.t +end + +(** Builder for a plugin. + + The builder takes a congruence closure, and instantiate the + plugin on it. *) +module type PLUGIN_BUILDER = sig + module M : MONOID_ARG + + module type PL = PLUGIN with module CC = M.CC and module M = M + + type plugin = (module PL) + + val create_and_setup : ?size:int -> M.CC.t -> plugin + (** Create a new monoid state *) +end diff --git a/src/sigs/cc/view.ml b/src/sigs/cc/view.ml new file mode 100644 index 00000000..e319f5ef --- /dev/null +++ b/src/sigs/cc/view.ml @@ -0,0 +1,38 @@ +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't +(* do not enter *) + +let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = + match v with + | Bool b -> Bool b + | App_fun (f, args) -> App_fun (f_f f, f_ts args) + | App_ho (f, a) -> App_ho (f_t f, f_t a) + | Not t -> Not (f_t t) + | If (a, b, c) -> If (f_t a, f_t b, f_t c) + | Eq (a, b) -> Eq (f_t a, f_t b) + | Opaque t -> Opaque (f_t t) + +let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = + match v with + | Bool _ -> () + | App_fun (f, args) -> + f_f f; + f_ts args + | App_ho (f, a) -> + f_t f; + f_t a + | Not t -> f_t t + | If (a, b, c) -> + f_t a; + f_t b; + f_t c + | Eq (a, b) -> + f_t a; + f_t b + | Opaque t -> f_t t diff --git a/src/sigs/cc/view.mli b/src/sigs/cc/view.mli new file mode 100644 index 00000000..038ea1a6 --- /dev/null +++ b/src/sigs/cc/view.mli @@ -0,0 +1,33 @@ +(** View terms through the lens of the Congruence Closure *) + +(** A view of a term fron the point of view of the congruence closure. + + - ['f] is the type of function symbols + - ['t] is the type of terms + - ['ts] is the type of sequences of terms (arguments of function application) + *) +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't (** do not enter *) + +val map_view : + f_f:('a -> 'b) -> + f_t:('c -> 'd) -> + f_ts:('e -> 'f) -> + ('a, 'c, 'e) t -> + ('b, 'd, 'f) t +(** Map function over a view, one level deep. + Each function maps over a different type, e.g. [f_t] maps over terms *) + +val iter_view : + f_f:('a -> unit) -> + f_t:('b -> unit) -> + f_ts:('c -> unit) -> + ('a, 'b, 'c) t -> + unit +(** Iterate over a view, one level deep. *) diff --git a/src/sigs/lit/dune b/src/sigs/lit/dune new file mode 100644 index 00000000..3774c2ba --- /dev/null +++ b/src/sigs/lit/dune @@ -0,0 +1,5 @@ +(library + (name sidekick_sigs_lit) + (public_name sidekick.sigs.lit) + (synopsis "Common definition for literals") + (libraries containers iter sidekick.sigs sidekick.sigs.term)) diff --git a/src/sigs/lit/sidekick_sigs_lit.ml b/src/sigs/lit/sidekick_sigs_lit.ml new file mode 100644 index 00000000..4acc4277 --- /dev/null +++ b/src/sigs/lit/sidekick_sigs_lit.ml @@ -0,0 +1,45 @@ +(** Literals + + Literals are a pair of a boolean-sorted term, and a sign. + Positive literals are the same as their term, and negative literals + are the negation of their term. + + The SAT solver deals only in literals and clauses (sets of literals). + Everything else belongs in the SMT solver. *) + +module type TERM = Sidekick_sigs_term.S + +module type S = sig + module T : TERM + (** Literals depend on terms *) + + type t + (** A literal *) + + include Sidekick_sigs.EQ_HASH_PRINT with type t := t + + val term : t -> T.Term.t + (** Get the (positive) term *) + + val sign : t -> bool + (** Get the sign. A negated literal has sign [false]. *) + + val neg : t -> t + (** Take negation of literal. [sign (neg lit) = not (sign lit)]. *) + + val abs : t -> t + (** [abs lit] is like [lit] but always positive, i.e. [sign (abs lit) = true] *) + + val signed_term : t -> T.Term.t * bool + (** Return the atom and the sign *) + + val atom : ?sign:bool -> T.Term.store -> T.Term.t -> t + (** [atom store t] makes a literal out of a term, possibly normalizing + its sign in the process. + @param sign if provided, and [sign=false], negate the resulting lit. *) + + val norm_sign : t -> t * bool + (** [norm_sign (+t)] is [+t, true], + and [norm_sign (-t)] is [+t, false]. + In both cases the term is positive, and the boolean reflects the initial sign. *) +end diff --git a/src/sigs/proof-core/dune b/src/sigs/proof-core/dune new file mode 100644 index 00000000..8eb404e9 --- /dev/null +++ b/src/sigs/proof-core/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_sigs_proof_core) + (public_name sidekick.sigs.proof.core) + (synopsis "Common rules for proof traces") + (flags :standard -open Sidekick_util) + (libraries containers iter sidekick.util sidekick.sigs)) diff --git a/src/sigs/proof-core/sidekick_sigs_proof_core.ml b/src/sigs/proof-core/sidekick_sigs_proof_core.ml new file mode 100644 index 00000000..7bc87bb2 --- /dev/null +++ b/src/sigs/proof-core/sidekick_sigs_proof_core.ml @@ -0,0 +1,94 @@ +(** Proof rules for common operations and congruence closure *) + +module type S = sig + type rule + type term + type lit + + type step_id + (** Identifier for a proof proof_rule (like a unique ID for a clause previously + added/proved) *) + + val lemma_cc : lit Iter.t -> rule + (** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory + of uninterpreted functions. *) + + val define_term : term -> term -> rule + (** [define_term cst u proof] defines the new constant [cst] as being equal + to [u]. + The result is a proof of the clause [cst = u] *) + + val proof_p1 : step_id -> step_id -> rule + (** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) + and [p2] proves [C \/ t], is the rule that produces [C \/ u], + i.e unit paramodulation. *) + + val proof_r1 : step_id -> step_id -> rule + (** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) + and [p2] proves [C \/ ¬t], is the rule that produces [C \/ u], + i.e unit resolution. *) + + val proof_res : pivot:term -> step_id -> step_id -> rule + (** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] + and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], + is the rule that produces [C \/ D], i.e boolean resolution. *) + + val with_defs : step_id -> step_id Iter.t -> rule + (** [with_defs pr defs] specifies that [pr] is valid only in + a context where the definitions [defs] are present. *) + + val lemma_true : term -> rule + (** [lemma_true (true) p] asserts the clause [(true)] *) + + val lemma_preprocess : term -> term -> using:step_id Iter.t -> rule + (** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology + and that [t] has been preprocessed into [u]. + + The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence + closure, and then resolved against the clauses [using] to obtain + a unit equality. + + From now on, [t] and [u] will be used interchangeably. + @return a rule ID for the clause [(t=u)]. *) + + val lemma_rw_clause : + step_id -> res:lit Iter.t -> using:step_id Iter.t -> rule + (** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], + uses the equations [|- p_i = q_i] from [using] + to rewrite some literals of [c] into [res]. This is used to preprocess + literals of a clause (using {!lemma_preprocess} individually). *) +end + +type ('rule, 'step_id, 'term, 'lit) t = + (module S + with type rule = 'rule + and type step_id = 'step_id + and type term = 'term + and type lit = 'lit) + +(** Make a dummy proof with given types *) +module Dummy (A : sig + type rule + type step_id + type term + type lit + + val dummy_rule : rule +end) : + S + with type rule = A.rule + and type step_id = A.step_id + and type term = A.term + and type lit = A.lit = struct + include A + + let lemma_cc _ = dummy_rule + let define_term _ _ = dummy_rule + let proof_p1 _ _ = dummy_rule + let proof_r1 _ _ = dummy_rule + let proof_res ~pivot:_ _ _ = dummy_rule + let with_defs _ _ = dummy_rule + let lemma_true _ = dummy_rule + let lemma_preprocess _ _ ~using:_ = dummy_rule + let lemma_rw_clause _ ~res:_ ~using:_ = dummy_rule +end diff --git a/src/sigs/proof-sat/dune b/src/sigs/proof-sat/dune new file mode 100644 index 00000000..baa7cc5f --- /dev/null +++ b/src/sigs/proof-sat/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_sigs_proof_sat) + (public_name sidekick.sigs.proof.sat) + (synopsis "SAT-solving rules for proof traces") + (flags :standard -open Sidekick_util) + (libraries containers iter sidekick.util sidekick.sigs)) diff --git a/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml b/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml new file mode 100644 index 00000000..5e81fafc --- /dev/null +++ b/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml @@ -0,0 +1,24 @@ +(** Signature for SAT-solver proof emission. *) +module type S = sig + type rule + (** The stored proof (possibly nil, possibly on disk, possibly in memory) *) + + type step_id + (** identifier for a proof *) + + type lit + (** A boolean literal for the proof trace *) + + val sat_input_clause : lit Iter.t -> rule + (** Emit an input clause. *) + + val sat_redundant_clause : lit Iter.t -> hyps:step_id Iter.t -> rule + (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. + The clause must be RUP wrt [hyps]. *) + + (* FIXME: goes in proof trace itself? not exactly a rule… + val sat_unsat_core : lit Iter.t -> rule + (** Produce a proof of the empty clause given this subset of the assumptions. + FIXME: probably needs the list of proof_step that disprove the lits? *) + *) +end diff --git a/src/sigs/proof-trace/dune b/src/sigs/proof-trace/dune new file mode 100644 index 00000000..19c97cd6 --- /dev/null +++ b/src/sigs/proof-trace/dune @@ -0,0 +1,5 @@ +(library + (name sidekick_sigs_proof_trace) + (public_name sidekick.sigs.proof-trace) + (synopsis "Common definition for proof traces") + (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml b/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml new file mode 100644 index 00000000..012957c3 --- /dev/null +++ b/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml @@ -0,0 +1,50 @@ +(** Proof traces. +*) + +open Sidekick_util + +module type S = sig + type rule + + type step_id + (** Identifier for a tracing step (like a unique ID for a clause previously + added/proved) *) + + module Step_vec : Vec_sig.BASE with type t = step_id + (** A vector indexed by steps. *) + + (** The proof trace itself. + + A proof trace is a log of all deductive steps taken by the solver, + so we can later reconstruct a certificate for proof-checking. + + Each step in the proof trace should be a {b valid + lemma} (of its theory) or a {b valid consequence} of previous steps. + *) + module type PROOF_TRACE = sig + val enabled : unit -> bool + (** Is proof tracing enabled? *) + + val add_step : rule -> step_id + (** Create a new step in the trace. *) + + val add_unsat : step_id -> unit + (** Signal "unsat" result at the given proof *) + + val delete : step_id -> unit + (** Forget a step that won't be used in the rest of the trace. + Only useful for performance/memory considerations. *) + end + + type t = (module PROOF_TRACE) +end + +module Utils_ (Trace : S) = struct + let[@inline] enabled ((module Tr) : Trace.t) : bool = Tr.enabled () + + let[@inline] add_step ((module Tr) : Trace.t) rule : Trace.step_id = + Tr.add_step rule + + let[@inline] add_unsat ((module Tr) : Trace.t) s : unit = Tr.add_unsat s + let[@inline] delete ((module Tr) : Trace.t) s : unit = Tr.delete s +end diff --git a/src/sigs/sidekick_sigs.ml b/src/sigs/sidekick_sigs.ml index d6c46ab5..8fb16dd9 100644 --- a/src/sigs/sidekick_sigs.ml +++ b/src/sigs/sidekick_sigs.ml @@ -24,4 +24,17 @@ module type PRINT = sig val pp : t CCFormat.printer end +module type EQ_HASH_PRINT = sig + include EQ + include HASH with type t := t + include PRINT with type t := t +end + +module type EQ_ORD_HASH_PRINT = sig + include EQ + include ORD with type t := t + include HASH with type t := t + include PRINT with type t := t +end + type 'a printer = Format.formatter -> 'a -> unit diff --git a/src/sigs/term/dune b/src/sigs/term/dune new file mode 100644 index 00000000..3c461792 --- /dev/null +++ b/src/sigs/term/dune @@ -0,0 +1,5 @@ +(library + (name sidekick_sigs_term) + (public_name sidekick.sigs.term) + (synopsis "Common definition for terms and types") + (libraries containers iter sidekick.sigs)) diff --git a/src/sigs/term/sidekick_sigs_term.ml b/src/sigs/term/sidekick_sigs_term.ml new file mode 100644 index 00000000..bf82f0c7 --- /dev/null +++ b/src/sigs/term/sidekick_sigs_term.ml @@ -0,0 +1,80 @@ +(** Main representation of Terms and Types *) +module type S = sig + module Fun : Sidekick_sigs.EQ_HASH_PRINT + (** A function symbol, like "f" or "plus" or "is_human" or "socrates" *) + + (** Types + + Types should be comparable (ideally, in O(1)), and have + at least a boolean type available. *) + module Ty : sig + include Sidekick_sigs.EQ_HASH_PRINT + + type store + + val bool : store -> t + val is_bool : t -> bool + end + + (** Term structure. + + Terms should be {b hashconsed}, with perfect sharing. + This allows, for example, {!Term.Tbl} and {!Term.iter_dag} to be efficient. + *) + module Term : sig + include Sidekick_sigs.EQ_ORD_HASH_PRINT + + type store + (** A store used to create new terms. It is where the hashconsing + table should live, along with other all-terms related store. *) + + val ty : t -> Ty.t + + val bool : store -> bool -> t + (** build true/false *) + + val as_bool : t -> bool option + (** [as_bool t] is [Some true] if [t] is the term [true], and similarly + for [false]. For other terms it is [None]. *) + + val abs : store -> t -> t * bool + (** [abs t] returns an "absolute value" for the term, along with the + sign of [t]. + + The idea is that we want to turn [not a] into [(a, false)], + or [(a != b)] into [(a=b, false)]. For terms without a negation this + should return [(t, true)]. + + The store is passed in case a new term needs to be created. *) + + val map_shallow : store -> (t -> t) -> t -> t + (** Map function on immediate subterms. This should not be recursive. *) + + val iter_shallow : store -> (t -> unit) -> t -> unit + (** Iterate function on immediate subterms. This should not be recursive. *) + + val iter_dag : t -> (t -> unit) -> unit + (** [iter_dag t f] calls [f] once on each subterm of [t], [t] included. + It must {b not} traverse [t] as a tree, but rather as a + perfectly shared DAG. + + For example, in: + {[ + let x = 2 in + let y = f x x in + let z = g y x in + z = z + ]} + + the DAG has the following nodes: + + {[ n1: 2 + n2: f n1 n1 + n3: g n2 n1 + n4: = n3 n3 + ]} + *) + + module Tbl : CCHashtbl.S with type key = t + end +end From 633a658e0c0c94e4d1611fb85410515c3d64ea8a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 15 Jul 2022 23:51:53 -0400 Subject: [PATCH 002/174] wip: use new sigs --- src/cc/Sidekick_cc.ml | 411 ++++++++---- src/cc/Sidekick_cc.mli | 21 +- src/cc/dune | 2 +- src/core/Sidekick_core.ml | 1021 +----------------------------- src/core/dune | 4 +- src/mini-cc/Sidekick_mini_cc.ml | 6 +- src/mini-cc/Sidekick_mini_cc.mli | 8 +- src/mini-cc/dune | 2 +- 8 files changed, 326 insertions(+), 1149 deletions(-) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 606cd5b5..d2f1ea2f 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,41 +1,37 @@ -open Sidekick_core -module View = Sidekick_core.CC_view +include Sidekick_sigs_cc +open View -type ('f, 't, 'ts) view = ('f, 't, 'ts) View.t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't -(* do not enter *) - -module type S = Sidekick_core.CC_S - -module Make (A : CC_ARG) : +module Make (A : ARG) : S with module T = A.T and module Lit = A.Lit - and type proof = A.proof - and type proof_step = A.proof_step - and module Actions = A.Actions = struct + and module Proof_trace = A.Proof_trace = struct module T = A.T module Lit = A.Lit - module Actions = A.Actions - module P = Actions.P + module Proof_trace = A.Proof_trace + module Term = T.Term + module Fun = T.Fun + + open struct + (* proof rules *) + module Rules_ = A.CC.Proof_rules + module P = Sidekick_sigs_proof_trace.Utils_ (Proof_trace) + end type term = T.Term.t type value = term type term_store = T.Term.store type lit = Lit.t type fun_ = T.Fun.t - type proof = A.proof - type proof_step = A.proof_step - type actions = Actions.t + type proof = A.Proof_trace.t + type proof_step = A.Proof_trace.step_id - module Term = T.Term - module Fun = T.Fun + type actions = + (module ACTIONS + with type term = T.Term.t + and type lit = Lit.t + and type proof = proof + and type proof_step = proof_step) module Bits : sig type t = private int @@ -97,7 +93,7 @@ module Make (A : CC_ARG) : An equivalence class is represented by its "root" element, the representative. *) - and signature = (fun_, node, node list) view + and signature = (fun_, node, node list) View.t and explanation_forest_link = | FL_none @@ -117,7 +113,7 @@ module Make (A : CC_ARG) : type repr = node - module N = struct + module Class = struct type t = node let[@inline] equal (n1 : t) n2 = n1 == n2 @@ -171,11 +167,11 @@ module Make (A : CC_ARG) : (* non-recursive, inlinable function for [find] *) let[@inline] find_ (n : node) : repr = let n2 = n.n_root in - assert (N.is_root n2); + assert (Class.is_root n2); n2 let[@inline] same_class (n1 : node) (n2 : node) : bool = - N.equal (find_ n1) (find_ n2) + Class.equal (find_ n1) (find_ n2) let[@inline] find _ n = find_ n @@ -187,8 +183,9 @@ module Make (A : CC_ARG) : | E_trivial -> Fmt.string out "reduction" | E_lit lit -> Lit.pp out lit | E_congruence (n1, n2) -> - Fmt.fprintf out "(@[congruence@ %a@ %a@])" N.pp n1 N.pp n2 - | E_merge (a, b) -> Fmt.fprintf out "(@[merge@ %a@ %a@])" N.pp a N.pp b + Fmt.fprintf out "(@[congruence@ %a@ %a@])" Class.pp n1 Class.pp n2 + | E_merge (a, b) -> + Fmt.fprintf out "(@[merge@ %a@ %a@])" Class.pp a Class.pp b | E_merge_t (a, b) -> Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp a Term.pp b @@ -199,13 +196,13 @@ module Make (A : CC_ARG) : es | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b | E_same_val (n1, n2) -> - Fmt.fprintf out "(@[same-value@ %a@ %a@])" N.pp n1 N.pp n2 + Fmt.fprintf out "(@[same-value@ %a@ %a@])" Class.pp n1 Class.pp n2 let mk_trivial : t = E_trivial let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) let[@inline] mk_merge a b : t = - if N.equal a b then + if Class.equal a b then mk_trivial else E_merge (a, b) @@ -220,7 +217,7 @@ module Make (A : CC_ARG) : let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) let[@inline] mk_same_value t u = - if N.equal t u then + if Class.equal t u then mk_trivial else E_same_val (t, u) @@ -239,7 +236,7 @@ module Make (A : CC_ARG) : module Resolved_expl = struct type t = { lits: lit list; - same_value: (N.t * N.t) list; + same_value: (Class.t * Class.t) list; pr: proof -> proof_step; } @@ -256,7 +253,7 @@ module Make (A : CC_ARG) : let { lits; same_value; pr = _ } = self in Fmt.fprintf out "(@[resolved-expl@ (@[%a@])@ :same-val (@[%a@])@])" (Util.pp_list Lit.pp) lits - (Util.pp_list @@ Fmt.Dump.pair N.pp N.pp) + (Util.pp_list @@ Fmt.Dump.pair Class.pp Class.pp) same_value ) end @@ -271,13 +268,14 @@ module Make (A : CC_ARG) : | Bool b1, Bool b2 -> b1 = b2 | App_fun (f1, []), App_fun (f2, []) -> Fun.equal f1 f2 | App_fun (f1, l1), App_fun (f2, l2) -> - Fun.equal f1 f2 && CCList.equal N.equal l1 l2 - | App_ho (f1, a1), App_ho (f2, a2) -> N.equal f1 f2 && N.equal a1 a2 - | Not a, Not b -> N.equal a b + Fun.equal f1 f2 && CCList.equal Class.equal l1 l2 + | App_ho (f1, a1), App_ho (f2, a2) -> + Class.equal f1 f2 && Class.equal a1 a2 + | Not a, Not b -> Class.equal a b | If (a1, b1, c1), If (a2, b2, c2) -> - N.equal a1 a2 && N.equal b1 b2 && N.equal c1 c2 - | Eq (a1, b1), Eq (a2, b2) -> N.equal a1 a2 && N.equal b1 b2 - | Opaque u1, Opaque u2 -> N.equal u1 u2 + Class.equal a1 a2 && Class.equal b1 b2 && Class.equal c1 c2 + | Eq (a1, b1), Eq (a2, b2) -> Class.equal a1 a2 && Class.equal b1 b2 + | Opaque u1, Opaque u2 -> Class.equal u1 u2 | Bool _, _ | App_fun _, _ | App_ho _, _ @@ -291,24 +289,25 @@ module Make (A : CC_ARG) : let module H = CCHash in match s with | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list N.hash l) - | App_ho (f, a) -> H.combine3 30 (N.hash f) (N.hash a) - | Eq (a, b) -> H.combine3 40 (N.hash a) (N.hash b) - | Opaque u -> H.combine2 50 (N.hash u) - | If (a, b, c) -> H.combine4 60 (N.hash a) (N.hash b) (N.hash c) - | Not u -> H.combine2 70 (N.hash u) + | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list Class.hash l) + | App_ho (f, a) -> H.combine3 30 (Class.hash f) (Class.hash a) + | Eq (a, b) -> H.combine3 40 (Class.hash a) (Class.hash b) + | Opaque u -> H.combine2 50 (Class.hash u) + | If (a, b, c) -> + H.combine4 60 (Class.hash a) (Class.hash b) (Class.hash c) + | Not u -> H.combine2 70 (Class.hash u) let pp out = function | Bool b -> Fmt.bool out b | App_fun (f, []) -> Fun.pp out f | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list N.pp) l - | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" N.pp f N.pp a - | Opaque t -> N.pp out t - | Not u -> Fmt.fprintf out "(@[not@ %a@])" N.pp u - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" N.pp a N.pp b + Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list Class.pp) l + | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" Class.pp f Class.pp a + | Opaque t -> Class.pp out t + | Not u -> Fmt.fprintf out "(@[not@ %a@])" Class.pp u + | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" Class.pp a Class.pp b | If (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" N.pp a N.pp b N.pp c + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" Class.pp a Class.pp b Class.pp c end module Sig_tbl = CCHashtbl.Make (Signature) @@ -360,12 +359,12 @@ module Make (A : CC_ARG) : several times. See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) - and ev_on_pre_merge = t -> actions -> N.t -> N.t -> Expl.t -> unit - and ev_on_post_merge = t -> actions -> N.t -> N.t -> unit - and ev_on_new_term = t -> N.t -> term -> unit + and ev_on_pre_merge = t -> actions -> Class.t -> Class.t -> Expl.t -> unit + and ev_on_post_merge = t -> actions -> Class.t -> Class.t -> unit + and ev_on_new_term = t -> Class.t -> term -> unit and ev_on_conflict = t -> th:bool -> lit list -> unit and ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit - and ev_on_is_subterm = N.t -> term -> unit + and ev_on_is_subterm = Class.t -> term -> unit let[@inline] size_ (r : repr) = r.n_size let[@inline] n_true cc = Lazy.force cc.true_ @@ -387,13 +386,13 @@ module Make (A : CC_ARG) : let[@inline] on_backtrack cc f : unit = Backtrack_stack.push_if_nonzero_level cc.undo f - let[@inline] get_bitfield _cc field n = N.get_field field n + let[@inline] get_bitfield _cc field n = Class.get_field field n let set_bitfield cc field b n = - let old = N.get_field field n in + let old = Class.get_field field n in if old <> b then ( - on_backtrack cc (fun () -> N.set_field field old n); - N.set_field field b n + on_backtrack cc (fun () -> Class.set_field field old n); + Class.set_field field b n ) (* check if [t] is in the congruence closure. @@ -402,24 +401,26 @@ module Make (A : CC_ARG) : (* print full state *) let pp_full out (cc : t) : unit = - let pp_next out n = Fmt.fprintf out "@ :next %a" N.pp n.n_next in + let pp_next out n = Fmt.fprintf out "@ :next %a" Class.pp n.n_next in let pp_root out n = - if N.is_root n then + if Class.is_root n then Fmt.string out " :is-root" else - Fmt.fprintf out "@ :root %a" N.pp n.n_root + Fmt.fprintf out "@ :root %a" Class.pp n.n_root in let pp_expl out n = match n.n_expl with | FL_none -> () | FL_some e -> - Fmt.fprintf out " (@[:forest %a :expl %a@])" N.pp e.next Expl.pp e.expl + Fmt.fprintf out " (@[:forest %a :expl %a@])" Class.pp e.next Expl.pp + e.expl in let pp_n out n = Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp n.n_term pp_root n pp_next n pp_expl n and pp_sig_e out (s, n) = - Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s N.pp n pp_root n + Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s Class.pp n pp_root + n in Fmt.fprintf out "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ %a@])@])" @@ -441,19 +442,19 @@ module Make (A : CC_ARG) : let add_signature cc (s : signature) (n : node) : unit = assert (not @@ Sig_tbl.mem cc.signatures_tbl s); Log.debugf 50 (fun k -> - k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s N.pp n); + k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s Class.pp n); on_backtrack cc (fun () -> Sig_tbl.remove cc.signatures_tbl s); Sig_tbl.add cc.signatures_tbl s n let push_pending cc t : unit = - Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" N.pp t); + Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" Class.pp t); Vec.push cc.pending t let merge_classes cc t u e : unit = if t != u && not (same_class t u) then ( Log.debugf 50 (fun k -> - k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" N.pp t N.pp u - Expl.pp e); + k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" Class.pp t Class.pp + u Expl.pp e); Vec.push cc.combine @@ CT_merge (t, u, e) ) @@ -477,10 +478,11 @@ module Make (A : CC_ARG) : Vec.clear cc.combine; List.iter (fun f -> f cc ~th e) cc.on_conflict; Stat.incr cc.count_conflict; - Actions.raise_conflict acts e p + let (module A) = acts in + A.raise_conflict e p let[@inline] all_classes cc : repr Iter.t = - T_tbl.values cc.tbl |> Iter.filter N.is_root + T_tbl.values cc.tbl |> Iter.filter Class.is_root (* find the closest common ancestor of [a] and [b] in the proof forest. @@ -494,7 +496,7 @@ module Make (A : CC_ARG) : let find_common_ancestor cc (a : node) (b : node) : node = (* catch up to the other node *) let rec find1 a = - if N.get_field cc.field_marked_explain a then + if Class.get_field cc.field_marked_explain a then a else ( match a.n_expl with @@ -503,15 +505,15 @@ module Make (A : CC_ARG) : ) in let rec find2 a b = - if N.equal a b then + if Class.equal a b then a - else if N.get_field cc.field_marked_explain a then + else if Class.get_field cc.field_marked_explain a then a - else if N.get_field cc.field_marked_explain b then + else if Class.get_field cc.field_marked_explain b then b else ( - N.set_field cc.field_marked_explain true a; - N.set_field cc.field_marked_explain true b; + Class.set_field cc.field_marked_explain true a; + Class.set_field cc.field_marked_explain true b; match a.n_expl, b.n_expl with | FL_some r1, FL_some r2 -> find2 r1.next r2.next | FL_some r, FL_none -> find1 r.next @@ -523,8 +525,8 @@ module Make (A : CC_ARG) : (* cleanup tags on nodes traversed in [find2] *) let rec cleanup_ n = - if N.get_field cc.field_marked_explain n then ( - N.set_field cc.field_marked_explain false n; + if Class.get_field cc.field_marked_explain n then ( + Class.set_field cc.field_marked_explain false n; match n.n_expl with | FL_none -> () | FL_some { next; _ } -> cleanup_ next @@ -538,7 +540,7 @@ module Make (A : CC_ARG) : module Expl_state = struct type t = { mutable lits: Lit.t list; - mutable same_val: (N.t * N.t) list; + mutable same_val: (Class.t * Class.t) list; mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * proof_step) list; } @@ -572,7 +574,9 @@ module Make (A : CC_ARG) : Iter.of_list self.th_lemmas |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) in - let p_cc = P.lemma_cc (Iter.append p_lits1 p_lits2) proof in + let p_cc = + P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) + in let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = (* pr_th: [sub_proofs |- t=u]. now resolve away [sub_proofs] to get literals that were @@ -582,15 +586,16 @@ module Make (A : CC_ARG) : (fun pr_th (lit_i, hyps_i) -> (* [hyps_i |- lit_i] *) let lemma_i = - P.lemma_cc - Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) - proof + P.add_step proof + @@ Rules_.lemma_cc + Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) in (* resolve [lit_i] away. *) - P.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th proof) + P.add_step proof + @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) pr_th sub_proofs in - P.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr proof + P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr in (* resolve with theory proofs responsible for some merges, if any. *) List.fold_left resolve_with_th_proof p_cc self.th_lemmas @@ -629,14 +634,14 @@ module Make (A : CC_ARG) : let sub_proofs = List.map (fun (t_i, u_i, expls_i) -> - let lit_i = A.mk_lit_eq cc.tst t_i u_i in + let lit_i = A.CC.mk_lit_eq cc.tst t_i u_i in (* use a separate call to [explain_expls] for each set *) let sub = explain_expls cc expls_i in Expl_state.merge st sub; lit_i, sub.lits) expl_sets in - let lit_t_u = A.mk_lit_eq cc.tst t u in + let lit_t_u = A.CC.mk_lit_eq cc.tst t u in Expl_state.add_th st lit_t_u sub_proofs pr | E_merge (a, b) -> explain_equal_rec_ cc st a b | E_merge_t (a, b) -> @@ -657,8 +662,8 @@ module Make (A : CC_ARG) : and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : node) (b : node) : unit = Log.debugf 5 (fun k -> - k "(@[cc.explain_loop.at@ %a@ =?= %a@])" N.pp a N.pp b); - assert (N.equal (find_ a) (find_ b)); + k "(@[cc.explain_loop.at@ %a@ =?= %a@])" Class.pp a Class.pp b); + assert (Class.equal (find_ a) (find_ b)); let ancestor = find_common_ancestor cc a b in explain_along_path cc st a ancestor; explain_along_path cc st b ancestor @@ -689,7 +694,7 @@ module Make (A : CC_ARG) : and add_new_term_ cc (t : term) : node = assert (not @@ mem cc t); Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp t); - let n = N.make t in + let n = Class.make t in (* register sub-terms, add [t] to their parent list, and return the corresponding initial signature *) let sig0 = compute_sig0 cc n in @@ -724,7 +729,7 @@ module Make (A : CC_ARG) : sub in let[@inline] return x = Some x in - match A.cc_view n.n_term with + match A.CC.view n.n_term with | Bool _ | Opaque _ -> None | Eq (a, b) -> let a = deref_sub a in @@ -750,13 +755,14 @@ module Make (A : CC_ARG) : match n.n_as_lit with | Some _ -> () | None -> - Log.debugf 15 (fun k -> k "(@[cc.set-as-lit@ %a@ %a@])" N.pp n Lit.pp lit); + Log.debugf 15 (fun k -> + k "(@[cc.set-as-lit@ %a@ %a@])" Class.pp n Lit.pp lit); on_backtrack cc (fun () -> n.n_as_lit <- None); n.n_as_lit <- Some lit (* is [n] true or false? *) let n_is_bool_value (self : t) n : bool = - N.equal n (n_true self) || N.equal n (n_false self) + Class.equal n (n_true self) || Class.equal n (n_false self) (* gather a pair [lits, pr], where [lits] is the set of asserted literals needed in the explanation (which is useful for @@ -790,16 +796,17 @@ module Make (A : CC_ARG) : if same_class a b then ( let expl = Expl.mk_merge a b in Log.debugf 5 (fun k -> - k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" N.pp n N.pp a N.pp b); + k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" Class.pp n Class.pp a + Class.pp b); merge_classes cc n (n_true cc) expl ) | Some (Not u) -> (* [u = bool ==> not u = not bool] *) let r_u = find_ u in - if N.equal r_u (n_true cc) then ( + if Class.equal r_u (n_true cc) then ( let expl = Expl.mk_merge u (n_true cc) in merge_classes cc n (n_false cc) expl - ) else if N.equal r_u (n_false cc) then ( + ) else if Class.equal r_u (n_false cc) then ( let expl = Expl.mk_merge u (n_false cc) in merge_classes cc n (n_true cc) expl ) @@ -810,7 +817,7 @@ module Make (A : CC_ARG) : | None -> (* add to the signature table [sig(n) --> n] *) add_signature cc s n - | Some u when N.equal n u -> () + | Some u when Class.equal n u -> () | Some u -> (* [t1] and [t2] must be applications of the same symbol to arguments that are pairwise equal *) @@ -841,10 +848,11 @@ module Make (A : CC_ARG) : k "(@[cc.semantic-conflict.set-val@ (@[set-val %a@ := %a@])@ \ (@[existing-val %a@ := %a@])@])" - N.pp n Term.pp v N.pp n' Term.pp v'); + Class.pp n Term.pp v Class.pp n' Term.pp v'); Stat.incr cc.count_semantic_conflict; - Actions.raise_semantic_conflict acts lits tuples + let (module A) = acts in + A.raise_semantic_conflict lits tuples | Some _ -> () | None -> T_b_tbl.add cc.t_to_val repr_n.n_term (n, v)); (* now for the reverse map, look in self.val_to_t for [v]. @@ -861,20 +869,20 @@ module Make (A : CC_ARG) : and task_merge_ cc acts a b e_ab : unit = let ra = find_ a in let rb = find_ b in - if not @@ N.equal ra rb then ( - assert (N.is_root ra); - assert (N.is_root rb); + if not @@ Class.equal ra rb then ( + assert (Class.is_root ra); + assert (Class.is_root rb); Stat.incr cc.count_merge; (* check we're not merging [true] and [false] *) if - (N.equal ra (n_true cc) && N.equal rb (n_false cc)) - || (N.equal rb (n_true cc) && N.equal ra (n_false cc)) + (Class.equal ra (n_true cc) && Class.equal rb (n_false cc)) + || (Class.equal rb (n_true cc) && Class.equal ra (n_false cc)) then ( Log.debugf 5 (fun k -> k "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ %a@ :t2 %a@]@ :e_ab %a@])" - N.pp ra N.pp a N.pp rb N.pp b Expl.pp e_ab); + Class.pp ra Class.pp a Class.pp rb Class.pp b Expl.pp e_ab); let th = ref false in (* TODO: C1: P.true_neq_false @@ -891,11 +899,12 @@ module Make (A : CC_ARG) : let lits = expl_st.lits in let same_val = expl_st.same_val - |> List.rev_map (fun (t, u) -> true, N.term t, N.term u) + |> List.rev_map (fun (t, u) -> true, Class.term t, Class.term u) in assert (same_val <> []); Stat.incr cc.count_semantic_conflict; - Actions.raise_semantic_conflict acts lits same_val + let (module A) = acts in + A.raise_semantic_conflict lits same_val ) else ( (* regular conflict *) let lits, pr = lits_and_proof_of_expl cc expl_st in @@ -917,9 +926,9 @@ module Make (A : CC_ARG) : in (* when merging terms with [true] or [false], possibly propagate them to SAT *) let merge_bool r1 t1 r2 t2 = - if N.equal r1 (n_true cc) then + if Class.equal r1 (n_true cc) then propagate_bools cc acts r2 t2 r1 t1 e_ab true - else if N.equal r1 (n_false cc) then + else if Class.equal r1 (n_false cc) then propagate_bools cc acts r2 t2 r1 t1 e_ab false in @@ -930,7 +939,7 @@ module Make (A : CC_ARG) : (* perform [union r_from r_into] *) Log.debugf 15 (fun k -> - k "(@[cc.merge@ :from %a@ :into %a@])" N.pp r_from N.pp r_into); + k "(@[cc.merge@ :from %a@ :into %a@])" Class.pp r_from Class.pp r_into); (* call [on_pre_merge] functions, and merge theory data items *) if not cc.model_mode then ( @@ -942,9 +951,9 @@ module Make (A : CC_ARG) : ); ((* parents might have a different signature, check for collisions *) - N.iter_parents r_from (fun parent -> push_pending cc parent); + Class.iter_parents r_from (fun parent -> push_pending cc parent); (* for each node in [r_from]'s class, make it point to [r_into] *) - N.iter_class r_from (fun u -> + Class.iter_class r_from (fun u -> assert (u.n_root == r_from); u.n_root <- r_into); (* capture current state *) @@ -961,15 +970,15 @@ module Make (A : CC_ARG) : (* on backtrack, unmerge classes and restore the pointers to [r_from] *) on_backtrack cc (fun () -> Log.debugf 30 (fun k -> - k "(@[cc.undo_merge@ :from %a@ :into %a@])" N.pp r_from N.pp - r_into); + k "(@[cc.undo_merge@ :from %a@ :into %a@])" Class.pp r_from + Class.pp r_into); r_into.n_bits <- r_into_old_bits; r_into.n_next <- r_into_old_next; r_from.n_next <- r_from_old_next; r_into.n_parents <- r_into_old_parents; (* NOTE: this must come after the restoration of [next] pointers, otherwise we'd iterate on too big a class *) - N.iter_class_ r_from (fun u -> u.n_root <- r_from); + Class.iter_class_ r_from (fun u -> u.n_root <- r_from); r_into.n_size <- r_into.n_size - r_from.n_size)); (* check for semantic values, update the one of [r_into] @@ -997,10 +1006,11 @@ module Make (A : CC_ARG) : k "(@[cc.semantic-conflict.post-merge@ (@[n-from %a@ := %a@])@ \ (@[n-into %a@ := %a@])@])" - N.pp n_from Term.pp v_from N.pp n_into Term.pp v_into); + Class.pp n_from Term.pp v_from Class.pp n_into Term.pp v_into); Stat.incr cc.count_semantic_conflict; - Actions.raise_semantic_conflict acts lits tuples + let (module A) = acts in + A.raise_semantic_conflict lits tuples | Some _ -> ())); (* update explanations (a -> b), arbitrarily. @@ -1012,8 +1022,8 @@ module Make (A : CC_ARG) : that bridges between [a] and [b] *) on_backtrack cc (fun () -> match a.n_expl, b.n_expl with - | FL_some e, _ when N.equal e.next b -> a.n_expl <- FL_none - | _, FL_some e when N.equal e.next a -> b.n_expl <- FL_none + | FL_some e, _ when Class.equal e.next b -> a.n_expl <- FL_none + | _, FL_some e when Class.equal e.next a -> b.n_expl <- FL_none | _ -> assert false); a.n_expl <- FL_some { next = b; expl = e_ab }; (* call [on_post_merge] *) @@ -1036,14 +1046,14 @@ module Make (A : CC_ARG) : in (* TODO: flag per class, `or`-ed on merge, to indicate if the class contains at least one lit *) - N.iter_class r1 (fun u1 -> + Class.iter_class r1 (fun u1 -> (* propagate if: - [u1] is a proper literal - [t2 != r2], because that can only happen after an explicit merge (no way to obtain that by propagation) *) - match N.as_lit u1 with - | Some lit when not (N.equal r2 t2) -> + match Class.as_lit u1 with + | Some lit when not (Class.equal r2 t2) -> let lit = if sign then lit @@ -1070,7 +1080,8 @@ module Make (A : CC_ARG) : in List.iter (fun f -> f cc lit reason) cc.on_propagate; Stat.incr cc.count_props; - Actions.propagate acts lit ~reason + let (module A) = acts in + A.propagate lit ~reason ) | _ -> ()) @@ -1078,9 +1089,7 @@ module Make (A : CC_ARG) : let pp out _ = Fmt.string out "cc" end - let add_seq cc seq = - seq (fun t -> ignore @@ add_term_rec_ cc t); - () + let add_iter cc it : unit = it (fun t -> ignore @@ add_term_rec_ cc t) let[@inline] push_level (self : t) : unit = Backtrack_stack.push_level self.undo; @@ -1112,7 +1121,7 @@ module Make (A : CC_ARG) : all_classes self |> Iter.filter_map (fun repr -> match T_b_tbl.get self.t_to_val repr.n_term with - | Some (_, v) -> Some (repr, N.iter_class repr, v) + | Some (_, v) -> Some (repr, Class.iter_class repr, v) | None -> None) (* assert that this boolean literal holds. @@ -1122,7 +1131,7 @@ module Make (A : CC_ARG) : let t = Lit.term lit in Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); let sign = Lit.sign lit in - match A.cc_view t with + match A.CC.view t with | Eq (a, b) when sign -> let a = add_term cc a in let b = add_term cc b in @@ -1159,8 +1168,8 @@ module Make (A : CC_ARG) : let merge cc n1 n2 expl = Log.debugf 5 (fun k -> - k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" N.pp n1 N.pp n2 - Expl.pp expl); + k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" Class.pp n1 Class.pp + n2 Expl.pp expl); assert (T.Ty.equal (T.Term.ty n1.n_term) (T.Term.ty n2.n_term)); merge_classes cc n1 n2 expl @@ -1245,7 +1254,8 @@ module Make (A : CC_ARG) : let check_inv_ (self : t) : unit = if check_inv_enabled_ then ( Log.debug 2 "(cc.check-invariants)"; - all_classes self |> Iter.flat_map N.iter_class + all_classes self + |> Iter.flat_map Class.iter_class |> Iter.iter (fun n -> match n.n_sig0 with | None -> () @@ -1254,16 +1264,143 @@ module Make (A : CC_ARG) : let ok = match find_signature self s' with | None -> false - | Some r -> N.equal r n.n_root + | Some r -> Class.equal r n.n_root in if not ok then Log.debugf 0 (fun k -> k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" - N.pp n Signature.pp s Signature.pp s')) + Class.pp n Signature.pp s Signature.pp s')) ) (* model: return all the classes *) let get_model (cc : t) : repr Iter.t Iter.t = check_inv_ cc; - all_classes cc |> Iter.map N.iter_class + all_classes cc |> Iter.map Class.iter_class +end + +module Make_plugin (M : MONOID_ARG) : PLUGIN_BUILDER with module M = M = struct + module M = M + module CC = M.CC + module Class = CC.Class + module N_tbl = Backtrackable_tbl.Make (Class) + module Expl = CC.Expl + + type term = CC.term + + module type PL = PLUGIN with module CC = M.CC and module M = M + + type plugin = (module PL) + + module Make (A : sig + val size : int option + val cc : CC.t + end) : PL = struct + module M = M + module CC = CC + open A + + (* repr -> value for the class *) + let values : M.t N_tbl.t = N_tbl.create ?size () + + (* bit in CC to filter out quickly classes without value *) + let field_has_value : Class.bitfield = + CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc + + let push_level () = N_tbl.push_level values + let pop_levels n = N_tbl.pop_levels values n + let n_levels () = N_tbl.n_levels values + + let mem n = + let res = CC.get_bitfield cc field_has_value n in + assert ( + if res then + N_tbl.mem values n + else + true); + res + + let get n = + if CC.get_bitfield cc field_has_value n then + N_tbl.get values n + else + None + + let on_new_term cc n (t : term) : unit = + (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) + let maybe_m, l = M.of_term cc n t in + (match maybe_m with + | Some v -> + Log.debugf 20 (fun k -> + k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name Class.pp n + M.pp v); + CC.set_bitfield cc field_has_value true n; + N_tbl.add values n v + | None -> ()); + List.iter + (fun (n_u, m_u) -> + Log.debugf 20 (fun k -> + k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])" + M.name Class.pp n Class.pp n_u M.pp m_u); + let n_u = CC.find cc n_u in + if CC.get_bitfield cc field_has_value n_u then ( + let m_u' = + try N_tbl.find values n_u + with Not_found -> + Error.errorf "node %a has bitfield but no value" Class.pp n_u + in + match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with + | Error expl -> + Error.errorf + "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" + Class.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl + | Ok m_u_merged -> + Log.debugf 20 (fun k -> + k + "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ + :value %a@])" + M.name Class.pp n Class.pp n_u M.pp m_u_merged); + N_tbl.add values n_u m_u_merged + ) else ( + (* just add to [n_u] *) + CC.set_bitfield cc field_has_value true n_u; + N_tbl.add values n_u m_u + )) + l; + () + + let iter_all : _ Iter.t = N_tbl.to_iter values + + let on_pre_merge cc acts n1 n2 e_n1_n2 : unit = + match get n1, get n2 with + | Some v1, Some v2 -> + Log.debugf 5 (fun k -> + k + "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \ + :val2 %a@])@])" + M.name Class.pp n1 M.pp v1 Class.pp n2 M.pp v2); + (match M.merge cc n1 v1 n2 v2 e_n1_n2 with + | Ok v' -> + N_tbl.remove values n2; + (* only keep repr *) + N_tbl.add values n1 v' + | Error expl -> CC.raise_conflict_from_expl cc acts expl) + | None, Some cr -> + CC.set_bitfield cc field_has_value true n1; + N_tbl.add values n1 cr; + N_tbl.remove values n2 (* only keep reprs *) + | Some _, None -> () (* already there on the left *) + | None, None -> () + + (* setup *) + let () = + CC.on_new_term cc on_new_term; + CC.on_pre_merge cc on_pre_merge; + () + end + + let create_and_setup ?size (cc : CC.t) : plugin = + (module Make (struct + let size = size + let cc = cc + end)) end diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 48760ec2..ade46641 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -1,13 +1,20 @@ -(** {2 Congruence Closure} *) +(** Congruence Closure Implementation *) -open Sidekick_core +module View = Sidekick_sigs_cc.View -module type S = Sidekick_core.CC_S +module type TERM = Sidekick_sigs_cc.TERM +module type LIT = Sidekick_sigs_cc.LIT +module type ARG = Sidekick_sigs_cc.ARG +module type S = Sidekick_sigs_cc.S +module type MONOID_ARG = Sidekick_sigs_cc.MONOID_ARG +module type PLUGIN = Sidekick_sigs_cc.PLUGIN +module type PLUGIN_BUILDER = Sidekick_sigs_cc.PLUGIN_BUILDER -module Make (A : CC_ARG) : +module Make (A : ARG) : S with module T = A.T and module Lit = A.Lit - and type proof = A.proof - and type proof_step = A.proof_step - and module Actions = A.Actions + and module Proof_trace = A.Proof_trace + +(** Create a plugin builder from the given per-class monoid *) +module Make_plugin (M : MONOID_ARG) : PLUGIN_BUILDER with module M = M diff --git a/src/cc/dune b/src/cc/dune index a7ca76ab..b33f850d 100644 --- a/src/cc/dune +++ b/src/cc/dune @@ -1,5 +1,5 @@ (library (name Sidekick_cc) (public_name sidekick.cc) - (libraries containers iter sidekick.core sidekick.util) + (libraries containers iter sidekick.sigs sidekick.sigs.cc sidekick.util) (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index ce108e2b..213ba2fc 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -1,4 +1,4 @@ -(** {1 Main Signatures} +(** Main Signatures. Theories and concrete solvers rely on an environment that defines several important types: @@ -14,777 +14,15 @@ module Fmt = CCFormat -(** View terms through the lens of the Congruence Closure *) -module CC_view = struct - (** A view of a term fron the point of view of the congruence closure. - - - ['f] is the type of function symbols - - ['t] is the type of terms - - ['ts] is the type of sequences of terms (arguments of function application) - *) - type ('f, 't, 'ts) t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't - (* do not enter *) - - (** Map function over a view, one level deep. - Each function maps over a different type, e.g. [f_t] maps over terms *) - let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = - match v with - | Bool b -> Bool b - | App_fun (f, args) -> App_fun (f_f f, f_ts args) - | App_ho (f, a) -> App_ho (f_t f, f_t a) - | Not t -> Not (f_t t) - | If (a, b, c) -> If (f_t a, f_t b, f_t c) - | Eq (a, b) -> Eq (f_t a, f_t b) - | Opaque t -> Opaque (f_t t) - - (** Iterate over a view, one level deep. *) - let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = - match v with - | Bool _ -> () - | App_fun (f, args) -> - f_f f; - f_ts args - | App_ho (f, a) -> - f_t f; - f_t a - | Not t -> f_t t - | If (a, b, c) -> - f_t a; - f_t b; - f_t c - | Eq (a, b) -> - f_t a; - f_t b - | Opaque t -> f_t t -end - -(** Main representation of Terms and Types *) -module type TERM = sig - (** A function symbol, like "f" or "plus" or "is_human" or "socrates" *) - module Fun : sig - type t - - val equal : t -> t -> bool - val hash : t -> int - val pp : t Fmt.printer - end - - (** Types - - Types should be comparable (ideally, in O(1)), and have - at least a boolean type available. *) - module Ty : sig - type t - - val equal : t -> t -> bool - val hash : t -> int - val pp : t Fmt.printer - - type store - - val bool : store -> t - val is_bool : t -> bool - end - - (** Term structure. - - Terms should be {b hashconsed}, with perfect sharing. - This allows, for example, {!Term.Tbl} and {!Term.iter_dag} to be efficient. - *) - module Term : sig - type t - - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val pp : t Fmt.printer - - type store - (** A store used to create new terms. It is where the hashconsing - table should live, along with other all-terms related store. *) - - val ty : t -> Ty.t - - val bool : store -> bool -> t - (** build true/false *) - - val as_bool : t -> bool option - (** [as_bool t] is [Some true] if [t] is the term [true], and similarly - for [false]. For other terms it is [None]. *) - - val abs : store -> t -> t * bool - (** [abs t] returns an "absolute value" for the term, along with the - sign of [t]. - - The idea is that we want to turn [not a] into [(a, false)], - or [(a != b)] into [(a=b, false)]. For terms without a negation this - should return [(t, true)]. - - The store is passed in case a new term needs to be created. *) - - val map_shallow : store -> (t -> t) -> t -> t - (** Map function on immediate subterms. This should not be recursive. *) - - val iter_shallow : store -> (t -> unit) -> t -> unit - (** Iterate function on immediate subterms. This should not be recursive. *) - - val iter_dag : t -> (t -> unit) -> unit - (** [iter_dag t f] calls [f] once on each subterm of [t], [t] included. - It must {b not} traverse [t] as a tree, but rather as a - perfectly shared DAG. - - For example, in: - {[ - let x = 2 in - let y = f x x in - let z = g y x in - z = z - ]} - - the DAG has the following nodes: - - {[ n1: 2 - n2: f n1 n1 - n3: g n2 n1 - n4: = n3 n3 - ]} - *) - - module Tbl : CCHashtbl.S with type key = t - end -end +module type TERM = Sidekick_sigs_term.S +module type LIT = Sidekick_sigs_lit.S +module type PROOF_TRACE = Sidekick_sigs_proof_trace.S +module type SAT_PROOF = Sidekick_sigs_proof_sat.S (** Signature for SAT-solver proof emission. *) -module type SAT_PROOF = sig - type t - (** The stored proof (possibly nil, possibly on disk, possibly in memory) *) - - type proof_step - (** identifier for a proof *) - - module Step_vec : Vec_sig.BASE with type elt = proof_step - (** A vector of steps *) - - type lit - (** A boolean literal for the proof trace *) - - type proof_rule = t -> proof_step - (** A proof proof_rule constructor, used to obtain proofs from theories *) - - val enabled : t -> bool - (** Returns true if proof production is enabled *) - - val emit_input_clause : lit Iter.t -> proof_rule - (** Emit an input clause. *) - - val emit_redundant_clause : lit Iter.t -> hyps:proof_step Iter.t -> proof_rule - (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. - The clause must be RUP wrt [hyps]. *) - - val emit_unsat_core : lit Iter.t -> proof_rule - (** Produce a proof of the empty clause given this subset of the assumptions. - FIXME: probably needs the list of proof_step that disprove the lits? *) - - val emit_unsat : proof_step -> t -> unit - (** Signal "unsat" result at the given proof *) - - val del_clause : proof_step -> lit Iter.t -> t -> unit - (** Forget a clause. Only useful for performance considerations. *) -end +module type PROOF = Sidekick_sigs_proof_core.S (** Proofs of unsatisfiability. *) -module type PROOF = sig - type t - (** The abstract representation of a proof. A proof always proves - a clause to be {b valid} (true in every possible interpretation - of the problem's assertions, and the theories) *) - - type proof_step - (** Identifier for a proof proof_rule (like a unique ID for a clause previously - added/proved) *) - - type term - type lit - type proof_rule = t -> proof_step - - include - SAT_PROOF - with type t := t - and type lit := lit - and type proof_step := proof_step - and type proof_rule := proof_rule - - val lemma_cc : lit Iter.t -> proof_rule - (** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory - of uninterpreted functions. *) - - val define_term : term -> term -> proof_rule - (** [define_term cst u proof] defines the new constant [cst] as being equal - to [u]. - The result is a proof of the clause [cst = u] *) - - val proof_p1 : proof_step -> proof_step -> proof_rule - (** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) - and [p2] proves [C \/ t], is the rule that produces [C \/ u], - i.e unit paramodulation. *) - - val proof_r1 : proof_step -> proof_step -> proof_rule - (** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) - and [p2] proves [C \/ ¬t], is the rule that produces [C \/ u], - i.e unit resolution. *) - - val proof_res : pivot:term -> proof_step -> proof_step -> proof_rule - (** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] - and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], - is the rule that produces [C \/ D], i.e boolean resolution. *) - - val with_defs : proof_step -> proof_step Iter.t -> proof_rule - (** [with_defs pr defs] specifies that [pr] is valid only in - a context where the definitions [defs] are present. *) - - val lemma_true : term -> proof_rule - (** [lemma_true (true) p] asserts the clause [(true)] *) - - val lemma_preprocess : term -> term -> using:proof_step Iter.t -> proof_rule - (** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology - and that [t] has been preprocessed into [u]. - - The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence - closure, and then resolved against the clauses [using] to obtain - a unit equality. - - From now on, [t] and [u] will be used interchangeably. - @return a proof_rule ID for the clause [(t=u)]. *) - - val lemma_rw_clause : - proof_step -> res:lit Iter.t -> using:proof_step Iter.t -> proof_rule - (** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], - uses the equations [|- p_i = q_i] from [using] - to rewrite some literals of [c] into [res]. This is used to preprocess - literals of a clause (using {!lemma_preprocess} individually). *) -end - -(** Literals - - Literals are a pair of a boolean-sorted term, and a sign. - Positive literals are the same as their term, and negative literals - are the negation of their term. - - The SAT solver deals only in literals and clauses (sets of literals). - Everything else belongs in the SMT solver. *) -module type LIT = sig - module T : TERM - (** Literals depend on terms *) - - type t - (** A literal *) - - val term : t -> T.Term.t - (** Get the (positive) term *) - - val sign : t -> bool - (** Get the sign. A negated literal has sign [false]. *) - - val neg : t -> t - (** Take negation of literal. [sign (neg lit) = not (sign lit)]. *) - - val abs : t -> t - (** [abs lit] is like [lit] but always positive, i.e. [sign (abs lit) = true] *) - - val signed_term : t -> T.Term.t * bool - (** Return the atom and the sign *) - - val atom : ?sign:bool -> T.Term.store -> T.Term.t -> t - (** [atom store t] makes a literal out of a term, possibly normalizing - its sign in the process. - @param sign if provided, and [sign=false], negate the resulting lit. *) - - val norm_sign : t -> t * bool - (** [norm_sign (+t)] is [+t, true], - and [norm_sign (-t)] is [+t, false]. - In both cases the term is positive, and the boolean reflects the initial sign. *) - - val equal : t -> t -> bool - val hash : t -> int - val pp : t Fmt.printer -end - -(** Actions provided to the congruence closure. - - The congruence closure must be able to propagate literals when - it detects that they are true or false; it must also - be able to create conflicts when the set of (dis)equalities - is inconsistent *) -module type CC_ACTIONS = sig - module T : TERM - module Lit : LIT with module T = T - - type proof - type proof_step - - module P : - PROOF - with type lit = Lit.t - and type t = proof - and type term = T.Term.t - and type proof_step = proof_step - - type t - (** An action handle. It is used by the congruence closure - to perform the actions below. How it performs the actions - is not specified and is solver-specific. *) - - val proof : t -> proof - - val raise_conflict : t -> Lit.t list -> proof_step -> 'a - (** [raise_conflict acts c pr] declares that [c] is a tautology of - the theory of congruence. This does not return (it should raise an - exception). - @param pr the proof of [c] being a tautology *) - - val raise_semantic_conflict : - t -> Lit.t list -> (bool * T.Term.t * T.Term.t) list -> 'a - (** [raise_semantic_conflict acts lits same_val] declares that - the conjunction of all [lits] (literals true in current trail) and tuples - [{=,≠}, t_i, u_i] implies false. - - The [{=,≠}, t_i, u_i] are pairs of terms with the same value (if [=] / true) - or distinct value (if [≠] / false)) in the current model. - - This does not return. It should raise an exception. - *) - - val propagate : t -> Lit.t -> reason:(unit -> Lit.t list * proof_step) -> unit - (** [propagate acts lit ~reason pr] declares that [reason() => lit] - is a tautology. - - - [reason()] should return a list of literals that are currently true. - - [lit] should be a literal of interest (see {!CC_S.set_as_lit}). - - This function might never be called, a congruence closure has the right - to not propagate and only trigger conflicts. *) -end - -(** Arguments to a congruence closure's implementation *) -module type CC_ARG = sig - module T : TERM - module Lit : LIT with module T = T - - type proof - type proof_step - - module P : - PROOF - with type lit = Lit.t - and type t = proof - and type term = T.Term.t - and type proof_step = proof_step - - module Actions : - CC_ACTIONS - with module T = T - and module Lit = Lit - and type proof = proof - and type proof_step = proof_step - - val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t - (** View the term through the lens of the congruence closure *) - - val mk_lit_eq : ?sign:bool -> T.Term.store -> T.Term.t -> T.Term.t -> Lit.t - (** [mk_lit_eq store t u] makes the literal [t=u] *) -end - -(** Main congruence closure signature. - - The congruence closure handles the theory QF_UF (uninterpreted - function symbols). - It is also responsible for {i theory combination}, and provides - a general framework for equality reasoning that other - theories piggyback on. - - For example, the theory of datatypes relies on the congruence closure - to do most of the work, and "only" adds injectivity/disjointness/acyclicity - lemmas when needed. - - Similarly, a theory of arrays would hook into the congruence closure and - assert (dis)equalities as needed. -*) -module type CC_S = sig - (** first, some aliases. *) - - module T : TERM - module Lit : LIT with module T = T - - type proof - type proof_step - - module P : - PROOF - with type lit = Lit.t - and type t = proof - and type proof_step = proof_step - - module Actions : - CC_ACTIONS - with module T = T - and module Lit = Lit - and type proof = proof - and type proof_step = proof_step - - type term_store = T.Term.store - type term = T.Term.t - type value = term - type fun_ = T.Fun.t - type lit = Lit.t - type actions = Actions.t - - type t - (** The congruence closure object. - It contains a fair amount of state and is mutable - and backtrackable. *) - - (** Equivalence classes. - - An equivalence class is a set of terms that are currently equal - in the partial model built by the solver. - The class is represented by a collection of nodes, one of which is - distinguished and is called the "representative". - - All information pertaining to the whole equivalence class is stored - in this representative's node. - - When two classes become equal (are "merged"), one of the two - representatives is picked as the representative of the new class. - The new class contains the union of the two old classes' nodes. - - We also allow theories to store additional information in the - representative. This information can be used when two classes are - merged, to detect conflicts and solve equations à la Shostak. - *) - module N : sig - type t - (** An equivalent class, containing terms that are proved - to be equal. - - A value of type [t] points to a particular term, but see - {!find} to get the representative of the class. *) - - val term : t -> term - (** Term contained in this equivalence class. - If [is_root n], then [term n] is the class' representative term. *) - - val equal : t -> t -> bool - (** Are two classes {b physically} equal? To check for - logical equality, use [CC.N.equal (CC.find cc n1) (CC.find cc n2)] - which checks for equality of representatives. *) - - val hash : t -> int - (** An opaque hash of this node. *) - - val pp : t Fmt.printer - (** Unspecified printing of the node, for example its term, - a unique ID, etc. *) - - val is_root : t -> bool - (** Is the node a root (ie the representative of its class)? - See {!find} to get the root. *) - - val iter_class : t -> t Iter.t - (** Traverse the congruence class. - Precondition: [is_root n] (see {!find} below) *) - - val iter_parents : t -> t Iter.t - (** Traverse the parents of the class. - Precondition: [is_root n] (see {!find} below) *) - - type bitfield - (** A field in the bitfield of this node. This should only be - allocated when a theory is initialized. - - Bitfields are accessed using preallocated keys. - See {!CC_S.allocate_bitfield}. - - All fields are initially 0, are backtracked automatically, - and are merged automatically when classes are merged. *) - end - - (** Explanations - - Explanations are specialized proofs, created by the congruence closure - when asked to justify why 2 terms are equal. *) - module Expl : sig - type t - - val pp : t Fmt.printer - - val mk_merge : N.t -> N.t -> t - (** Explanation: the nodes were explicitly merged *) - - val mk_merge_t : term -> term -> t - (** Explanation: the terms were explicitly merged *) - - val mk_lit : lit -> t - (** Explanation: we merged [t] and [u] because of literal [t=u], - or we merged [t] and [true] because of literal [t], - or [t] and [false] because of literal [¬t] *) - - val mk_same_value : N.t -> N.t -> t - - val mk_list : t list -> t - (** Conjunction of explanations *) - - val mk_theory : - term -> term -> (term * term * t list) list -> proof_step -> t - (** [mk_theory t u expl_sets pr] builds a theory explanation for - why [|- t=u]. It depends on sub-explanations [expl_sets] which - are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are - explanations that justify [t_i = u_i] in the current congruence closure. - - The proof [pr] is the theory lemma, of the form - [ (t_i = u_i)_i |- t=u ]. - It is resolved against each [expls_i |- t_i=u_i] obtained from - [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] - where [Gamma] is a subset of the literals asserted into the congruence - closure. - - For example for the lemma [a=b] deduced by injectivity - from [Some a=Some b] in the theory of datatypes, - the arguments would be - [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] - where [pr] is the injectivity lemma [Some a=Some b |- a=b]. - *) - end - - (** Resolved explanations. - - The congruence closure keeps explanations for why terms are in the same - class. However these are represented in a compact, cheap form. - To use these explanations we need to {b resolve} them into a - resolved explanation, typically a list of - literals that are true in the current trail and are responsible for - merges. - - However, we can also have merged classes because they have the same value - in the current model. *) - module Resolved_expl : sig - type t = { - lits: lit list; - same_value: (N.t * N.t) list; - pr: proof -> proof_step; - } - - val is_semantic : t -> bool - (** [is_semantic expl] is [true] if there's at least one - pair in [expl.same_value]. *) - - val pp : t Fmt.printer - end - - type node = N.t - (** A node of the congruence closure *) - - type repr = N.t - (** Node that is currently a representative *) - - type explanation = Expl.t - - (** {3 Accessors} *) - - val term_store : t -> term_store - val proof : t -> proof - - val find : t -> node -> repr - (** Current representative *) - - val add_term : t -> term -> node - (** Add the term to the congruence closure, if not present already. - Will be backtracked. *) - - val mem_term : t -> term -> bool - (** Returns [true] if the term is explicitly present in the congruence closure *) - - (** {3 Events} - - Events triggered by the congruence closure, to which - other plugins can subscribe. *) - - type ev_on_pre_merge = t -> actions -> N.t -> N.t -> Expl.t -> unit - (** [ev_on_pre_merge cc acts n1 n2 expl] is called right before [n1] - and [n2] are merged with explanation [expl]. *) - - type ev_on_post_merge = t -> actions -> N.t -> N.t -> unit - (** [ev_on_post_merge cc acts n1 n2] is called right after [n1] - and [n2] were merged. [find cc n1] and [find cc n2] will return - the same node. *) - - type ev_on_new_term = t -> N.t -> term -> unit - (** [ev_on_new_term cc n t] is called whenever a new term [t] - is added to the congruence closure. Its node is [n]. *) - - type ev_on_conflict = t -> th:bool -> lit list -> unit - (** [ev_on_conflict acts ~th c] is called when the congruence - closure triggers a conflict by asserting the tautology [c]. - - @param th true if the explanation for this conflict involves - at least one "theory" explanation; i.e. some of the equations - participating in the conflict are purely syntactic theories - like injectivity of constructors. *) - - type ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit - (** [ev_on_propagate cc lit reason] is called whenever [reason() => lit] - is a propagated lemma. See {!CC_ACTIONS.propagate}. *) - - type ev_on_is_subterm = N.t -> term -> unit - (** [ev_on_is_subterm n t] is called when [n] is a subterm of - another node for the first time. [t] is the term corresponding to - the node [n]. This can be useful for theory combination. *) - - val create : - ?stat:Stat.t -> - ?on_pre_merge:ev_on_pre_merge list -> - ?on_post_merge:ev_on_post_merge list -> - ?on_new_term:ev_on_new_term list -> - ?on_conflict:ev_on_conflict list -> - ?on_propagate:ev_on_propagate list -> - ?on_is_subterm:ev_on_is_subterm list -> - ?size:[ `Small | `Big ] -> - term_store -> - proof -> - t - (** Create a new congruence closure. - - @param term_store used to be able to create new terms. All terms - interacting with this congruence closure must belong in this term state - as well. *) - - val allocate_bitfield : descr:string -> t -> N.bitfield - (** Allocate a new node field (see {!N.bitfield}). - - This field descriptor is henceforth reserved for all nodes - in this congruence closure, and can be set using {!set_bitfield} - for each node individually. - This can be used to efficiently store some metadata on nodes - (e.g. "is there a numeric value in the class" - or "is there a constructor term in the class"). - - There may be restrictions on how many distinct fields are allocated - for a given congruence closure (e.g. at most {!Sys.int_size} fields). - *) - - val get_bitfield : t -> N.bitfield -> N.t -> bool - (** Access the bit field of the given node *) - - val set_bitfield : t -> N.bitfield -> bool -> N.t -> unit - (** Set the bitfield for the node. This will be backtracked. - See {!N.bitfield}. *) - - (* TODO: remove? this is managed by the solver anyway? *) - val on_pre_merge : t -> ev_on_pre_merge -> unit - (** Add a function to be called when two classes are merged *) - - val on_post_merge : t -> ev_on_post_merge -> unit - (** Add a function to be called when two classes are merged *) - - val on_new_term : t -> ev_on_new_term -> unit - (** Add a function to be called when a new node is created *) - - val on_conflict : t -> ev_on_conflict -> unit - (** Called when the congruence closure finds a conflict *) - - val on_propagate : t -> ev_on_propagate -> unit - (** Called when the congruence closure propagates a literal *) - - val on_is_subterm : t -> ev_on_is_subterm -> unit - (** Called on terms that are subterms of function symbols *) - - val set_as_lit : t -> N.t -> lit -> unit - (** map the given node to a literal. *) - - val find_t : t -> term -> repr - (** Current representative of the term. - @raise Not_found if the term is not already {!add}-ed. *) - - val add_seq : t -> term Iter.t -> unit - (** Add a sequence of terms to the congruence closure *) - - val all_classes : t -> repr Iter.t - (** All current classes. This is costly, only use if there is no other solution *) - - val assert_lit : t -> lit -> unit - (** Given a literal, assume it in the congruence closure and propagate - its consequences. Will be backtracked. - - Useful for the theory combination or the SAT solver's functor *) - - val assert_lits : t -> lit Iter.t -> unit - (** Addition of many literals *) - - val explain_eq : t -> N.t -> N.t -> Resolved_expl.t - (** Explain why the two nodes are equal. - Fails if they are not, in an unspecified way. *) - - val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a - (** Raise a conflict with the given explanation. - It must be a theory tautology that [expl ==> absurd]. - To be used in theories. - - This fails in an unspecified way if the explanation, once resolved, - satisfies {!Resolved_expl.is_semantic}. *) - - val n_true : t -> N.t - (** Node for [true] *) - - val n_false : t -> N.t - (** Node for [false] *) - - val n_bool : t -> bool -> N.t - (** Node for either true or false *) - - val merge : t -> N.t -> N.t -> Expl.t -> unit - (** Merge these two nodes given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val merge_t : t -> term -> term -> Expl.t -> unit - (** Shortcut for adding + merging *) - - val set_model_value : t -> term -> value -> unit - (** Set the value of a term in the model. *) - - val with_model_mode : t -> (unit -> 'a) -> 'a - (** Enter model combination mode. *) - - val get_model_for_each_class : t -> (repr * N.t Iter.t * value) Iter.t - (** In model combination mode, obtain classes with their values. *) - - val check : t -> actions -> unit - (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. - Will use the {!actions} to propagate literals, declare conflicts, etc. *) - - val push_level : t -> unit - (** Push backtracking level *) - - val pop_levels : t -> int -> unit - (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) - - val get_model : t -> N.t Iter.t Iter.t - (** get all the equivalence classes so they can be merged in the model *) - - (**/**) - - module Debug_ : sig - val pp : t Fmt.printer - end - - (**/**) -end (** Registry to extract values *) module type REGISTRY = sig @@ -807,6 +45,7 @@ end module type SOLVER_INTERNAL = sig module T : TERM module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE type ty = T.Ty.t type term = T.Term.t @@ -814,16 +53,8 @@ module type SOLVER_INTERNAL = sig type term_store = T.Term.store type ty_store = T.Ty.store type clause_pool - type proof - type proof_step - - (** {3 Proofs} *) - module P : - PROOF - with type lit = Lit.t - and type term = term - and type t = proof - and type proof_step = proof_step + type proof = Proof_trace.t + type proof_step = Proof_trace.step_id type t (** {3 Main type for a solver} *) @@ -855,14 +86,10 @@ module type SOLVER_INTERNAL = sig (** Congruence closure instance *) module CC : - CC_S + Sidekick_sigs_cc.S with module T = T and module Lit = Lit - and type proof = proof - and type proof_step = proof_step - and type P.t = proof - and type P.lit = lit - and type Actions.t = theory_actions + and module Proof_trace = Proof_trace val cc : t -> CC.t (** Congruence closure for this solver *) @@ -1000,13 +227,14 @@ module type SOLVER_INTERNAL = sig it must be a theory tautology that [expl ==> absurd]. To be used in theories. *) - val cc_find : t -> CC.N.t -> CC.N.t + val cc_find : t -> CC.Class.t -> CC.Class.t (** Find representative of the node *) val cc_are_equal : t -> term -> term -> bool (** Are these two terms equal in the congruence closure? *) - val cc_merge : t -> theory_actions -> CC.N.t -> CC.N.t -> CC.Expl.t -> unit + val cc_merge : + t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit (** Merge these two nodes in the congruence closure, given this explanation. It must be a theory tautology that [expl ==> n1 = n2]. To be used in theories. *) @@ -1015,7 +243,7 @@ module type SOLVER_INTERNAL = sig (** Merge these two terms in the congruence closure, given this explanation. See {!cc_merge} *) - val cc_add_term : t -> term -> CC.N.t + val cc_add_term : t -> term -> CC.Class.t (** Add/retrieve congruence closure node for this term. To be used in theories *) @@ -1025,19 +253,19 @@ module type SOLVER_INTERNAL = sig val on_cc_pre_merge : t -> - (CC.t -> theory_actions -> CC.N.t -> CC.N.t -> CC.Expl.t -> unit) -> + (CC.t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit) -> unit (** Callback for when two classes containing data for this key are merged (called before) *) val on_cc_post_merge : - t -> (CC.t -> theory_actions -> CC.N.t -> CC.N.t -> unit) -> unit + t -> (CC.t -> theory_actions -> CC.Class.t -> CC.Class.t -> unit) -> unit (** Callback for when two classes containing data for this key are merged (called after)*) - val on_cc_new_term : t -> (CC.t -> CC.N.t -> term -> unit) -> unit + val on_cc_new_term : t -> (CC.t -> CC.Class.t -> term -> unit) -> unit (** Callback to add data on terms when they are added to the congruence closure *) - val on_cc_is_subterm : t -> (CC.N.t -> term -> unit) -> unit + val on_cc_is_subterm : t -> (CC.Class.t -> term -> unit) -> unit (** Callback for when a term is a subterm of another term in the congruence closure *) @@ -1083,7 +311,7 @@ module type SOLVER_INTERNAL = sig (** {3 Model production} *) type model_ask_hook = - recurse:(t -> CC.N.t -> term) -> t -> CC.N.t -> term option + recurse:(t -> CC.Class.t -> term) -> t -> CC.Class.t -> term option (** A model-production hook to query values from a theory. It takes the solver, a class, and returns @@ -1113,25 +341,14 @@ end module type SOLVER = sig module T : TERM module Lit : LIT with module T = T - - type proof - type proof_step - - module P : - PROOF - with type lit = Lit.t - and type t = proof - and type proof_step = proof_step - and type term = T.Term.t + module Proof_trace : PROOF_TRACE (** Internal solver, available to theories. *) module Solver_internal : SOLVER_INTERNAL with module T = T and module Lit = Lit - and type proof = proof - and type proof_step = proof_step - and module P = P + and module Proof_trace = Proof_trace type t (** The solver's state. *) @@ -1140,6 +357,8 @@ module type SOLVER = sig type term = T.Term.t type ty = T.Ty.t type lit = Lit.t + type proof = Proof_trace.t + type proof_step = Proof_trace.step_id (** {3 Value registry} *) @@ -1368,195 +587,3 @@ module type SOLVER = sig val pp_stats : t CCFormat.printer (** Print some statistics. What it prints exactly is unspecified. *) end - -(** Helper for the congruence closure - - This helps theories keeping track of some state for each class. - The state of a class is the monoidal combination of the state for each - term in the class (for example, the set of terms in the - class whose head symbol is a datatype constructor). *) -module type MONOID_ARG = sig - module SI : SOLVER_INTERNAL - - type t - (** Some type with a monoid structure *) - - val pp : t Fmt.printer - - val name : string - (** name of the monoid structure (short) *) - - val of_term : - SI.CC.t -> SI.CC.N.t -> SI.T.Term.t -> t option * (SI.CC.N.t * t) list - (** [of_term n t], where [t] is the term annotating node [n], - must return [maybe_m, l], where: - - [maybe_m = Some m] if [t] has monoid value [m]; - otherwise [maybe_m=None] - - [l] is a list of [(u, m_u)] where each [u]'s term - is a direct subterm of [t] - and [m_u] is the monoid value attached to [u]. - *) - - val merge : - SI.CC.t -> - SI.CC.N.t -> - t -> - SI.CC.N.t -> - t -> - SI.CC.Expl.t -> - (t, SI.CC.Expl.t) result - (** Monoidal combination of two values. - - [merge cc n1 mon1 n2 mon2 expl] returns the result of merging - monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) - when [n1] and [n2] are merged with explanation [expl]. - - @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; - or [Error expl'] if the merge is unsatisfiable. [expl'] can then be - used to trigger a conflict and undo the merge. - *) -end - -(** State for a per-equivalence-class monoid. - - Helps keep track of monoid state per equivalence class. - A theory might use one or more instance(s) of this to - aggregate some theory-specific state over all terms, with - the information of what terms are already known to be equal - potentially saving work for the theory. *) -module Monoid_of_repr (M : MONOID_ARG) : sig - type t - - val create_and_setup : ?size:int -> M.SI.t -> t - (** Create a new monoid state *) - - val push_level : t -> unit - (** Push backtracking point *) - - val pop_levels : t -> int -> unit - (** Pop [n] backtracking points *) - - val n_levels : t -> int - - val mem : t -> M.SI.CC.N.t -> bool - (** Does the CC node have a monoid value? *) - - val get : t -> M.SI.CC.N.t -> M.t option - (** Get monoid value for this CC node, if any *) - - val iter_all : t -> (M.SI.CC.repr * M.t) Iter.t - val pp : t Fmt.printer -end = struct - module SI = M.SI - module T = SI.T.Term - module N = SI.CC.N - module CC = SI.CC - module N_tbl = Backtrackable_tbl.Make (N) - module Expl = SI.CC.Expl - - type t = { - cc: CC.t; - values: M.t N_tbl.t; (* repr -> value for the class *) - field_has_value: N.bitfield; - (* bit in CC to filter out quickly classes without value *) - } - - let push_level self = N_tbl.push_level self.values - let pop_levels self n = N_tbl.pop_levels self.values n - let n_levels self = N_tbl.n_levels self.values - - let mem self n = - let res = CC.get_bitfield self.cc self.field_has_value n in - assert ( - if res then - N_tbl.mem self.values n - else - true); - res - - let get self n = - if CC.get_bitfield self.cc self.field_has_value n then - N_tbl.get self.values n - else - None - - let on_new_term self cc n (t : T.t) : unit = - (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) - let maybe_m, l = M.of_term cc n t in - (match maybe_m with - | Some v -> - Log.debugf 20 (fun k -> - k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name N.pp n M.pp - v); - SI.CC.set_bitfield cc self.field_has_value true n; - N_tbl.add self.values n v - | None -> ()); - List.iter - (fun (n_u, m_u) -> - Log.debugf 20 (fun k -> - k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])" - M.name N.pp n N.pp n_u M.pp m_u); - let n_u = CC.find cc n_u in - if CC.get_bitfield self.cc self.field_has_value n_u then ( - let m_u' = - try N_tbl.find self.values n_u - with Not_found -> - Error.errorf "node %a has bitfield but no value" N.pp n_u - in - match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with - | Error expl -> - Error.errorf - "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" - N.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl - | Ok m_u_merged -> - Log.debugf 20 (fun k -> - k - "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ - :value %a@])" - M.name N.pp n N.pp n_u M.pp m_u_merged); - N_tbl.add self.values n_u m_u_merged - ) else ( - (* just add to [n_u] *) - SI.CC.set_bitfield cc self.field_has_value true n_u; - N_tbl.add self.values n_u m_u - )) - l; - () - - let iter_all (self : t) : _ Iter.t = N_tbl.to_iter self.values - - let on_pre_merge (self : t) cc acts n1 n2 e_n1_n2 : unit = - match get self n1, get self n2 with - | Some v1, Some v2 -> - Log.debugf 5 (fun k -> - k - "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \ - :val2 %a@])@])" - M.name N.pp n1 M.pp v1 N.pp n2 M.pp v2); - (match M.merge cc n1 v1 n2 v2 e_n1_n2 with - | Ok v' -> - N_tbl.remove self.values n2; - (* only keep repr *) - N_tbl.add self.values n1 v' - | Error expl -> SI.CC.raise_conflict_from_expl cc acts expl) - | None, Some cr -> - SI.CC.set_bitfield cc self.field_has_value true n1; - N_tbl.add self.values n1 cr; - N_tbl.remove self.values n2 (* only keep reprs *) - | Some _, None -> () (* already there on the left *) - | None, None -> () - - let pp out (self : t) : unit = - let pp_e out (t, v) = Fmt.fprintf out "(@[%a@ :has %a@])" N.pp t M.pp v in - Fmt.fprintf out "(@[%a@])" (Fmt.iter pp_e) (iter_all self) - - let create_and_setup ?size (solver : SI.t) : t = - let cc = SI.cc solver in - let field_has_value = - SI.CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc - in - let self = { cc; values = N_tbl.create ?size (); field_has_value } in - SI.on_cc_new_term solver (on_new_term self); - SI.on_cc_pre_merge solver (on_pre_merge self); - self -end diff --git a/src/core/dune b/src/core/dune index 946d7159..b95bfa59 100644 --- a/src/core/dune +++ b/src/core/dune @@ -2,4 +2,6 @@ (name Sidekick_core) (public_name sidekick.core) (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.util)) + (libraries containers iter sidekick.util sidekick.sigs.proof-trace + sidekick.sigs.term sidekick.sigs.lit sidekick.sigs.proof.sat + sidekick.sigs.proof.core sidekick.sigs.cc)) diff --git a/src/mini-cc/Sidekick_mini_cc.ml b/src/mini-cc/Sidekick_mini_cc.ml index 996e7ac1..444c0f2f 100644 --- a/src/mini-cc/Sidekick_mini_cc.ml +++ b/src/mini-cc/Sidekick_mini_cc.ml @@ -1,7 +1,9 @@ -module CC_view = Sidekick_core.CC_view +module CC_view = Sidekick_sigs_cc.View + +module type TERM = Sidekick_sigs_term.S module type ARG = sig - module T : Sidekick_core.TERM + module T : TERM val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t end diff --git a/src/mini-cc/Sidekick_mini_cc.mli b/src/mini-cc/Sidekick_mini_cc.mli index 8097c446..85d5b588 100644 --- a/src/mini-cc/Sidekick_mini_cc.mli +++ b/src/mini-cc/Sidekick_mini_cc.mli @@ -1,17 +1,19 @@ -(** {1 Mini congruence closure} +(** Mini congruence closure This implementation is as simple as possible, and doesn't provide backtracking, theories, or explanations. It just decides the satisfiability of a set of (dis)equations. *) -module CC_view = Sidekick_core.CC_view +module CC_view = Sidekick_sigs_cc.View + +module type TERM = Sidekick_sigs_term.S (** Argument for the functor {!Make} It only requires a term structure, and a congruence-oriented view. *) module type ARG = sig - module T : Sidekick_core.TERM + module T : TERM val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t end diff --git a/src/mini-cc/dune b/src/mini-cc/dune index e20dc525..bbcbb9ad 100644 --- a/src/mini-cc/dune +++ b/src/mini-cc/dune @@ -1,5 +1,5 @@ (library (name Sidekick_mini_cc) (public_name sidekick.mini-cc) - (libraries containers iter sidekick.core sidekick.util) + (libraries containers iter sidekick.sigs.cc sidekick.sigs.term sidekick.util) (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) From 833fa8e038bd9cebd6945386987978d3757b7bdd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 17 Jul 2022 20:20:46 -0400 Subject: [PATCH 003/174] add Event abstraction in Util --- src/util/Event.ml | 14 ++++++++++++++ src/util/Event.mli | 12 ++++++++++++ 2 files changed, 26 insertions(+) create mode 100644 src/util/Event.ml create mode 100644 src/util/Event.mli diff --git a/src/util/Event.ml b/src/util/Event.ml new file mode 100644 index 00000000..4bee61c0 --- /dev/null +++ b/src/util/Event.ml @@ -0,0 +1,14 @@ +type 'a handler = 'a -> unit +type 'a t = { h: 'a handler Vec.t } [@@unboxed] + +let nop_handler_ = ignore + +module Emitter = struct + type nonrec 'a t = 'a t + + let emit (self : _ t) x : unit = Vec.iter self.h ~f:(fun h -> h x) + let create () : _ t = { h = Vec.make 3 nop_handler_ } +end + +let on self f = Vec.push self.h f +let of_emitter x = x diff --git a/src/util/Event.mli b/src/util/Event.mli new file mode 100644 index 00000000..12599ef8 --- /dev/null +++ b/src/util/Event.mli @@ -0,0 +1,12 @@ +type 'a t +(** An event emitting values of type ['a] *) + +module Emitter : sig + type 'a t + + val emit : 'a t -> 'a -> unit + val create : unit -> 'a t +end + +val on : 'a t -> ('a -> unit) -> unit +val of_emitter : 'a Emitter.t -> 'a t From ea752b5cf55eb61e66179efde73c972552e673ff Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 17 Jul 2022 20:21:22 -0400 Subject: [PATCH 004/174] feat: add some BACKTRACKABLE sigs --- src/sigs/sidekick_sigs.ml | 48 ++++++++++++++++++++++++++++++++-- src/util/Backtrack_stack.mli | 9 +------ src/util/Backtrackable_ref.mli | 12 +-------- src/util/Backtrackable_tbl.ml | 5 ++-- src/util/Backtrackable_tbl.mli | 5 ++-- src/util/Sidekick_util.ml | 3 +-- 6 files changed, 53 insertions(+), 29 deletions(-) diff --git a/src/sigs/sidekick_sigs.ml b/src/sigs/sidekick_sigs.ml index 8fb16dd9..4cbcd6b6 100644 --- a/src/sigs/sidekick_sigs.ml +++ b/src/sigs/sidekick_sigs.ml @@ -18,10 +18,12 @@ module type HASH = sig val hash : t -> int end +type 'a printer = Format.formatter -> 'a -> unit + module type PRINT = sig type t - val pp : t CCFormat.printer + val pp : t printer end module type EQ_HASH_PRINT = sig @@ -37,4 +39,46 @@ module type EQ_ORD_HASH_PRINT = sig include PRINT with type t := t end -type 'a printer = Format.formatter -> 'a -> unit +module type DYN_BACKTRACKABLE = sig + val n_levels : unit -> int + (** Number of levels *) + + val push_level : unit -> unit + (** Push a backtracking point *) + + val pop_levels : int -> unit + (** [pop_levels n] removes [n] levels *) +end + +module type BACKTRACKABLE0 = sig + type t + + val n_levels : t -> int + (** Number of levels *) + + val push_level : t -> unit + (** Push a backtracking point *) + + val pop_levels : t -> int -> unit + (** [pop_levels st n] removes [n] levels *) +end + +module type BACKTRACKABLE1 = sig + type 'a t + + val n_levels : _ t -> int + (** Number of levels *) + + val push_level : _ t -> unit + (** Push a backtracking point *) + + val pop_levels : _ t -> int -> unit + (** [pop_levels st n] removes [n] levels *) +end + +module type BACKTRACKABLE1_CB = sig + include BACKTRACKABLE1 + + val pop_levels : 'a t -> int -> f:('a -> unit) -> unit + (** [pop_levels st n ~f] removes [n] levels, calling [f] on every removed item *) +end diff --git a/src/util/Backtrack_stack.mli b/src/util/Backtrack_stack.mli index ced0f18f..d71ea285 100644 --- a/src/util/Backtrack_stack.mli +++ b/src/util/Backtrack_stack.mli @@ -10,13 +10,6 @@ val push : 'a t -> 'a -> unit val push_if_nonzero_level : 'a t -> 'a -> unit (** Push an element onto the stack if level > 0 *) -val n_levels : _ t -> int -(** Number of levels *) - -val push_level : _ t -> unit -(** Push a backtracking point *) - -val pop_levels : 'a t -> int -> f:('a -> unit) -> unit -(** [pop_levels st n ~f] removes [n] levels, calling [f] on every removed item *) +include Sidekick_sigs.BACKTRACKABLE1_CB with type 'a t := 'a t val iter : f:('a -> unit) -> 'a t -> unit diff --git a/src/util/Backtrackable_ref.mli b/src/util/Backtrackable_ref.mli index bb686ff3..1b2fb56b 100644 --- a/src/util/Backtrackable_ref.mli +++ b/src/util/Backtrackable_ref.mli @@ -16,14 +16,4 @@ val get : 'a t -> 'a val update : 'a t -> ('a -> 'a) -> unit (** Update the reference's current content *) -val push_level : _ t -> unit -(** Push a backtracking level, copying the current value on top of some - stack. The [copy] function will be used if it was provided in {!create}. *) - -val n_levels : _ t -> int -(** Number of saved values *) - -val pop_levels : _ t -> int -> unit -(** Pop [n] levels, restoring to the value the reference was storing [n] calls - to [push_level] earlier. - @raise Invalid_argument if [n] is bigger than [n_levels]. *) +include Sidekick_sigs.BACKTRACKABLE1 with type 'a t := 'a t diff --git a/src/util/Backtrackable_tbl.ml b/src/util/Backtrackable_tbl.ml index 08c1bfc1..ccdcfdbf 100644 --- a/src/util/Backtrackable_tbl.ml +++ b/src/util/Backtrackable_tbl.ml @@ -14,9 +14,8 @@ module type S = sig val to_iter : 'a t -> (key * 'a) Iter.t val add : 'a t -> key -> 'a -> unit val remove : _ t -> key -> unit - val push_level : _ t -> unit - val pop_levels : _ t -> int -> unit - val n_levels : _ t -> int + + include Sidekick_sigs.BACKTRACKABLE1 with type 'a t := 'a t end module type ARG = sig diff --git a/src/util/Backtrackable_tbl.mli b/src/util/Backtrackable_tbl.mli index f5cb8896..90181801 100644 --- a/src/util/Backtrackable_tbl.mli +++ b/src/util/Backtrackable_tbl.mli @@ -16,9 +16,8 @@ module type S = sig val to_iter : 'a t -> (key * 'a) Iter.t val add : 'a t -> key -> 'a -> unit val remove : _ t -> key -> unit - val push_level : _ t -> unit - val pop_levels : _ t -> int -> unit - val n_levels : _ t -> int + + include Sidekick_sigs.BACKTRACKABLE1 with type 'a t := 'a t end module type ARG = sig diff --git a/src/util/Sidekick_util.ml b/src/util/Sidekick_util.ml index e1ffadf7..44a0af18 100644 --- a/src/util/Sidekick_util.ml +++ b/src/util/Sidekick_util.ml @@ -13,7 +13,7 @@ module Int_id = Int_id module Int_tbl = Util.Int_tbl module Int_set = Util.Int_set module Int_map = Util.Int_map -module IArray = IArray +module Event = Event module Backtrack_stack = Backtrack_stack module Backtrackable_tbl = Backtrackable_tbl module Backtrackable_ref = Backtrackable_ref @@ -24,4 +24,3 @@ module Stat = Stat module Hash = Hash module Profile = Profile module Chunk_stack = Chunk_stack -module Intf = Sidekick_sigs From b2d0ea2d330e56907240b18f33a1e4a905319023 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 18 Jul 2022 23:17:29 -0400 Subject: [PATCH 005/174] add sidekick.sh launcher script --- sidekick.sh | 3 +++ 1 file changed, 3 insertions(+) create mode 100755 sidekick.sh diff --git a/sidekick.sh b/sidekick.sh new file mode 100755 index 00000000..15d7fdad --- /dev/null +++ b/sidekick.sh @@ -0,0 +1,3 @@ +#!/bin/sh +OPTS=--profile=release +exec dune exec $OPTS ./src/main/main.exe -- $@ From f3f0628261bac8f21cbf710bd1b34f6bb4be03f1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 18 Jul 2022 23:20:07 -0400 Subject: [PATCH 006/174] large refactor with signature splitting, events, etc. --- src/base-solver/sidekick_base_solver.ml | 20 +- src/base/Base_types.ml | 2 +- src/base/ID.mli | 5 +- src/base/Proof.ml | 271 +++++--- src/base/Proof.mli | 57 +- src/base/Proof_dummy.ml | 101 ++- src/base/Proof_dummy.mli | 43 +- src/base/Proof_quip.ml | 4 +- src/base/Proof_quip.mli | 2 +- src/base/Sidekick_base.ml | 3 - src/base/dune | 3 +- src/cc/Sidekick_cc.ml | 644 +++++++----------- src/cc/Sidekick_cc.mli | 33 +- src/cc/plugin/dune | 5 + src/cc/plugin/sidekick_cc_plugin.ml | 159 +++++ src/cc/plugin/sidekick_cc_plugin.mli | 21 + src/core/Sidekick_core.ml | 568 +-------------- src/lra/dune | 3 +- src/lra/sidekick_arith_lra.ml | 57 +- src/main/pure_sat_solver.ml | 84 ++- src/mini-cc/Sidekick_mini_cc.ml | 8 +- src/mini-cc/Sidekick_mini_cc.mli | 2 +- src/mini-cc/tests/sidekick_test_minicc.ml | 2 +- .../dummy/Sidekick_proof_trace_dummy.ml | 18 + src/proof-trace/dummy/dune | 6 + .../dyn/Sidekick_proof_trace_dyn.ml | 23 + src/proof-trace/dyn/dune | 6 + src/sat/Proof_dummy.ml | 24 +- src/sat/Proof_dummy.mli | 11 - src/sat/Sidekick_sat.ml | 3 +- src/sat/Solver.ml | 199 +++--- src/sat/Solver.mli | 16 +- src/sat/Solver_intf.ml | 92 ++- src/sat/dune | 6 +- src/sigs/cc/sidekick_sigs_cc.ml | 330 ++++----- src/sigs/proof-sat/sidekick_sigs_proof_sat.ml | 10 +- .../proof-trace/sidekick_sigs_proof_trace.ml | 40 +- src/sigs/smt/Sidekick_sigs_smt.ml | 597 ++++++++++++++++ src/sigs/smt/dune | 8 + src/smt-solver/Sidekick_smt_solver.ml | 221 +++--- src/smt-solver/dune | 2 +- src/smtlib/Process.ml | 19 +- src/smtlib/Process.mli | 2 +- src/tef/Sidekick_tef.real.ml | 2 +- src/th-bool-static/Sidekick_th_bool_static.ml | 78 ++- src/th-bool-static/dune | 2 +- src/th-cstor/Sidekick_th_cstor.ml | 21 +- src/th-cstor/dune | 2 +- src/th-data/Sidekick_th_data.ml | 73 +- src/th-data/dune | 2 +- src/th-data/th_intf.ml | 34 +- src/util/Event.ml | 3 +- src/util/Event.mli | 5 +- src/util/gen/dune | 2 + src/util/gen/gen_vec.ml.tmp | 2 + 55 files changed, 2133 insertions(+), 1823 deletions(-) create mode 100644 src/cc/plugin/dune create mode 100644 src/cc/plugin/sidekick_cc_plugin.ml create mode 100644 src/cc/plugin/sidekick_cc_plugin.mli create mode 100644 src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml create mode 100644 src/proof-trace/dummy/dune create mode 100644 src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml create mode 100644 src/proof-trace/dyn/dune delete mode 100644 src/sat/Proof_dummy.mli create mode 100644 src/sigs/smt/Sidekick_sigs_smt.ml create mode 100644 src/sigs/smt/dune create mode 100644 src/util/gen/dune create mode 100644 src/util/gen/gen_vec.ml.tmp diff --git a/src/base-solver/sidekick_base_solver.ml b/src/base-solver/sidekick_base_solver.ml index 05695fe2..75b2f777 100644 --- a/src/base-solver/sidekick_base_solver.ml +++ b/src/base-solver/sidekick_base_solver.ml @@ -11,14 +11,16 @@ module Solver_arg = struct module T = Sidekick_base.Solver_arg module Lit = Sidekick_base.Lit - let cc_view = Term.cc_view + let view_as_cc = Term.cc_view let mk_eq = Term.eq let is_valid_literal _ = true - module P = Sidekick_base.Proof + module Proof_trace = Sidekick_base.Proof.Proof_trace + module Rule_core = Sidekick_base.Proof.Rule_core + module Rule_sat = Sidekick_base.Proof.Rule_sat - type proof = P.t - type proof_step = P.proof_step + type step_id = Proof_trace.A.step_id + type rule = Proof_trace.A.rule end module Solver = Sidekick_smt_solver.Make (Solver_arg) @@ -29,7 +31,6 @@ module Th_data = Sidekick_th_data.Make (struct module S = Solver open! Base_types open! Sidekick_th_data - module Proof = Proof module Cstor = Cstor let as_datatype ty = @@ -64,7 +65,7 @@ module Th_data = Sidekick_th_data.Make (struct let ty_is_finite = Ty.finite let ty_set_is_finite = Ty.set_finite - module P = Proof + module P = Proof.Rule_data end) (** Reducing boolean formulas to clauses *) @@ -74,12 +75,7 @@ module Th_bool = Sidekick_th_bool_static.Make (struct type term = S.T.Term.t include Form - - let lemma_bool_tauto = Proof.lemma_bool_tauto - let lemma_bool_c = Proof.lemma_bool_c - let lemma_bool_equiv = Proof.lemma_bool_equiv - let lemma_ite_true = Proof.lemma_ite_true - let lemma_ite_false = Proof.lemma_ite_false + module P = Proof.Rule_bool end) module Gensym = struct diff --git a/src/base/Base_types.ml b/src/base/Base_types.ml index f420e075..efd3852b 100644 --- a/src/base/Base_types.ml +++ b/src/base/Base_types.ml @@ -3,7 +3,7 @@ module Vec = Sidekick_util.Vec module Log = Sidekick_util.Log module Fmt = CCFormat -module CC_view = Sidekick_core.CC_view +module CC_view = Sidekick_sigs_cc.View module Proof_ser = Sidekick_base_proof_trace.Proof_ser module Storage = Sidekick_base_proof_trace.Storage diff --git a/src/base/ID.mli b/src/base/ID.mli index 32611ac1..0e96c3fa 100644 --- a/src/base/ID.mli +++ b/src/base/ID.mli @@ -37,10 +37,7 @@ val to_string : t -> string val to_string_full : t -> string (** Printer name and unique counter for this ID. *) -include Intf.EQ with type t := t -include Intf.ORD with type t := t -include Intf.HASH with type t := t -include Intf.PRINT with type t := t +include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t val pp_name : t CCFormat.printer diff --git a/src/base/Proof.ml b/src/base/Proof.ml index 96de480e..86aa110f 100644 --- a/src/base/Proof.ml +++ b/src/base/Proof.ml @@ -30,27 +30,13 @@ end (* a step is just a unique integer ID. The actual step is stored in the chunk_stack. *) -type proof_step = Proof_ser.ID.t +type step_id = Proof_ser.ID.t type term_id = Proof_ser.ID.t type lit = Lit.t type term = Term.t -type t = { - mutable enabled: bool; - buf: Buffer.t; - out: Proof_ser.Bare.Encode.t; - mutable storage: Storage.t; - dispose: unit -> unit; - mutable steps_writer: CS.Writer.t; - mutable next_id: int; - map_term: term_id Term.Tbl.t; (* term -> proof ID *) - map_fun: term_id Fun.Tbl.t; -} - -type proof_rule = t -> proof_step - module Step_vec = struct - type elt = proof_step + type elt = step_id type t = elt Vec.t let get = Vec.get @@ -71,6 +57,18 @@ module Step_vec = struct let to_iter = Vec.to_iter end +type t = { + mutable enabled: bool; + buf: Buffer.t; + out: Proof_ser.Bare.Encode.t; + mutable storage: Storage.t; + dispose: unit -> unit; + mutable steps_writer: CS.Writer.t; + mutable next_id: int; + map_term: term_id Term.Tbl.t; (* term -> proof ID *) + map_fun: term_id Fun.Tbl.t; +} + let disable (self : t) : unit = self.enabled <- false; self.storage <- Storage.No_store; @@ -114,7 +112,7 @@ let create ?(config = Config.default) () : t = let empty = create ~config:Config.empty () let iter_steps_backward (self : t) = Storage.iter_steps_backward self.storage -let dummy_step : proof_step = Int32.min_int +let dummy_step : step_id = Int32.min_int let[@inline] enabled (self : t) = self.enabled (* allocate a unique ID to refer to an event in the trace *) @@ -178,119 +176,178 @@ let emit_lit_ (self : t) (lit : Lit.t) : term_id = else Int32.neg t -let emit_ (self : t) f : proof_step = - if enabled self then ( - let view = f () in - let id = alloc_id self in - emit_step_ self { PS.Step.id; view }; - id - ) else - dummy_step - let emit_no_return_ (self : t) f : unit = if enabled self then ( let view = f () in emit_step_ self { PS.Step.id = -1l; view } ) -let[@inline] emit_redundant_clause lits ~hyps (self : t) = - emit_ self @@ fun () -> - let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in - let clause = Proof_ser.{ Clause.lits } in - let hyps = Iter.to_array hyps in - PS.Step_view.Step_rup { res = clause; hyps } +let emit_unsat c (self : t) : unit = + emit_no_return_ self @@ fun () -> PS.(Step_view.Step_unsat { Step_unsat.c }) -let emit_input_clause (lits : Lit.t Iter.t) (self : t) = - emit_ self @@ fun () -> - let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in - PS.(Step_view.Step_input { Step_input.c = { Clause.lits } }) +(** What a rule can return. It can return an existing step, or ask to create + a new one. *) +type rule_res = R_new of PS.Step_view.t | R_old of step_id -let define_term t u (self : t) = - emit_ self @@ fun () -> - let t = emit_term_ self t and u = emit_term_ self u in - PS.(Step_view.Expr_def { Expr_def.c = t; rhs = u }) +type rule = t -> rule_res -let proof_p1 rw_with c (self : t) = - emit_ self @@ fun () -> - PS.(Step_view.Step_proof_p1 { Step_proof_p1.c; rw_with }) - -let proof_r1 unit c (self : t) = - emit_ self @@ fun () -> PS.(Step_view.Step_proof_r1 { Step_proof_r1.c; unit }) - -let proof_res ~pivot c1 c2 (self : t) = - emit_ self @@ fun () -> - let pivot = emit_term_ self pivot in - PS.(Step_view.Step_proof_res { Step_proof_res.c1; c2; pivot }) - -let lemma_preprocess t u ~using (self : t) = - emit_ self @@ fun () -> - let t = emit_term_ self t and u = emit_term_ self u in - let using = using |> Iter.to_array in - PS.(Step_view.Step_preprocess { Step_preprocess.t; u; using }) - -let lemma_true t (self : t) = - emit_ self @@ fun () -> - let t = emit_term_ self t in - PS.(Step_view.Step_true { Step_true.true_ = t }) - -let lemma_cc lits (self : t) = - emit_ self @@ fun () -> - let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in - PS.(Step_view.Step_cc { Step_cc.eqns = lits }) - -let lemma_rw_clause c ~res ~using (self : t) = +let emit_rule_ (self : t) (f : rule) : step_id = if enabled self then ( - let using = Iter.to_array using in - if Array.length using = 0 then - c - (* useless step *) - else - emit_ self @@ fun () -> - let lits = Iter.map (emit_lit_ self) res |> Iter.to_array in - let res = Proof_ser.{ Clause.lits } in - PS.(Step_view.Step_clause_rw { Step_clause_rw.c; res; using }) + match f self with + | R_old id -> id + | R_new view -> + let id = alloc_id self in + emit_step_ self { PS.Step.id; view }; + id ) else dummy_step -(* TODO *) -let with_defs _ _ (_pr : t) = dummy_step +module Proof_trace = struct + module A = struct + type nonrec step_id = step_id + type nonrec rule = rule + + module Step_vec = Step_vec + end + + type nonrec t = t + + let enabled = enabled + let add_step = emit_rule_ + let[@inline] add_unsat self id = emit_unsat id self + let delete _ _ = () +end + +let r_new v = R_new v +let r_old id = R_old id + +module Rule_sat = struct + type nonrec lit = lit + type nonrec step_id = step_id + type nonrec rule = rule + + let sat_redundant_clause lits ~hyps : rule = + fun self -> + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + let clause = Proof_ser.{ Clause.lits } in + let hyps = Iter.to_array hyps in + r_new @@ PS.Step_view.Step_rup { res = clause; hyps } + + let sat_input_clause (lits : Lit.t Iter.t) : rule = + fun self -> + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + r_new @@ PS.(Step_view.Step_input { Step_input.c = { Clause.lits } }) + + (* TODO *) + let sat_unsat_core _ (_pr : t) = r_old dummy_step +end + +module Rule_core = struct + type nonrec term = term + type nonrec step_id = step_id + type nonrec rule = rule + type nonrec lit = lit + + let sat_redundant_clause lits ~hyps : rule = + fun self -> + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + let clause = Proof_ser.{ Clause.lits } in + let hyps = Iter.to_array hyps in + r_new @@ PS.Step_view.Step_rup { res = clause; hyps } + + let define_term t u : rule = + fun self -> + let t = emit_term_ self t and u = emit_term_ self u in + r_new @@ PS.(Step_view.Expr_def { Expr_def.c = t; rhs = u }) + + let proof_p1 rw_with c : rule = + fun _self -> + r_new @@ PS.(Step_view.Step_proof_p1 { Step_proof_p1.c; rw_with }) + + let proof_r1 unit c : rule = + fun _self -> r_new @@ PS.(Step_view.Step_proof_r1 { Step_proof_r1.c; unit }) + + let proof_res ~pivot c1 c2 : rule = + fun self -> + let pivot = emit_term_ self pivot in + r_new @@ PS.(Step_view.Step_proof_res { Step_proof_res.c1; c2; pivot }) + + let lemma_preprocess t u ~using : rule = + fun self -> + let t = emit_term_ self t and u = emit_term_ self u in + let using = using |> Iter.to_array in + r_new @@ PS.(Step_view.Step_preprocess { Step_preprocess.t; u; using }) + + let lemma_true t : rule = + fun self -> + let t = emit_term_ self t in + r_new @@ PS.(Step_view.Step_true { Step_true.true_ = t }) + + let lemma_cc lits : rule = + fun self -> + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + r_new @@ PS.(Step_view.Step_cc { Step_cc.eqns = lits }) + + let lemma_rw_clause c ~res ~using : rule = + fun self -> + let using = Iter.to_array using in + if Array.length using = 0 then + r_old c + (* useless step *) + else ( + let lits = Iter.map (emit_lit_ self) res |> Iter.to_array in + let res = Proof_ser.{ Clause.lits } in + r_new @@ PS.(Step_view.Step_clause_rw { Step_clause_rw.c; res; using }) + ) + + (* TODO *) + let with_defs _ _ (_pr : t) = r_old dummy_step +end (* not useful *) let del_clause _ _ (_pr : t) = () -(* TODO *) -let emit_unsat_core _ (_pr : t) = dummy_step +module Rule_bool = struct + type nonrec term = term + type nonrec lit = lit + type nonrec rule = rule -let emit_unsat c (self : t) : unit = - emit_no_return_ self @@ fun () -> PS.(Step_view.Step_unsat { Step_unsat.c }) + let lemma_bool_tauto lits : rule = + fun self -> + let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in + r_new @@ PS.(Step_view.Step_bool_tauto { Step_bool_tauto.lits }) -let lemma_bool_tauto lits (self : t) = - emit_ self @@ fun () -> - let lits = Iter.map (emit_lit_ self) lits |> Iter.to_array in - PS.(Step_view.Step_bool_tauto { Step_bool_tauto.lits }) + let lemma_bool_c rule (ts : Term.t list) : rule = + fun self -> + let exprs = Util.array_of_list_map (emit_term_ self) ts in + r_new @@ PS.(Step_view.Step_bool_c { Step_bool_c.exprs; rule }) -let lemma_bool_c rule (ts : Term.t list) (self : t) = - emit_ self @@ fun () -> - let exprs = ts |> Util.array_of_list_map (emit_term_ self) in - PS.(Step_view.Step_bool_c { Step_bool_c.exprs; rule }) + let lemma_bool_equiv _ _ _ = r_old dummy_step + let lemma_ite_true ~ite:_ _ = r_old dummy_step + let lemma_ite_false ~ite:_ _ = r_old dummy_step +end (* TODO *) -let lemma_lra _ _ = dummy_step -let lemma_relax_to_lra _ _ = dummy_step -let lemma_lia _ _ = dummy_step -let lemma_bool_equiv _ _ _ = dummy_step -let lemma_ite_true ~ite:_ _ = dummy_step -let lemma_ite_false ~ite:_ _ = dummy_step -let lemma_isa_cstor ~cstor_t:_ _ (_pr : t) = dummy_step -let lemma_select_cstor ~cstor_t:_ _ (_pr : t) = dummy_step -let lemma_isa_split _ _ (_pr : t) = dummy_step -let lemma_isa_sel _ (_pr : t) = dummy_step -let lemma_isa_disj _ _ (_pr : t) = dummy_step -let lemma_cstor_inj _ _ _ (_pr : t) = dummy_step -let lemma_cstor_distinct _ _ (_pr : t) = dummy_step -let lemma_acyclicity _ (_pr : t) = dummy_step +let lemma_lra _ _ = r_old dummy_step +let lemma_relax_to_lra _ _ = r_old dummy_step +let lemma_lia _ _ = r_old dummy_step + +module Rule_data = struct + type nonrec lit = lit + type nonrec rule = rule + type nonrec term = term + + let lemma_isa_cstor ~cstor_t:_ _ (_pr : t) = r_old dummy_step + let lemma_select_cstor ~cstor_t:_ _ (_pr : t) = r_old dummy_step + let lemma_isa_split _ _ (_pr : t) = r_old dummy_step + let lemma_isa_sel _ (_pr : t) = r_old dummy_step + let lemma_isa_disj _ _ (_pr : t) = r_old dummy_step + let lemma_cstor_inj _ _ _ (_pr : t) = r_old dummy_step + let lemma_cstor_distinct _ _ (_pr : t) = r_old dummy_step + let lemma_acyclicity _ (_pr : t) = r_old dummy_step +end module Unsafe_ = struct - let[@inline] id_of_proof_step_ (p : proof_step) : proof_step = p + let[@inline] id_of_proof_step_ (p : step_id) : step_id = p end diff --git a/src/base/Proof.mli b/src/base/Proof.mli index 50880768..3939fc79 100644 --- a/src/base/Proof.mli +++ b/src/base/Proof.mli @@ -28,39 +28,42 @@ end (** {2 Main Proof API} *) -type t +module Proof_trace : Sidekick_core.PROOF_TRACE + +type t = Proof_trace.t (** A container for the whole proof *) -type proof_step -(** A proof step in the trace. +type step_id = Proof_trace.A.step_id +type rule = Proof_trace.A.rule - The proof will store all steps, and at the end when we find the empty clause - we can filter them to keep only the relevant ones. *) +module Rule_sat : + Sidekick_core.SAT_PROOF_RULES + with type rule = rule + and type lit = Lit.t + and type step_id = step_id -include - Sidekick_core.PROOF - with type t := t - and type proof_step := proof_step +module Rule_core : + Sidekick_core.PROOF_CORE + with type rule = rule + and type lit = Lit.t + and type term = Term.t + and type step_id = step_id + +val lemma_lra : Lit.t Iter.t -> rule +val lemma_relax_to_lra : Lit.t Iter.t -> rule +val lemma_lia : Lit.t Iter.t -> rule + +module Rule_data : + Sidekick_th_data.PROOF_RULES + with type rule = rule and type lit = Lit.t and type term = Term.t -val lemma_lra : Lit.t Iter.t -> proof_rule -val lemma_relax_to_lra : Lit.t Iter.t -> proof_rule -val lemma_lia : Lit.t Iter.t -> proof_rule - -include - Sidekick_th_data.PROOF - with type proof := t - and type proof_step := proof_step - and type lit := Lit.t - and type term := Term.t - -include - Sidekick_th_bool_static.PROOF - with type proof := t - and type proof_step := proof_step - and type lit := Lit.t - and type term := Term.t +module Rule_bool : + Sidekick_th_bool_static.PROOF_RULES + with type rule = rule + and type lit = Lit.t + and type term = Term.t (** {2 Creation} *) @@ -83,5 +86,5 @@ val iter_steps_backward : t -> Proof_ser.Step.t Iter.t a dummy backend. *) module Unsafe_ : sig - val id_of_proof_step_ : proof_step -> Proof_ser.ID.t + val id_of_proof_step_ : step_id -> Proof_ser.ID.t end diff --git a/src/base/Proof_dummy.ml b/src/base/Proof_dummy.ml index 9818b4f0..af268417 100644 --- a/src/base/Proof_dummy.ml +++ b/src/base/Proof_dummy.ml @@ -2,40 +2,75 @@ open Base_types type lit = Lit.t type term = Term.t -type t = unit -type proof_step = unit -type proof_rule = t -> proof_step -module Step_vec = Vec_unit +module Arg = struct + type nonrec rule = unit + type nonrec step_id = unit + + module Step_vec = Vec_unit + + let dummy_step_id = () +end + +include Sidekick_proof_trace_dummy.Make (Arg) + +type rule = A.rule +type step_id = A.step_id let create () : t = () let with_proof _ _ = () -let enabled (_pr : t) = false -let del_clause _ _ (_pr : t) = () -let emit_redundant_clause _ ~hyps:_ _ = () -let emit_input_clause _ _ = () -let define_term _ _ _ = () -let emit_unsat _ _ = () -let proof_p1 _ _ (_pr : t) = () -let proof_r1 _ _ (_pr : t) = () -let proof_res ~pivot:_ _ _ (_pr : t) = () -let emit_unsat_core _ (_pr : t) = () -let lemma_preprocess _ _ ~using:_ (_pr : t) = () -let lemma_true _ _ = () -let lemma_cc _ _ = () -let lemma_rw_clause _ ~res:_ ~using:_ (_pr : t) = () -let with_defs _ _ (_pr : t) = () -let lemma_lra _ _ = () -let lemma_bool_tauto _ _ = () -let lemma_bool_c _ _ _ = () -let lemma_bool_equiv _ _ _ = () -let lemma_ite_true ~ite:_ _ = () -let lemma_ite_false ~ite:_ _ = () -let lemma_isa_cstor ~cstor_t:_ _ (_pr : t) = () -let lemma_select_cstor ~cstor_t:_ _ (_pr : t) = () -let lemma_isa_split _ _ (_pr : t) = () -let lemma_isa_sel _ (_pr : t) = () -let lemma_isa_disj _ _ (_pr : t) = () -let lemma_cstor_inj _ _ _ (_pr : t) = () -let lemma_cstor_distinct _ _ (_pr : t) = () -let lemma_acyclicity _ (_pr : t) = () + +module Rule_sat = struct + type nonrec rule = rule + type nonrec step_id = step_id + type nonrec lit = lit + + let sat_redundant_clause _ ~hyps:_ = () + let sat_input_clause _ = () + let sat_unsat_core _ = () +end + +module Rule_core = struct + type nonrec rule = rule + type nonrec step_id = step_id + type nonrec lit = lit + type nonrec term = term + + let define_term _ _ = () + let proof_p1 _ _ = () + let proof_r1 _ _ = () + let proof_res ~pivot:_ _ _ = () + let lemma_preprocess _ _ ~using:_ = () + let lemma_true _ = () + let lemma_cc _ = () + let lemma_rw_clause _ ~res:_ ~using:_ = () + let with_defs _ _ = () +end + +let lemma_lra _ = () + +module Rule_bool = struct + type nonrec rule = rule + type nonrec lit = lit + + let lemma_bool_tauto _ = () + let lemma_bool_c _ _ = () + let lemma_bool_equiv _ _ = () + let lemma_ite_true ~ite:_ = () + let lemma_ite_false ~ite:_ = () +end + +module Rule_data = struct + type nonrec rule = rule + type nonrec lit = lit + type nonrec term = term + + let lemma_isa_cstor ~cstor_t:_ _ = () + let lemma_select_cstor ~cstor_t:_ _ = () + let lemma_isa_split _ _ = () + let lemma_isa_sel _ = () + let lemma_isa_disj _ _ = () + let lemma_cstor_inj _ _ _ = () + let lemma_cstor_distinct _ _ = () + let lemma_acyclicity _ = () +end diff --git a/src/base/Proof_dummy.mli b/src/base/Proof_dummy.mli index 73620f18..3aca187e 100644 --- a/src/base/Proof_dummy.mli +++ b/src/base/Proof_dummy.mli @@ -2,28 +2,35 @@ open Base_types -include - Sidekick_core.PROOF - with type t = private unit - and type proof_step = private unit +module Arg : + Sidekick_sigs_proof_trace.ARG with type rule = unit and type step_id = unit + +include Sidekick_sigs_proof_trace.S with module A = Arg + +type rule = A.rule +type step_id = A.step_id + +module Rule_sat : + Sidekick_sigs_proof_sat.S with type rule = rule and type lit = Lit.t + +module Rule_core : + Sidekick_core.PROOF_CORE + with type rule = rule and type lit = Lit.t and type term = Term.t -type proof_rule = t -> proof_step - val create : unit -> t -val lemma_lra : Lit.t Iter.t -> proof_rule +val lemma_lra : Lit.t Iter.t -> rule -include - Sidekick_th_data.PROOF - with type proof := t - and type proof_step := proof_step - and type lit := Lit.t - and type term := Term.t +module Rule_data : + Sidekick_th_data.PROOF_RULES + with type rule = rule + and type lit = Lit.t + and type term = Term.t -include - Sidekick_th_bool_static.PROOF - with type proof := t - and type proof_step := proof_step - and type lit := Lit.t +module Rule_bool : + Sidekick_th_bool_static.PROOF_RULES + with type rule = rule + and type lit = Lit.t + and type term = Term.t and type term := Term.t diff --git a/src/base/Proof_quip.ml b/src/base/Proof_quip.ml index e7b8696a..1b6833f9 100644 --- a/src/base/Proof_quip.ml +++ b/src/base/Proof_quip.ml @@ -8,7 +8,7 @@ type t = P.t module type CONV_ARG = sig val proof : Proof.t - val unsat : Proof.proof_step + val unsat : Proof.step_id end module Make_lazy_tbl (T : sig @@ -318,7 +318,7 @@ end = struct P.composite_a steps end -let of_proof (self : Proof.t) ~(unsat : Proof.proof_step) : P.t = +let of_proof (self : Proof.t) ~(unsat : Proof.step_id) : P.t = let module C = Conv (struct let proof = self let unsat = unsat diff --git a/src/base/Proof_quip.mli b/src/base/Proof_quip.mli index 374a3198..589d6f84 100644 --- a/src/base/Proof_quip.mli +++ b/src/base/Proof_quip.mli @@ -4,7 +4,7 @@ type t -val of_proof : Proof.t -> unsat:Proof.proof_step -> t +val of_proof : Proof.t -> unsat:Proof.step_id -> t type out_format = Sidekick_quip.out_format = Sexp | CSexp diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index a1e65705..bbd89507 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -40,6 +40,3 @@ module Lit = Lit module Proof_dummy = Proof_dummy module Proof = Proof module Proof_quip = Proof_quip - -(* re-export *) -module IArray = IArray diff --git a/src/base/dune b/src/base/dune index 06d7cb19..2846b4e8 100644 --- a/src/base/dune +++ b/src/base/dune @@ -4,5 +4,6 @@ (synopsis "Base term definitions for the standalone SMT solver and library") (libraries containers iter sidekick.core sidekick.util sidekick.lit sidekick-base.proof-trace sidekick.quip sidekick.arith-lra - sidekick.th-bool-static sidekick.th-data sidekick.zarith zarith) + sidekick.th-bool-static sidekick.th-data sidekick.zarith zarith + sidekick.proof-trace.dummy) (flags :standard -w -32 -open Sidekick_util)) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index d2f1ea2f..32792284 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,6 +1,30 @@ -include Sidekick_sigs_cc +open Sidekick_sigs_cc +module View = View open View +module type S = sig + include S + + val create : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> term_store -> proof_trace -> t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. *) + + (**/**) + + module Debug_ : sig + val pp : t Fmt.printer + (** Print the whole CC *) + end + + (**/**) +end + +module type ARG = ARG + module Make (A : ARG) : S with module T = A.T @@ -14,8 +38,8 @@ module Make (A : ARG) : open struct (* proof rules *) - module Rules_ = A.CC.Proof_rules - module P = Sidekick_sigs_proof_trace.Utils_ (Proof_trace) + module Rules_ = A.Rule_core + module P = Proof_trace end type term = T.Term.t @@ -23,15 +47,15 @@ module Make (A : ARG) : type term_store = T.Term.store type lit = Lit.t type fun_ = T.Fun.t - type proof = A.Proof_trace.t - type proof_step = A.Proof_trace.step_id + type proof_trace = A.Proof_trace.t + type step_id = A.Proof_trace.A.step_id type actions = - (module ACTIONS + (module DYN_ACTIONS with type term = T.Term.t and type lit = Lit.t - and type proof = proof - and type proof_step = proof_step) + and type proof_trace = proof_trace + and type step_id = step_id) module Bits : sig type t = private int @@ -107,8 +131,7 @@ module Make (A : ARG) : | E_merge_t of term * term | E_congruence of node * node (* caused by normal congruence *) | E_and of explanation * explanation - | E_theory of - term * term * (term * term * explanation list) list * proof_step + | E_theory of term * term * (term * term * explanation list) list * step_id | E_same_val of node * node type repr = node @@ -237,7 +260,7 @@ module Make (A : ARG) : type t = { lits: lit list; same_value: (Class.t * Class.t) list; - pr: proof -> proof_step; + pr: proof_trace -> step_id; } let[@inline] is_semantic (self : t) : bool = @@ -320,7 +343,7 @@ module Make (A : ARG) : type t = { tst: term_store; - proof: proof; + proof: proof_trace; tbl: node T_tbl.t; (* internalization [term -> node] *) signatures_tbl: node Sig_tbl.t; (* map a signature to the corresponding node in some equivalence class. @@ -333,6 +356,7 @@ module Make (A : ARG) : pending: node Vec.t; combine: combine_task Vec.t; t_to_val: (node * value) T_b_tbl.t; + (* TODO: remove this, make it a plugin/EGG instead *) (* [repr -> (t,val)] where [repr = t] and [t := val] in the model *) val_to_t: node T_b_tbl.t; (* [val -> t] where [t := val] in the model *) undo: (unit -> unit) Backtrack_stack.t; @@ -342,12 +366,12 @@ module Make (A : ARG) : true_: node lazy_t; false_: node lazy_t; mutable model_mode: bool; - mutable on_pre_merge: ev_on_pre_merge list; - mutable on_post_merge: ev_on_post_merge list; - mutable on_new_term: ev_on_new_term list; - mutable on_conflict: ev_on_conflict list; - mutable on_propagate: ev_on_propagate list; - mutable on_is_subterm: ev_on_is_subterm list; + on_pre_merge: (t * actions * Class.t * Class.t * Expl.t) Event.Emitter.t; + on_post_merge: (t * actions * Class.t * Class.t) Event.Emitter.t; + on_new_term: (t * Class.t * term) Event.Emitter.t; + on_conflict: ev_on_conflict Event.Emitter.t; + on_propagate: (t * lit * (unit -> lit list * step_id)) Event.Emitter.t; + on_is_subterm: (t * Class.t * term) Event.Emitter.t; count_conflict: int Stat.counter; count_props: int Stat.counter; count_merge: int Stat.counter; @@ -359,75 +383,73 @@ module Make (A : ARG) : several times. See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) - and ev_on_pre_merge = t -> actions -> Class.t -> Class.t -> Expl.t -> unit - and ev_on_post_merge = t -> actions -> Class.t -> Class.t -> unit - and ev_on_new_term = t -> Class.t -> term -> unit - and ev_on_conflict = t -> th:bool -> lit list -> unit - and ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit - and ev_on_is_subterm = Class.t -> term -> unit + and ev_on_conflict = { cc: t; th: bool; c: lit list } let[@inline] size_ (r : repr) = r.n_size - let[@inline] n_true cc = Lazy.force cc.true_ - let[@inline] n_false cc = Lazy.force cc.false_ + let[@inline] n_true self = Lazy.force self.true_ + let[@inline] n_false self = Lazy.force self.false_ - let n_bool cc b = + let n_bool self b = if b then - n_true cc + n_true self else - n_false cc + n_false self - let[@inline] term_store cc = cc.tst - let[@inline] proof cc = cc.proof + let[@inline] term_store self = self.tst + let[@inline] proof self = self.proof - let allocate_bitfield ~descr cc = + let allocate_bitfield self ~descr = Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); - Bits.mk_field cc.bitgen + Bits.mk_field self.bitgen - let[@inline] on_backtrack cc f : unit = - Backtrack_stack.push_if_nonzero_level cc.undo f + let[@inline] on_backtrack self f : unit = + Backtrack_stack.push_if_nonzero_level self.undo f let[@inline] get_bitfield _cc field n = Class.get_field field n - let set_bitfield cc field b n = + let set_bitfield self field b n = let old = Class.get_field field n in if old <> b then ( - on_backtrack cc (fun () -> Class.set_field field old n); + on_backtrack self (fun () -> Class.set_field field old n); Class.set_field field b n ) (* check if [t] is in the congruence closure. Invariant: [in_cc t ∧ do_cc t => forall u subterm t, in_cc u] *) - let[@inline] mem (cc : t) (t : term) : bool = T_tbl.mem cc.tbl t + let[@inline] mem (self : t) (t : term) : bool = T_tbl.mem self.tbl t - (* print full state *) - let pp_full out (cc : t) : unit = - let pp_next out n = Fmt.fprintf out "@ :next %a" Class.pp n.n_next in - let pp_root out n = - if Class.is_root n then - Fmt.string out " :is-root" - else - Fmt.fprintf out "@ :root %a" Class.pp n.n_root - in - let pp_expl out n = - match n.n_expl with - | FL_none -> () - | FL_some e -> - Fmt.fprintf out " (@[:forest %a :expl %a@])" Class.pp e.next Expl.pp - e.expl - in - let pp_n out n = - Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp n.n_term pp_root n pp_next n - pp_expl n - and pp_sig_e out (s, n) = - Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s Class.pp n pp_root - n - in - Fmt.fprintf out - "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ %a@])@])" - (Util.pp_iter ~sep:" " pp_n) - (T_tbl.values cc.tbl) - (Util.pp_iter ~sep:" " pp_sig_e) - (Sig_tbl.to_iter cc.signatures_tbl) + module Debug_ = struct + (* print full state *) + let pp out (self : t) : unit = + let pp_next out n = Fmt.fprintf out "@ :next %a" Class.pp n.n_next in + let pp_root out n = + if Class.is_root n then + Fmt.string out " :is-root" + else + Fmt.fprintf out "@ :root %a" Class.pp n.n_root + in + let pp_expl out n = + match n.n_expl with + | FL_none -> () + | FL_some e -> + Fmt.fprintf out " (@[:forest %a :expl %a@])" Class.pp e.next Expl.pp + e.expl + in + let pp_n out n = + Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp n.n_term pp_root n pp_next n + pp_expl n + and pp_sig_e out (s, n) = + Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s Class.pp n + pp_root n + in + Fmt.fprintf out + "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ \ + %a@])@])" + (Util.pp_iter ~sep:" " pp_n) + (T_tbl.values self.tbl) + (Util.pp_iter ~sep:" " pp_sig_e) + (Sig_tbl.to_iter self.signatures_tbl) + end (* compute up-to-date signature *) let update_sig (s : signature) : Signature.t = @@ -439,50 +461,50 @@ module Make (A : ARG) : Sig_tbl.get cc.signatures_tbl s (* add to signature table. Assume it's not present already *) - let add_signature cc (s : signature) (n : node) : unit = - assert (not @@ Sig_tbl.mem cc.signatures_tbl s); + let add_signature self (s : signature) (n : node) : unit = + assert (not @@ Sig_tbl.mem self.signatures_tbl s); Log.debugf 50 (fun k -> k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s Class.pp n); - on_backtrack cc (fun () -> Sig_tbl.remove cc.signatures_tbl s); - Sig_tbl.add cc.signatures_tbl s n + on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); + Sig_tbl.add self.signatures_tbl s n - let push_pending cc t : unit = + let push_pending self t : unit = Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" Class.pp t); - Vec.push cc.pending t + Vec.push self.pending t - let merge_classes cc t u e : unit = + let merge_classes self t u e : unit = if t != u && not (same_class t u) then ( Log.debugf 50 (fun k -> k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" Class.pp t Class.pp u Expl.pp e); - Vec.push cc.combine @@ CT_merge (t, u, e) + Vec.push self.combine @@ CT_merge (t, u, e) ) (* re-root the explanation tree of the equivalence class of [n] so that it points to [n]. postcondition: [n.n_expl = None] *) - let[@unroll 2] rec reroot_expl (cc : t) (n : node) : unit = + let[@unroll 2] rec reroot_expl (self : t) (n : node) : unit = match n.n_expl with | FL_none -> () (* already root *) | FL_some { next = u; expl = e_n_u } -> (* reroot to [u], then invert link between [u] and [n] *) - reroot_expl cc u; + reroot_expl self u; u.n_expl <- FL_some { next = n; expl = e_n_u }; n.n_expl <- FL_none - let raise_conflict_ (cc : t) ~th (acts : actions) (e : lit list) - (p : proof_step) : _ = + let raise_conflict_ (cc : t) ~th (acts : actions) (e : lit list) (p : step_id) + : _ = Profile.instant "cc.conflict"; (* clear tasks queue *) Vec.clear cc.pending; Vec.clear cc.combine; - List.iter (fun f -> f cc ~th e) cc.on_conflict; + Event.emit cc.on_conflict { cc; th; c = e }; Stat.incr cc.count_conflict; let (module A) = acts in A.raise_conflict e p - let[@inline] all_classes cc : repr Iter.t = - T_tbl.values cc.tbl |> Iter.filter Class.is_root + let[@inline] all_classes self : repr Iter.t = + T_tbl.values self.tbl |> Iter.filter Class.is_root (* find the closest common ancestor of [a] and [b] in the proof forest. @@ -493,10 +515,10 @@ module Make (A : ARG) : - if [n] is marked, then all the predecessors of [n] from [a] or [b] are marked too. *) - let find_common_ancestor cc (a : node) (b : node) : node = + let find_common_ancestor self (a : node) (b : node) : node = (* catch up to the other node *) let rec find1 a = - if Class.get_field cc.field_marked_explain a then + if Class.get_field self.field_marked_explain a then a else ( match a.n_expl with @@ -507,13 +529,13 @@ module Make (A : ARG) : let rec find2 a b = if Class.equal a b then a - else if Class.get_field cc.field_marked_explain a then + else if Class.get_field self.field_marked_explain a then a - else if Class.get_field cc.field_marked_explain b then + else if Class.get_field self.field_marked_explain b then b else ( - Class.set_field cc.field_marked_explain true a; - Class.set_field cc.field_marked_explain true b; + Class.set_field self.field_marked_explain true a; + Class.set_field self.field_marked_explain true b; match a.n_expl, b.n_expl with | FL_some r1, FL_some r2 -> find2 r1.next r2.next | FL_some r, FL_none -> find1 r.next @@ -525,8 +547,8 @@ module Make (A : ARG) : (* cleanup tags on nodes traversed in [find2] *) let rec cleanup_ n = - if Class.get_field cc.field_marked_explain n then ( - Class.set_field cc.field_marked_explain false n; + if Class.get_field self.field_marked_explain n then ( + Class.set_field self.field_marked_explain false n; match n.n_expl with | FL_none -> () | FL_some { next; _ } -> cleanup_ next @@ -541,7 +563,7 @@ module Make (A : ARG) : type t = { mutable lits: Lit.t list; mutable same_val: (Class.t * Class.t) list; - mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * proof_step) list; + mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * step_id) list; } let create () : t = { lits = []; same_val = []; th_lemmas = [] } @@ -568,7 +590,7 @@ module Make (A : ARG) : () (* proof of [\/_i ¬lits[i]] *) - let proof_of_th_lemmas (self : t) (proof : proof) : proof_step = + let proof_of_th_lemmas (self : t) (proof : proof_trace) : step_id = let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in let p_lits2 = Iter.of_list self.th_lemmas @@ -609,8 +631,8 @@ module Make (A : ARG) : end (* decompose explanation [e] into a list of literals added to [acc] *) - let rec explain_decompose_expl cc (st : Expl_state.t) (e : explanation) : unit - = + let rec explain_decompose_expl self (st : Expl_state.t) (e : explanation) : + unit = Log.debugf 5 (fun k -> k "(@[cc.decompose_expl@ %a@])" Expl.pp e); match e with | E_trivial -> () @@ -619,14 +641,14 @@ module Make (A : ARG) : | Some (App_fun (f1, a1)), Some (App_fun (f2, a2)) -> assert (Fun.equal f1 f2); assert (List.length a1 = List.length a2); - List.iter2 (explain_equal_rec_ cc st) a1 a2 + List.iter2 (explain_equal_rec_ self st) a1 a2 | Some (App_ho (f1, a1)), Some (App_ho (f2, a2)) -> - explain_equal_rec_ cc st f1 f2; - explain_equal_rec_ cc st a1 a2 + explain_equal_rec_ self st f1 f2; + explain_equal_rec_ self st a1 a2 | Some (If (a1, b1, c1)), Some (If (a2, b2, c2)) -> - explain_equal_rec_ cc st a1 a2; - explain_equal_rec_ cc st b1 b2; - explain_equal_rec_ cc st c1 c2 + explain_equal_rec_ self st a1 a2; + explain_equal_rec_ self st b1 b2; + explain_equal_rec_ self st c1 c2 | _ -> assert false) | E_lit lit -> Expl_state.add_lit st lit | E_same_val (n1, n2) -> Expl_state.add_same_val st n1 n2 @@ -634,29 +656,29 @@ module Make (A : ARG) : let sub_proofs = List.map (fun (t_i, u_i, expls_i) -> - let lit_i = A.CC.mk_lit_eq cc.tst t_i u_i in + let lit_i = A.mk_lit_eq self.tst t_i u_i in (* use a separate call to [explain_expls] for each set *) - let sub = explain_expls cc expls_i in + let sub = explain_expls self expls_i in Expl_state.merge st sub; lit_i, sub.lits) expl_sets in - let lit_t_u = A.CC.mk_lit_eq cc.tst t u in + let lit_t_u = A.mk_lit_eq self.tst t u in Expl_state.add_th st lit_t_u sub_proofs pr - | E_merge (a, b) -> explain_equal_rec_ cc st a b + | E_merge (a, b) -> explain_equal_rec_ self st a b | E_merge_t (a, b) -> (* find nodes for [a] and [b] on the fly *) - (match T_tbl.find cc.tbl a, T_tbl.find cc.tbl b with - | a, b -> explain_equal_rec_ cc st a b + (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with + | a, b -> explain_equal_rec_ self st a b | exception Not_found -> Error.errorf "expl: cannot find node(s) for %a, %a" Term.pp a Term.pp b) | E_and (a, b) -> - explain_decompose_expl cc st a; - explain_decompose_expl cc st b + explain_decompose_expl self st a; + explain_decompose_expl self st b - and explain_expls cc (es : explanation list) : Expl_state.t = + and explain_expls self (es : explanation list) : Expl_state.t = let st = Expl_state.create () in - List.iter (explain_decompose_expl cc st) es; + List.iter (explain_decompose_expl self st) es; st and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : node) (b : node) : @@ -670,7 +692,7 @@ module Make (A : ARG) : (* explain why [a = parent_a], where [a -> ... -> target] in the proof forest *) - and explain_along_path cc (st : Expl_state.t) (a : node) (target : node) : + and explain_along_path self (st : Expl_state.t) (a : node) (target : node) : unit = let rec aux n = if n == target then @@ -679,7 +701,7 @@ module Make (A : ARG) : match n.n_expl with | FL_none -> assert false | FL_some { next = next_n; expl } -> - explain_decompose_expl cc st expl; + explain_decompose_expl self st expl; (* now prove [next_n = target] *) aux next_n ) @@ -687,28 +709,30 @@ module Make (A : ARG) : aux a (* add a term *) - let[@inline] rec add_term_rec_ cc t : node = - try T_tbl.find cc.tbl t with Not_found -> add_new_term_ cc t + let[@inline] rec add_term_rec_ self t : node = + match T_tbl.find self.tbl t with + | n -> n + | exception Not_found -> add_new_term_ self t - (* add [t] to [cc] when not present already *) - and add_new_term_ cc (t : term) : node = - assert (not @@ mem cc t); + (* add [t] when not present already *) + and add_new_term_ self (t : term) : node = + assert (not @@ mem self t); Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp t); let n = Class.make t in (* register sub-terms, add [t] to their parent list, and return the corresponding initial signature *) - let sig0 = compute_sig0 cc n in + let sig0 = compute_sig0 self n in n.n_sig0 <- sig0; (* remove term when we backtrack *) - on_backtrack cc (fun () -> + on_backtrack self (fun () -> Log.debugf 30 (fun k -> k "(@[cc.remove-term@ %a@])" Term.pp t); - T_tbl.remove cc.tbl t); + T_tbl.remove self.tbl t); (* add term to the table *) - T_tbl.add cc.tbl t n; + T_tbl.add self.tbl t n; if Option.is_some sig0 then (* [n] might be merged with other equiv classes *) - push_pending cc n; - if not cc.model_mode then List.iter (fun f -> f cc n t) cc.on_new_term; + push_pending self n; + if not self.model_mode then Event.emit self.on_new_term (self, n, t); n (* compute the initial signature of the given node *) @@ -723,13 +747,13 @@ module Make (A : ARG) : let old_parents = sub_r.n_parents in if Bag.is_empty old_parents && not self.model_mode then (* first time it has parents: tell watchers that this is a subterm *) - List.iter (fun f -> f sub u) self.on_is_subterm; + Event.emit self.on_is_subterm (self, sub, u); on_backtrack self (fun () -> sub_r.n_parents <- old_parents); sub_r.n_parents <- Bag.cons n sub_r.n_parents); sub in let[@inline] return x = Some x in - match A.CC.view n.n_term with + match A.view_as_cc n.n_term with | Bool _ | Opaque _ -> None | Eq (a, b) -> let a = deref_sub a in @@ -748,16 +772,16 @@ module Make (A : ARG) : return @@ App_ho (f, a) | If (a, b, c) -> return @@ If (deref_sub a, deref_sub b, deref_sub c) - let[@inline] add_term cc t : node = add_term_rec_ cc t + let[@inline] add_term self t : node = add_term_rec_ self t let mem_term = mem - let set_as_lit cc (n : node) (lit : lit) : unit = + let set_as_lit self (n : node) (lit : lit) : unit = match n.n_as_lit with | Some _ -> () | None -> Log.debugf 15 (fun k -> k "(@[cc.set-as-lit@ %a@ %a@])" Class.pp n Lit.pp lit); - on_backtrack cc (fun () -> n.n_as_lit <- None); + on_backtrack self (fun () -> n.n_as_lit <- None); n.n_as_lit <- Some lit (* is [n] true or false? *) @@ -769,7 +793,7 @@ module Make (A : ARG) : the SAT solver), and [pr] is a proof, including sub-proofs for theory merges. *) let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : - Lit.t list * proof_step = + Lit.t list * step_id = let { Expl_state.lits; th_lemmas = _; same_val } = st in assert (same_val = []); let pr = Expl_state.proof_of_th_lemmas st self.proof in @@ -777,17 +801,17 @@ module Make (A : ARG) : (* main CC algo: add terms from [pending] to the signature table, check for collisions *) - let rec update_tasks (cc : t) (acts : actions) : unit = - while not (Vec.is_empty cc.pending && Vec.is_empty cc.combine) do - while not @@ Vec.is_empty cc.pending do - task_pending_ cc (Vec.pop_exn cc.pending) + let rec update_tasks (self : t) (acts : actions) : unit = + while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do + while not @@ Vec.is_empty self.pending do + task_pending_ self (Vec.pop_exn self.pending) done; - while not @@ Vec.is_empty cc.combine do - task_combine_ cc acts (Vec.pop_exn cc.combine) + while not @@ Vec.is_empty self.combine do + task_combine_ self acts (Vec.pop_exn self.combine) done done - and task_pending_ cc (n : node) : unit = + and task_pending_ self (n : node) : unit = (* check if some parent collided *) match n.n_sig0 with | None -> () (* no-op *) @@ -798,47 +822,47 @@ module Make (A : ARG) : Log.debugf 5 (fun k -> k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" Class.pp n Class.pp a Class.pp b); - merge_classes cc n (n_true cc) expl + merge_classes self n (n_true self) expl ) | Some (Not u) -> (* [u = bool ==> not u = not bool] *) let r_u = find_ u in - if Class.equal r_u (n_true cc) then ( - let expl = Expl.mk_merge u (n_true cc) in - merge_classes cc n (n_false cc) expl - ) else if Class.equal r_u (n_false cc) then ( - let expl = Expl.mk_merge u (n_false cc) in - merge_classes cc n (n_true cc) expl + if Class.equal r_u (n_true self) then ( + let expl = Expl.mk_merge u (n_true self) in + merge_classes self n (n_false self) expl + ) else if Class.equal r_u (n_false self) then ( + let expl = Expl.mk_merge u (n_false self) in + merge_classes self n (n_true self) expl ) | Some s0 -> (* update the signature by using [find] on each sub-node *) let s = update_sig s0 in - (match find_signature cc s with + (match find_signature self s with | None -> (* add to the signature table [sig(n) --> n] *) - add_signature cc s n + add_signature self s n | Some u when Class.equal n u -> () | Some u -> (* [t1] and [t2] must be applications of the same symbol to arguments that are pairwise equal *) assert (n != u); let expl = Expl.mk_congruence n u in - merge_classes cc n u expl) + merge_classes self n u expl) - and[@inline] task_combine_ cc acts = function - | CT_merge (a, b, e_ab) -> task_merge_ cc acts a b e_ab - | CT_set_val (n, v) -> task_set_val_ cc acts n v + and task_combine_ self acts = function + | CT_merge (a, b, e_ab) -> task_merge_ self acts a b e_ab + | CT_set_val (n, v) -> task_set_val_ self acts n v - and task_set_val_ cc acts n v = + and task_set_val_ self acts n v = let repr_n = find_ n in (* - if repr(n) has value [v], do nothing - else if repr(n) has value [v'], semantic conflict - else add [repr(n) -> (n,v)] to cc.t_to_val *) - (match T_b_tbl.get cc.t_to_val repr_n.n_term with + (match T_b_tbl.get self.t_to_val repr_n.n_term with | Some (n', v') when not (Term.equal v v') -> (* semantic conflict *) let expl = [ Expl.mk_merge n n' ] in - let expl_st = explain_expls cc expl in + let expl_st = explain_expls self expl in let lits = expl_st.lits in let tuples = List.rev_map (fun (t, u) -> true, t.n_term, u.n_term) expl_st.same_val @@ -850,33 +874,33 @@ module Make (A : ARG) : (@[existing-val %a@ := %a@])@])" Class.pp n Term.pp v Class.pp n' Term.pp v'); - Stat.incr cc.count_semantic_conflict; + Stat.incr self.count_semantic_conflict; let (module A) = acts in A.raise_semantic_conflict lits tuples | Some _ -> () - | None -> T_b_tbl.add cc.t_to_val repr_n.n_term (n, v)); + | None -> T_b_tbl.add self.t_to_val repr_n.n_term (n, v)); (* now for the reverse map, look in self.val_to_t for [v]. - if present, push a merge command with Expl.mk_same_value - if not, add [v -> n] *) - match T_b_tbl.get cc.val_to_t v with - | None -> T_b_tbl.add cc.val_to_t v n + match T_b_tbl.get self.val_to_t v with + | None -> T_b_tbl.add self.val_to_t v n | Some n' when not (same_class n n') -> - merge_classes cc n n' (Expl.mk_same_value n n') + merge_classes self n n' (Expl.mk_same_value n n') | Some _ -> () (* main CC algo: merge equivalence classes in [st.combine]. @raise Exn_unsat if merge fails *) - and task_merge_ cc acts a b e_ab : unit = + and task_merge_ self acts a b e_ab : unit = let ra = find_ a in let rb = find_ b in if not @@ Class.equal ra rb then ( assert (Class.is_root ra); assert (Class.is_root rb); - Stat.incr cc.count_merge; + Stat.incr self.count_merge; (* check we're not merging [true] and [false] *) if - (Class.equal ra (n_true cc) && Class.equal rb (n_false cc)) - || (Class.equal rb (n_true cc) && Class.equal ra (n_false cc)) + (Class.equal ra (n_true self) && Class.equal rb (n_false self)) + || (Class.equal rb (n_true self) && Class.equal ra (n_false self)) then ( Log.debugf 5 (fun k -> k @@ -890,9 +914,9 @@ module Make (A : ARG) : C3: r1 C1 C2 *) let expl_st = Expl_state.create () in - explain_decompose_expl cc expl_st e_ab; - explain_equal_rec_ cc expl_st a ra; - explain_equal_rec_ cc expl_st b rb; + explain_decompose_expl self expl_st e_ab; + explain_equal_rec_ self expl_st a ra; + explain_equal_rec_ self expl_st b rb; if Expl_state.is_semantic expl_st then ( (* conflict involving some semantic values *) @@ -902,22 +926,22 @@ module Make (A : ARG) : |> List.rev_map (fun (t, u) -> true, Class.term t, Class.term u) in assert (same_val <> []); - Stat.incr cc.count_semantic_conflict; + Stat.incr self.count_semantic_conflict; let (module A) = acts in A.raise_semantic_conflict lits same_val ) else ( (* regular conflict *) - let lits, pr = lits_and_proof_of_expl cc expl_st in - raise_conflict_ cc ~th:!th acts (List.rev_map Lit.neg lits) pr + let lits, pr = lits_and_proof_of_expl self expl_st in + raise_conflict_ self ~th:!th acts (List.rev_map Lit.neg lits) pr ) ); (* We will merge [r_from] into [r_into]. we try to ensure that [size ra <= size rb] in general, but always keep values as representative *) let r_from, r_into = - if n_is_bool_value cc ra then + if n_is_bool_value self ra then rb, ra - else if n_is_bool_value cc rb then + else if n_is_bool_value self rb then ra, rb else if size_ ra > size_ rb then rb, ra @@ -926,13 +950,13 @@ module Make (A : ARG) : in (* when merging terms with [true] or [false], possibly propagate them to SAT *) let merge_bool r1 t1 r2 t2 = - if Class.equal r1 (n_true cc) then - propagate_bools cc acts r2 t2 r1 t1 e_ab true - else if Class.equal r1 (n_false cc) then - propagate_bools cc acts r2 t2 r1 t1 e_ab false + if Class.equal r1 (n_true self) then + propagate_bools self acts r2 t2 r1 t1 e_ab true + else if Class.equal r1 (n_false self) then + propagate_bools self acts r2 t2 r1 t1 e_ab false in - if not cc.model_mode then ( + if not self.model_mode then ( merge_bool ra a rb b; merge_bool rb b ra a ); @@ -942,16 +966,16 @@ module Make (A : ARG) : k "(@[cc.merge@ :from %a@ :into %a@])" Class.pp r_from Class.pp r_into); (* call [on_pre_merge] functions, and merge theory data items *) - if not cc.model_mode then ( + if not self.model_mode then ( (* explanation is [a=ra & e_ab & b=rb] *) let expl = Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] in - List.iter (fun f -> f cc acts r_into r_from expl) cc.on_pre_merge + Event.emit self.on_pre_merge (self, acts, r_into, r_from, expl) ); ((* parents might have a different signature, check for collisions *) - Class.iter_parents r_from (fun parent -> push_pending cc parent); + Class.iter_parents r_from (fun parent -> push_pending self parent); (* for each node in [r_from]'s class, make it point to [r_into] *) Class.iter_class r_from (fun u -> assert (u.n_root == r_from); @@ -968,7 +992,7 @@ module Make (A : ARG) : r_into.n_size <- r_into.n_size + r_from.n_size; r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; (* on backtrack, unmerge classes and restore the pointers to [r_from] *) - on_backtrack cc (fun () -> + on_backtrack self (fun () -> Log.debugf 30 (fun k -> k "(@[cc.undo_merge@ :from %a@ :into %a@])" Class.pp r_from Class.pp r_into); @@ -983,17 +1007,17 @@ module Make (A : ARG) : (* check for semantic values, update the one of [r_into] if [r_from] has a value *) - (match T_b_tbl.get cc.t_to_val r_from.n_term with + (match T_b_tbl.get self.t_to_val r_from.n_term with | None -> () | Some (n_from, v_from) -> - (match T_b_tbl.get cc.t_to_val r_into.n_term with - | None -> T_b_tbl.add cc.t_to_val r_into.n_term (n_from, v_from) + (match T_b_tbl.get self.t_to_val r_into.n_term with + | None -> T_b_tbl.add self.t_to_val r_into.n_term (n_from, v_from) | Some (n_into, v_into) when not (Term.equal v_from v_into) -> (* semantic conflict, including [n_from != n_into] in model *) let expl = [ e_ab; Expl.mk_merge r_from n_from; Expl.mk_merge r_into n_into ] in - let expl_st = explain_expls cc expl in + let expl_st = explain_expls self expl in let lits = expl_st.lits in let tuples = List.rev_map @@ -1008,7 +1032,7 @@ module Make (A : ARG) : (@[n-into %a@ := %a@])@])" Class.pp n_from Term.pp v_from Class.pp n_into Term.pp v_into); - Stat.incr cc.count_semantic_conflict; + Stat.incr self.count_semantic_conflict; let (module A) = acts in A.raise_semantic_conflict lits tuples | Some _ -> ())); @@ -1016,32 +1040,32 @@ module Make (A : ARG) : (* update explanations (a -> b), arbitrarily. Note that here we merge the classes by adding a bridge between [a] and [b], not their roots. *) - reroot_expl cc a; + reroot_expl self a; assert (a.n_expl = FL_none); (* on backtracking, link may be inverted, but we delete the one that bridges between [a] and [b] *) - on_backtrack cc (fun () -> + on_backtrack self (fun () -> match a.n_expl, b.n_expl with | FL_some e, _ when Class.equal e.next b -> a.n_expl <- FL_none | _, FL_some e when Class.equal e.next a -> b.n_expl <- FL_none | _ -> assert false); a.n_expl <- FL_some { next = b; expl = e_ab }; (* call [on_post_merge] *) - if not cc.model_mode then - List.iter (fun f -> f cc acts r_into r_from) cc.on_post_merge + if not self.model_mode then + Event.emit self.on_post_merge (self, acts, r_into, r_from) ) (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] in the equiv class of [r1] that is a known literal back to the SAT solver and which is not the one initially merged. We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) - and propagate_bools cc acts r1 t1 r2 t2 (e_12 : explanation) sign : unit = + and propagate_bools self acts r1 t1 r2 t2 (e_12 : explanation) sign : unit = (* explanation for [t1 =e= t2 = r2] *) let half_expl_and_pr = lazy (let st = Expl_state.create () in - explain_decompose_expl cc st e_12; - explain_equal_rec_ cc st r2 t2; + explain_decompose_expl self st e_12; + explain_equal_rec_ self st r2 t2; st) in (* TODO: flag per class, `or`-ed on merge, to indicate if the class @@ -1066,7 +1090,7 @@ module Make (A : ARG) : let (lazy st) = half_expl_and_pr in let st = Expl_state.copy st in (* do not modify shared st *) - explain_equal_rec_ cc st u1 t1; + explain_equal_rec_ self st u1 t1; (* propagate only if this doesn't depend on some semantic values *) if not (Expl_state.is_semantic st) then ( @@ -1075,21 +1099,17 @@ module Make (A : ARG) : let guard = st.lits in (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) Expl_state.add_lit st (Lit.neg lit); - let _, pr = lits_and_proof_of_expl cc st in + let _, pr = lits_and_proof_of_expl self st in guard, pr in - List.iter (fun f -> f cc lit reason) cc.on_propagate; - Stat.incr cc.count_props; + Event.emit self.on_propagate (self, lit, reason); + Stat.incr self.count_props; let (module A) = acts in A.propagate lit ~reason ) | _ -> ()) - module Debug_ = struct - let pp out _ = Fmt.string out "cc" - end - - let add_iter cc it : unit = it (fun t -> ignore @@ add_term_rec_ cc t) + let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) let[@inline] push_level (self : t) : unit = Backtrack_stack.push_level self.undo; @@ -1108,13 +1128,13 @@ module Make (A : ARG) : () (* run [f] in a local congruence closure level *) - let with_model_mode cc f = - assert (not cc.model_mode); - cc.model_mode <- true; - push_level cc; + let with_model_mode self f = + assert (not self.model_mode); + self.model_mode <- true; + push_level self; CCFun.protect f ~finally:(fun () -> - pop_levels cc 1; - cc.model_mode <- false) + pop_levels self 1; + self.model_mode <- false) let get_model_for_each_class self : _ Iter.t = assert self.model_mode; @@ -1127,54 +1147,49 @@ module Make (A : ARG) : (* assert that this boolean literal holds. if a lit is [= a b], merge [a] and [b]; otherwise merge the atom with true/false *) - let assert_lit cc lit : unit = + let assert_lit self lit : unit = let t = Lit.term lit in Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); let sign = Lit.sign lit in - match A.CC.view t with + match A.view_as_cc t with | Eq (a, b) when sign -> - let a = add_term cc a in - let b = add_term cc b in + let a = add_term self a in + let b = add_term self b in (* merge [a] and [b] *) - merge_classes cc a b (Expl.mk_lit lit) + merge_classes self a b (Expl.mk_lit lit) | _ -> (* equate t and true/false *) - let rhs = - if sign then - n_true cc - else - n_false cc - in - let n = add_term cc t in + let rhs = n_bool self sign in + let n = add_term self t in (* TODO: ensure that this is O(1). basically, just have [n] point to true/false and thus acquire the corresponding value, so its superterms (like [ite]) can evaluate properly *) (* TODO: use oriented merge (force direction [n -> rhs]) *) - merge_classes cc n rhs (Expl.mk_lit lit) + merge_classes self n rhs (Expl.mk_lit lit) - let[@inline] assert_lits cc lits : unit = Iter.iter (assert_lit cc) lits + let[@inline] assert_lits self lits : unit = Iter.iter (assert_lit self) lits (* raise a conflict *) - let raise_conflict_from_expl cc (acts : actions) expl = + let raise_conflict_from_expl self (acts : actions) expl = Log.debugf 5 (fun k -> k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); let st = Expl_state.create () in - explain_decompose_expl cc st expl; - let lits, pr = lits_and_proof_of_expl cc st in + explain_decompose_expl self st expl; + let lits, pr = lits_and_proof_of_expl self st in let c = List.rev_map Lit.neg lits in let th = st.th_lemmas <> [] in - raise_conflict_ cc ~th acts c pr + raise_conflict_ self ~th acts c pr - let merge cc n1 n2 expl = + let merge self n1 n2 expl = Log.debugf 5 (fun k -> k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" Class.pp n1 Class.pp n2 Expl.pp expl); assert (T.Ty.equal (T.Term.ty n1.n_term) (T.Term.ty n2.n_term)); - merge_classes cc n1 n2 expl + merge_classes self n1 n2 expl - let[@inline] merge_t cc t1 t2 expl = - merge cc (add_term cc t1) (add_term cc t2) expl + let merge_t self t1 t2 expl = + merge self (add_term self t1) (add_term self t2) expl let set_model_value (self : t) (t : term) (v : value) : unit = assert self.model_mode; @@ -1183,23 +1198,21 @@ module Make (A : ARG) : | None -> () (* ignore, th combination not needed *) | Some n -> Vec.push self.combine (CT_set_val (n, v)) - let explain_eq cc n1 n2 : Resolved_expl.t = + let explain_eq self n1 n2 : Resolved_expl.t = let st = Expl_state.create () in - explain_equal_rec_ cc st n1 n2; + explain_equal_rec_ self st n1 n2; (* FIXME: also need to return the proof? *) Expl_state.to_resolved_expl st - let on_pre_merge cc f = cc.on_pre_merge <- f :: cc.on_pre_merge - let on_post_merge cc f = cc.on_post_merge <- f :: cc.on_post_merge - let on_new_term cc f = cc.on_new_term <- f :: cc.on_new_term - let on_conflict cc f = cc.on_conflict <- f :: cc.on_conflict - let on_propagate cc f = cc.on_propagate <- f :: cc.on_propagate - let on_is_subterm cc f = cc.on_is_subterm <- f :: cc.on_is_subterm + let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge + let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge + let[@inline] on_new_term self = Event.of_emitter self.on_new_term + let[@inline] on_conflict self = Event.of_emitter self.on_conflict + let[@inline] on_propagate self = Event.of_emitter self.on_propagate + let[@inline] on_is_subterm self = Event.of_emitter self.on_is_subterm - let create ?(stat = Stat.global) ?(on_pre_merge = []) ?(on_post_merge = []) - ?(on_new_term = []) ?(on_conflict = []) ?(on_propagate = []) - ?(on_is_subterm = []) ?(size = `Big) (tst : term_store) (proof : proof) : - t = + let create ?(stat = Stat.global) ?(size = `Big) (tst : term_store) + (proof : proof_trace) : t = let size = match size with | `Small -> 128 @@ -1217,12 +1230,12 @@ module Make (A : ARG) : t_to_val = T_b_tbl.create ~size:32 (); val_to_t = T_b_tbl.create ~size:32 (); model_mode = false; - on_pre_merge; - on_post_merge; - on_new_term; - on_conflict; - on_propagate; - on_is_subterm; + on_pre_merge = Event.Emitter.create (); + on_post_merge = Event.Emitter.create (); + on_new_term = Event.Emitter.create (); + on_conflict = Event.Emitter.create (); + on_propagate = Event.Emitter.create (); + on_is_subterm = Event.Emitter.create (); pending = Vec.create (); combine = Vec.create (); undo = Backtrack_stack.create (); @@ -1240,13 +1253,13 @@ module Make (A : ARG) : ignore (Lazy.force false_ : node); cc - let[@inline] find_t cc t : repr = - let n = T_tbl.find cc.tbl t in + let[@inline] find_t self t : repr = + let n = T_tbl.find self.tbl t in find_ n - let[@inline] check cc acts : unit = + let[@inline] check self acts : unit = Log.debug 5 "(cc.check)"; - update_tasks cc acts + update_tasks self acts let check_inv_enabled_ = true (* XXX NUDGE *) @@ -1273,134 +1286,7 @@ module Make (A : ARG) : ) (* model: return all the classes *) - let get_model (cc : t) : repr Iter.t Iter.t = - check_inv_ cc; - all_classes cc |> Iter.map Class.iter_class -end - -module Make_plugin (M : MONOID_ARG) : PLUGIN_BUILDER with module M = M = struct - module M = M - module CC = M.CC - module Class = CC.Class - module N_tbl = Backtrackable_tbl.Make (Class) - module Expl = CC.Expl - - type term = CC.term - - module type PL = PLUGIN with module CC = M.CC and module M = M - - type plugin = (module PL) - - module Make (A : sig - val size : int option - val cc : CC.t - end) : PL = struct - module M = M - module CC = CC - open A - - (* repr -> value for the class *) - let values : M.t N_tbl.t = N_tbl.create ?size () - - (* bit in CC to filter out quickly classes without value *) - let field_has_value : Class.bitfield = - CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc - - let push_level () = N_tbl.push_level values - let pop_levels n = N_tbl.pop_levels values n - let n_levels () = N_tbl.n_levels values - - let mem n = - let res = CC.get_bitfield cc field_has_value n in - assert ( - if res then - N_tbl.mem values n - else - true); - res - - let get n = - if CC.get_bitfield cc field_has_value n then - N_tbl.get values n - else - None - - let on_new_term cc n (t : term) : unit = - (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) - let maybe_m, l = M.of_term cc n t in - (match maybe_m with - | Some v -> - Log.debugf 20 (fun k -> - k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name Class.pp n - M.pp v); - CC.set_bitfield cc field_has_value true n; - N_tbl.add values n v - | None -> ()); - List.iter - (fun (n_u, m_u) -> - Log.debugf 20 (fun k -> - k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])" - M.name Class.pp n Class.pp n_u M.pp m_u); - let n_u = CC.find cc n_u in - if CC.get_bitfield cc field_has_value n_u then ( - let m_u' = - try N_tbl.find values n_u - with Not_found -> - Error.errorf "node %a has bitfield but no value" Class.pp n_u - in - match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with - | Error expl -> - Error.errorf - "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" - Class.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl - | Ok m_u_merged -> - Log.debugf 20 (fun k -> - k - "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ - :value %a@])" - M.name Class.pp n Class.pp n_u M.pp m_u_merged); - N_tbl.add values n_u m_u_merged - ) else ( - (* just add to [n_u] *) - CC.set_bitfield cc field_has_value true n_u; - N_tbl.add values n_u m_u - )) - l; - () - - let iter_all : _ Iter.t = N_tbl.to_iter values - - let on_pre_merge cc acts n1 n2 e_n1_n2 : unit = - match get n1, get n2 with - | Some v1, Some v2 -> - Log.debugf 5 (fun k -> - k - "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \ - :val2 %a@])@])" - M.name Class.pp n1 M.pp v1 Class.pp n2 M.pp v2); - (match M.merge cc n1 v1 n2 v2 e_n1_n2 with - | Ok v' -> - N_tbl.remove values n2; - (* only keep repr *) - N_tbl.add values n1 v' - | Error expl -> CC.raise_conflict_from_expl cc acts expl) - | None, Some cr -> - CC.set_bitfield cc field_has_value true n1; - N_tbl.add values n1 cr; - N_tbl.remove values n2 (* only keep reprs *) - | Some _, None -> () (* already there on the left *) - | None, None -> () - - (* setup *) - let () = - CC.on_new_term cc on_new_term; - CC.on_pre_merge cc on_pre_merge; - () - end - - let create_and_setup ?size (cc : CC.t) : plugin = - (module Make (struct - let size = size - let cc = cc - end)) + let get_model (self : t) : repr Iter.t Iter.t = + check_inv_ self; + all_classes self |> Iter.map Class.iter_class end diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index ade46641..2ecc963d 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -1,20 +1,33 @@ (** Congruence Closure Implementation *) module View = Sidekick_sigs_cc.View +open Sidekick_sigs_cc -module type TERM = Sidekick_sigs_cc.TERM -module type LIT = Sidekick_sigs_cc.LIT -module type ARG = Sidekick_sigs_cc.ARG -module type S = Sidekick_sigs_cc.S -module type MONOID_ARG = Sidekick_sigs_cc.MONOID_ARG -module type PLUGIN = Sidekick_sigs_cc.PLUGIN -module type PLUGIN_BUILDER = Sidekick_sigs_cc.PLUGIN_BUILDER +module type ARG = ARG + +module type S = sig + include S + + val create : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> term_store -> proof_trace -> t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. *) + + (**/**) + + module Debug_ : sig + val pp : t Fmt.printer + (** Print the whole CC *) + end + + (**/**) +end module Make (A : ARG) : S with module T = A.T and module Lit = A.Lit and module Proof_trace = A.Proof_trace - -(** Create a plugin builder from the given per-class monoid *) -module Make_plugin (M : MONOID_ARG) : PLUGIN_BUILDER with module M = M diff --git a/src/cc/plugin/dune b/src/cc/plugin/dune new file mode 100644 index 00000000..269abd1e --- /dev/null +++ b/src/cc/plugin/dune @@ -0,0 +1,5 @@ +(library + (name Sidekick_cc_plugin) + (public_name sidekick.cc.plugin) + (libraries containers iter sidekick.sigs sidekick.sigs.cc sidekick.util) + (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml new file mode 100644 index 00000000..211fd6be --- /dev/null +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -0,0 +1,159 @@ +open Sidekick_sigs_cc + +module type EXTENDED_PLUGIN_BUILDER = sig + include MONOID_PLUGIN_BUILDER + + val mem : t -> M.CC.Class.t -> bool + (** Does the CC Class.t have a monoid value? *) + + val get : t -> M.CC.Class.t -> M.t option + (** Get monoid value for this CC Class.t, if any *) + + val iter_all : t -> (M.CC.repr * M.t) Iter.t + + include Sidekick_sigs.BACKTRACKABLE0 with type t := t + include Sidekick_sigs.PRINT with type t := t +end + +module Make (M : MONOID_PLUGIN_ARG) : + EXTENDED_PLUGIN_BUILDER with module M = M = struct + module M = M + module CC = M.CC + module Class = CC.Class + module Cls_tbl = Backtrackable_tbl.Make (Class) + module Expl = CC.Expl + + type term = CC.term + + module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M + + type t = (module DYN_PL_FOR_M) + + module Make (A : sig + val size : int option + val cc : CC.t + end) : DYN_PL_FOR_M = struct + module M = M + module CC = CC + open A + + (* repr -> value for the class *) + let values : M.t Cls_tbl.t = Cls_tbl.create ?size () + + (* bit in CC to filter out quickly classes without value *) + let field_has_value : CC.Class.bitfield = + CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc + + let push_level () = Cls_tbl.push_level values + let pop_levels n = Cls_tbl.pop_levels values n + let n_levels () = Cls_tbl.n_levels values + + let mem n = + let res = CC.get_bitfield cc field_has_value n in + assert ( + if res then + Cls_tbl.mem values n + else + true); + res + + let get n = + if CC.get_bitfield cc field_has_value n then + Cls_tbl.get values n + else + None + + let on_new_term cc n (t : term) : unit = + (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) + let maybe_m, l = M.of_term cc n t in + (match maybe_m with + | Some v -> + Log.debugf 20 (fun k -> + k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name Class.pp n + M.pp v); + CC.set_bitfield cc field_has_value true n; + Cls_tbl.add values n v + | None -> ()); + List.iter + (fun (n_u, m_u) -> + Log.debugf 20 (fun k -> + k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])" + M.name Class.pp n Class.pp n_u M.pp m_u); + let n_u = CC.find cc n_u in + if CC.get_bitfield cc field_has_value n_u then ( + let m_u' = + try Cls_tbl.find values n_u + with Not_found -> + Error.errorf "node %a has bitfield but no value" Class.pp n_u + in + match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with + | Error expl -> + Error.errorf + "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" + Class.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl + | Ok m_u_merged -> + Log.debugf 20 (fun k -> + k + "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ + :value %a@])" + M.name Class.pp n Class.pp n_u M.pp m_u_merged); + Cls_tbl.add values n_u m_u_merged + ) else ( + (* just add to [n_u] *) + CC.set_bitfield cc field_has_value true n_u; + Cls_tbl.add values n_u m_u + )) + l; + () + + let iter_all : _ Iter.t = Cls_tbl.to_iter values + + let on_pre_merge cc acts n1 n2 e_n1_n2 : unit = + match get n1, get n2 with + | Some v1, Some v2 -> + Log.debugf 5 (fun k -> + k + "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \ + :val2 %a@])@])" + M.name Class.pp n1 M.pp v1 Class.pp n2 M.pp v2); + (match M.merge cc n1 v1 n2 v2 e_n1_n2 with + | Ok v' -> + Cls_tbl.remove values n2; + (* only keep repr *) + Cls_tbl.add values n1 v' + | Error expl -> CC.raise_conflict_from_expl cc acts expl) + | None, Some cr -> + CC.set_bitfield cc field_has_value true n1; + Cls_tbl.add values n1 cr; + Cls_tbl.remove values n2 (* only keep reprs *) + | Some _, None -> () (* already there on the left *) + | None, None -> () + + let pp out () : unit = + let pp_e out (t, v) = + Fmt.fprintf out "(@[%a@ :has %a@])" Class.pp t M.pp v + in + Fmt.fprintf out "(@[%a@])" (Fmt.iter pp_e) iter_all + + (* setup *) + let () = + Event.on (CC.on_new_term cc) ~f:(fun (_, r, t) -> on_new_term cc r t); + Event.on (CC.on_pre_merge cc) ~f:(fun (_, acts, ra, rb, expl) -> + on_pre_merge cc acts ra rb expl); + () + end + + let create_and_setup ?size (cc : CC.t) : t = + (module Make (struct + let size = size + let cc = cc + end)) + + let push_level ((module P) : t) = P.push_level () + let pop_levels ((module P) : t) n = P.pop_levels n + let n_levels ((module P) : t) = P.n_levels () + let mem ((module P) : t) t = P.mem t + let get ((module P) : t) t = P.get t + let iter_all ((module P) : t) = P.iter_all + let pp out ((module P) : t) = P.pp out () +end diff --git a/src/cc/plugin/sidekick_cc_plugin.mli b/src/cc/plugin/sidekick_cc_plugin.mli new file mode 100644 index 00000000..f70ae421 --- /dev/null +++ b/src/cc/plugin/sidekick_cc_plugin.mli @@ -0,0 +1,21 @@ +(** Congruence Closure Implementation *) + +open Sidekick_sigs_cc + +module type EXTENDED_PLUGIN_BUILDER = sig + include MONOID_PLUGIN_BUILDER + + val mem : t -> M.CC.Class.t -> bool + (** Does the CC Class.t have a monoid value? *) + + val get : t -> M.CC.Class.t -> M.t option + (** Get monoid value for this CC Class.t, if any *) + + val iter_all : t -> (M.CC.repr * M.t) Iter.t + + include Sidekick_sigs.BACKTRACKABLE0 with type t := t + include Sidekick_sigs.PRINT with type t := t +end + +(** Create a plugin builder from the given per-class monoid *) +module Make (M : MONOID_PLUGIN_ARG) : EXTENDED_PLUGIN_BUILDER with module M = M diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index 213ba2fc..5fc40415 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -18,572 +18,8 @@ module type TERM = Sidekick_sigs_term.S module type LIT = Sidekick_sigs_lit.S module type PROOF_TRACE = Sidekick_sigs_proof_trace.S -module type SAT_PROOF = Sidekick_sigs_proof_sat.S +module type SAT_PROOF_RULES = Sidekick_sigs_proof_sat.S (** Signature for SAT-solver proof emission. *) -module type PROOF = Sidekick_sigs_proof_core.S +module type PROOF_CORE = Sidekick_sigs_proof_core.S (** Proofs of unsatisfiability. *) - -(** Registry to extract values *) -module type REGISTRY = sig - type t - type 'a key - - val create_key : unit -> 'a key - (** Call this statically, typically at program initialization, for - each distinct key. *) - - val create : unit -> t - val get : t -> 'a key -> 'a option - val set : t -> 'a key -> 'a -> unit -end - -(** A view of the solver from a theory's point of view. - - Theories should interact with the solver via this module, to assert - new lemmas, propagate literals, access the congruence closure, etc. *) -module type SOLVER_INTERNAL = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - type ty = T.Ty.t - type term = T.Term.t - type value = T.Term.t - type term_store = T.Term.store - type ty_store = T.Ty.store - type clause_pool - type proof = Proof_trace.t - type proof_step = Proof_trace.step_id - - type t - (** {3 Main type for a solver} *) - - type solver = t - - val tst : t -> term_store - val ty_st : t -> ty_store - val stats : t -> Stat.t - - val proof : t -> proof - (** Access the proof object *) - - (** {3 Registry} *) - - module Registry : REGISTRY - - val registry : t -> Registry.t - (** A solver contains a registry so that theories can share data *) - - (** {3 Actions for the theories} *) - - type theory_actions - (** Handle that the theories can use to perform actions. *) - - type lit = Lit.t - - (** {3 Congruence Closure} *) - - (** Congruence closure instance *) - module CC : - Sidekick_sigs_cc.S - with module T = T - and module Lit = Lit - and module Proof_trace = Proof_trace - - val cc : t -> CC.t - (** Congruence closure for this solver *) - - (** {3 Simplifiers} *) - - (** Simplify terms *) - module Simplify : sig - type t - - val tst : t -> term_store - val ty_st : t -> ty_store - - val clear : t -> unit - (** Reset internal cache, etc. *) - - val proof : t -> proof - (** Access proof *) - - type hook = t -> term -> (term * proof_step Iter.t) option - (** Given a term, try to simplify it. Return [None] if it didn't change. - - A simple example could be a hook that takes a term [t], - and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, - returns [Some (const (x+y))], and [None] otherwise. - - The simplifier will take care of simplifying the resulting term further, - caching (so that work is not duplicated in subterms), etc. - *) - - val normalize : t -> term -> (term * proof_step) option - (** Normalize a term using all the hooks. This performs - a fixpoint, i.e. it only stops when no hook applies anywhere inside - the term. *) - - val normalize_t : t -> term -> term * proof_step option - (** Normalize a term using all the hooks, along with a proof that the - simplification is correct. - returns [t, ø] if no simplification occurred. *) - end - - type simplify_hook = Simplify.hook - - val add_simplifier : t -> Simplify.hook -> unit - (** Add a simplifier hook for preprocessing. *) - - val simplify_t : t -> term -> (term * proof_step) option - (** Simplify input term, returns [Some u] if some - simplification occurred. *) - - val simp_t : t -> term -> term * proof_step option - (** [simp_t si t] returns [u] even if no simplification occurred - (in which case [t == u] syntactically). - It emits [|- t=u]. - (see {!simplifier}) *) - - (** {3 Preprocessors} - These preprocessors turn mixed, raw literals (possibly simplified) into - literals suitable for reasoning. - Typically some clauses are also added to the solver. *) - - module type PREPROCESS_ACTS = sig - val proof : proof - - val mk_lit : ?sign:bool -> term -> lit - (** [mk_lit t] creates a new literal for a boolean term [t]. *) - - val add_clause : lit list -> proof_step -> unit - (** pushes a new clause into the SAT solver. *) - - val add_lit : ?default_pol:bool -> lit -> unit - (** Ensure the literal will be decided/handled by the SAT solver. *) - end - - type preprocess_actions = (module PREPROCESS_ACTS) - (** Actions available to the preprocessor *) - - type preprocess_hook = t -> preprocess_actions -> term -> unit - (** Given a term, preprocess it. - - The idea is to add literals and clauses to help define the meaning of - the term, if needed. For example for boolean formulas, clauses - for their Tseitin encoding can be added, with the formula acting - as its own proxy symbol. - - @param preprocess_actions actions available during preprocessing. - *) - - val on_preprocess : t -> preprocess_hook -> unit - (** Add a hook that will be called when terms are preprocessed *) - - (** {3 hooks for the theory} *) - - val raise_conflict : t -> theory_actions -> lit list -> proof_step -> 'a - (** Give a conflict clause to the solver *) - - val push_decision : t -> theory_actions -> lit -> unit - (** Ask the SAT solver to decide the given literal in an extension of the - current trail. This is useful for theory combination. - If the SAT solver backtracks, this (potential) decision is removed - and forgotten. *) - - val propagate : - t -> theory_actions -> lit -> reason:(unit -> lit list * proof_step) -> unit - (** Propagate a boolean using a unit clause. - [expl => lit] must be a theory lemma, that is, a T-tautology *) - - val propagate_l : t -> theory_actions -> lit -> lit list -> proof_step -> unit - (** Propagate a boolean using a unit clause. - [expl => lit] must be a theory lemma, that is, a T-tautology *) - - val add_clause_temp : t -> theory_actions -> lit list -> proof_step -> unit - (** Add local clause to the SAT solver. This clause will be - removed when the solver backtracks. *) - - val add_clause_permanent : - t -> theory_actions -> lit list -> proof_step -> unit - (** Add toplevel clause to the SAT solver. This clause will - not be backtracked. *) - - val mk_lit : t -> theory_actions -> ?sign:bool -> term -> lit - (** Create a literal. This automatically preprocesses the term. *) - - val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit - (** Add the given literal to the SAT solver, so it gets assigned - a boolean value. - @param default_pol default polarity for the corresponding atom *) - - val add_lit_t : t -> theory_actions -> ?sign:bool -> term -> unit - (** Add the given (signed) bool term to the SAT solver, so it gets assigned - a boolean value *) - - val cc_raise_conflict_expl : t -> theory_actions -> CC.Expl.t -> 'a - (** Raise a conflict with the given congruence closure explanation. - it must be a theory tautology that [expl ==> absurd]. - To be used in theories. *) - - val cc_find : t -> CC.Class.t -> CC.Class.t - (** Find representative of the node *) - - val cc_are_equal : t -> term -> term -> bool - (** Are these two terms equal in the congruence closure? *) - - val cc_merge : - t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit - (** Merge these two nodes in the congruence closure, given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val cc_merge_t : t -> theory_actions -> term -> term -> CC.Expl.t -> unit - (** Merge these two terms in the congruence closure, given this explanation. - See {!cc_merge} *) - - val cc_add_term : t -> term -> CC.Class.t - (** Add/retrieve congruence closure node for this term. - To be used in theories *) - - val cc_mem_term : t -> term -> bool - (** Return [true] if the term is explicitly in the congruence closure. - To be used in theories *) - - val on_cc_pre_merge : - t -> - (CC.t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit) -> - unit - (** Callback for when two classes containing data for this key are merged (called before) *) - - val on_cc_post_merge : - t -> (CC.t -> theory_actions -> CC.Class.t -> CC.Class.t -> unit) -> unit - (** Callback for when two classes containing data for this key are merged (called after)*) - - val on_cc_new_term : t -> (CC.t -> CC.Class.t -> term -> unit) -> unit - (** Callback to add data on terms when they are added to the congruence - closure *) - - val on_cc_is_subterm : t -> (CC.Class.t -> term -> unit) -> unit - (** Callback for when a term is a subterm of another term in the - congruence closure *) - - val on_cc_conflict : t -> (CC.t -> th:bool -> lit list -> unit) -> unit - (** Callback called on every CC conflict *) - - val on_cc_propagate : - t -> (CC.t -> lit -> (unit -> lit list * proof_step) -> unit) -> unit - (** Callback called on every CC propagation *) - - val on_partial_check : - t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit - (** Register callbacked to be called with the slice of literals - newly added on the trail. - - This is called very often and should be efficient. It doesn't have - to be complete, only correct. It's given only the slice of - the trail consisting in new literals. *) - - val on_final_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit - (** Register callback to be called during the final check. - - Must be complete (i.e. must raise a conflict if the set of literals is - not satisfiable) and can be expensive. The function - is given the whole trail. - *) - - val on_th_combination : - t -> (t -> theory_actions -> (term * value) Iter.t) -> unit - (** Add a hook called during theory combination. - The hook must return an iterator of pairs [(t, v)] - which mean that term [t] has value [v] in the model. - - Terms with the same value (according to {!Term.equal}) will be - merged in the CC; if two terms with different values are merged, - we get a semantic conflict and must pick another model. *) - - val declare_pb_is_incomplete : t -> unit - (** Declare that, in some theory, the problem is outside the logic fragment - that is decidable (e.g. if we meet proper NIA formulas). - The solver will not reply "SAT" from now on. *) - - (** {3 Model production} *) - - type model_ask_hook = - recurse:(t -> CC.Class.t -> term) -> t -> CC.Class.t -> term option - (** A model-production hook to query values from a theory. - - It takes the solver, a class, and returns - a term for this class. For example, an arithmetic theory - might detect that a class contains a numeric constant, and return - this constant as a model value. - - If no hook assigns a value to a class, a fake value is created for it. - *) - - type model_completion_hook = t -> add:(term -> term -> unit) -> unit - (** A model production hook, for the theory to add values. - The hook is given a [add] function to add bindings to the model. *) - - val on_model : - ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit - (** Add model production/completion hooks. *) -end - -(** User facing view of the solver. - - This is the solver a user of sidekick can see, after instantiating - everything. The user can add some theories, clauses, etc. and asks - the solver to check satisfiability. - - Theory implementors will mostly interact with {!SOLVER_INTERNAL}. *) -module type SOLVER = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - (** Internal solver, available to theories. *) - module Solver_internal : - SOLVER_INTERNAL - with module T = T - and module Lit = Lit - and module Proof_trace = Proof_trace - - type t - (** The solver's state. *) - - type solver = t - type term = T.Term.t - type ty = T.Ty.t - type lit = Lit.t - type proof = Proof_trace.t - type proof_step = Proof_trace.step_id - - (** {3 Value registry} *) - - module Registry : REGISTRY - - val registry : t -> Registry.t - (** A solver contains a registry so that theories can share data *) - - (** {3 A theory} - - Theories are abstracted over the concrete implementation of the solver, - so they can work with any implementation. - - Typically a theory should be a functor taking an argument containing - a [SOLVER_INTERNAL] or even a full [SOLVER], - and some additional views on terms, literals, etc. - that are specific to the theory (e.g. to map terms to linear - expressions). - The theory can then be instantiated on any kind of solver for any - term representation that also satisfies the additional theory-specific - requirements. Instantiated theories (ie values of type {!SOLVER.theory}) - can be added to the solver. - *) - module type THEORY = sig - type t - (** The theory's state *) - - val name : string - (** Name of the theory (ideally, unique and short) *) - - val create_and_setup : Solver_internal.t -> t - (** Instantiate the theory's state for the given (internal) solver, - register callbacks, create keys, etc. - - Called once for every solver this theory is added to. *) - - val push_level : t -> unit - (** Push backtracking level. When the corresponding pop is called, - the theory's state should be restored to a state {b equivalent} - to what it was just before [push_level]. - - it does not have to be exactly the same state, it just needs to - be equivalent. *) - - val pop_levels : t -> int -> unit - (** [pop_levels theory n] pops [n] backtracking levels, - restoring [theory] to its state before calling [push_level] n times. *) - end - - type theory = (module THEORY) - (** A theory that can be used for this particular solver. *) - - type 'a theory_p = (module THEORY with type t = 'a) - (** A theory that can be used for this particular solver, with state - of type ['a]. *) - - val mk_theory : - name:string -> - create_and_setup:(Solver_internal.t -> 'th) -> - ?push_level:('th -> unit) -> - ?pop_levels:('th -> int -> unit) -> - unit -> - theory - (** Helper to create a theory. *) - - (** Models - - A model can be produced when the solver is found to be in a - satisfiable state after a call to {!solve}. *) - module Model : sig - 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 - end - - (* TODO *) - module Unknown : sig - type t - - val pp : t CCFormat.printer - - (* - type unknown = - | U_timeout - | U_incomplete - *) - end - - (** {3 Main API} *) - - val stats : t -> Stat.t - val tst : t -> T.Term.store - val ty_st : t -> T.Ty.store - val proof : t -> proof - - val create : - ?stat:Stat.t -> - ?size:[ `Big | `Tiny | `Small ] -> - (* TODO? ?config:Config.t -> *) - proof:proof -> - theories:theory list -> - T.Term.store -> - T.Ty.store -> - unit -> - t - (** Create a new solver. - - It needs a term state and a type state to manipulate terms and types. - All terms and types interacting with this solver will need to come - from these exact states. - - @param store_proof if true, proofs from the SAT solver and theories - are retained and potentially accessible after {!solve} - returns UNSAT. - @param size influences the size of initial allocations. - @param theories theories to load from the start. Other theories - can be added using {!add_theory}. *) - - val add_theory : t -> theory -> unit - (** Add a theory to the solver. This should be called before - any call to {!solve} or to {!add_clause} and the likes (otherwise - the theory will have a partial view of the problem). *) - - val add_theory_p : t -> 'a theory_p -> 'a - (** Add the given theory and obtain its state *) - - val add_theory_l : t -> theory list -> unit - - val mk_lit_t : t -> ?sign:bool -> term -> lit - (** [mk_lit_t _ ~sign t] returns [lit'], - where [lit'] is [preprocess(lit)] and [lit] is - an internal representation of [± t]. - - The proof of [|- lit = lit'] is directly added to the solver's proof. *) - - val add_clause : t -> lit array -> proof_step -> unit - (** [add_clause solver cs] adds a boolean clause to the solver. - Subsequent calls to {!solve} will need to satisfy this clause. *) - - val add_clause_l : t -> lit list -> proof_step -> unit - (** Add a clause to the solver, given as a list. *) - - val assert_terms : t -> term list -> unit - (** Helper that turns each term into an atom, before adding the result - to the solver as an assertion *) - - val assert_term : t -> term -> unit - (** Helper that turns the term into an atom, before adding the result - to the solver as a unit clause assertion *) - - (** Result of solving for the current set of clauses *) - type res = - | Sat of Model.t (** Satisfiable *) - | Unsat of { - unsat_core: unit -> lit Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_proof_step: unit -> proof_step option; - (** Proof step for the empty clause *) - } (** Unsatisfiable *) - | Unknown of Unknown.t - (** Unknown, obtained after a timeout, memory limit, etc. *) - - (* TODO: API to push/pop/clear assumptions, in addition to ~assumptions param *) - - val solve : - ?on_exit:(unit -> unit) list -> - ?check:bool -> - ?on_progress:(t -> unit) -> - ?should_stop:(t -> int -> bool) -> - assumptions:lit list -> - t -> - res - (** [solve s] checks the satisfiability of the clauses added so far to [s]. - @param check if true, the model is checked before returning. - @param on_progress called regularly during solving. - @param assumptions a set of atoms held to be true. The unsat core, - if any, will be a subset of [assumptions]. - @param should_stop a callback regularly called with the solver, - and with a number of "steps" done since last call. The exact notion - of step is not defined, but is guaranteed to increase regularly. - The function should return [true] if it judges solving - must stop (returning [Unknown]), [false] if solving can proceed. - @param on_exit functions to be run before this returns *) - - val last_res : t -> res option - (** Last result, if any. Some operations will erase this (e.g. {!assert_term}). *) - - val push_assumption : t -> lit -> unit - (** Pushes an assumption onto the assumption stack. It will remain - there until it's pop'd by {!pop_assumptions}. *) - - val pop_assumptions : t -> int -> unit - (** [pop_assumptions solver n] removes [n] assumptions from the stack. - It removes the assumptions that were the most - recently added via {!push_assumptions}. - Note that {!check_sat_propagations_only} can call this if it meets - a conflict. *) - - type propagation_result = - | PR_sat - | PR_conflict of { backtracked: int } - | PR_unsat of { unsat_core: unit -> lit Iter.t } - - val check_sat_propagations_only : - assumptions:lit list -> t -> propagation_result - (** [check_sat_propagations_only solver] uses assumptions (including - the [assumptions] parameter, and atoms previously added via {!push_assumptions}) - and boolean+theory propagation to quickly assess satisfiability. - It is not complete; calling {!solve} is required to get an accurate - result. - @returns one of: - - - [PR_sat] if the current state seems satisfiable - - [PR_conflict {backtracked=n}] if a conflict was found and resolved, - leading to backtracking [n] levels of assumptions - - [PR_unsat …] if the assumptions were found to be unsatisfiable, with - the given core. - *) - - (* TODO: allow on_progress to return a bool to know whether to stop? *) - - val pp_stats : t CCFormat.printer - (** Print some statistics. What it prints exactly is unspecified. *) -end diff --git a/src/lra/dune b/src/lra/dune index ffd2ca61..3e1f839c 100644 --- a/src/lra/dune +++ b/src/lra/dune @@ -3,4 +3,5 @@ (public_name sidekick.arith-lra) (synopsis "Solver for LRA (real arithmetic)") (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util) - (libraries containers sidekick.core sidekick.arith sidekick.simplex)) + (libraries containers sidekick.sigs.smt sidekick.arith sidekick.simplex + sidekick.cc.plugin)) diff --git a/src/lra/sidekick_arith_lra.ml b/src/lra/sidekick_arith_lra.ml index 344ccd3c..eb8efe82 100644 --- a/src/lra/sidekick_arith_lra.ml +++ b/src/lra/sidekick_arith_lra.ml @@ -1,9 +1,9 @@ -(** {1 Linear Rational Arithmetic} *) +(** Linear Rational Arithmetic *) (* Reference: http://smtlib.cs.uiowa.edu/logics-all.shtml#QF_LRA *) -open Sidekick_core +open Sidekick_sigs_smt module Predicate = Sidekick_simplex.Predicate module Linear_expr = Sidekick_simplex.Linear_expr module Linear_expr_intf = Sidekick_simplex.Linear_expr_intf @@ -32,7 +32,7 @@ let map_view f (l : _ lra_view) : _ lra_view = | LRA_other x -> LRA_other (f x) module type ARG = sig - module S : Sidekick_core.SOLVER + module S : SOLVER module Z : INT module Q : RATIONAL with type bigint = Z.t @@ -55,7 +55,7 @@ module type ARG = sig val has_ty_real : term -> bool (** Does this term have the type [Real] *) - val lemma_lra : S.Lit.t Iter.t -> S.P.proof_rule + val lemma_lra : S.Lit.t Iter.t -> S.Proof_trace.A.rule module Gensym : sig type t @@ -104,7 +104,11 @@ module Make (A : ARG) : S with module A = A = struct module T = A.S.T.Term module Lit = A.S.Solver_internal.Lit module SI = A.S.Solver_internal - module N = A.S.Solver_internal.CC.N + module N = SI.CC.Class + + open struct + module Pr = SI.Proof_trace + end module Tag = struct type t = Lit of Lit.t | CC_eq of N.t * N.t @@ -171,7 +175,7 @@ module Make (A : ARG) : S with module A = A = struct (* monoid to track linear expressions in congruence classes, to clash on merge *) module Monoid_exprs = struct - module SI = SI + module CC = SI.CC let name = "lra.const" @@ -214,12 +218,12 @@ module Make (A : ARG) : S with module A = A = struct with Confl expl -> Error expl end - module ST_exprs = Sidekick_core.Monoid_of_repr (Monoid_exprs) + module ST_exprs = Sidekick_cc_plugin.Make (Monoid_exprs) type state = { tst: T.store; ty_st: Ty.store; - proof: SI.P.t; + proof: SI.Proof_trace.t; gensym: A.Gensym.t; in_model: unit T.Tbl.t; (* terms to add to model *) encoded_eqs: unit T.Tbl.t; @@ -245,7 +249,7 @@ module Make (A : ARG) : S with module A = A = struct ty_st; proof; in_model = T.Tbl.create 8; - st_exprs = ST_exprs.create_and_setup si; + st_exprs = ST_exprs.create_and_setup (SI.cc si); gensym = A.Gensym.create tst; simp_preds = T.Tbl.create 32; simp_defined = T.Tbl.create 16; @@ -346,12 +350,13 @@ module Make (A : ARG) : S with module A = A = struct proxy) let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = - let pr = A.lemma_lra (Iter.of_list lits) PA.proof in + let pr = Pr.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in let pr = match using with | None -> pr | Some using -> - SI.P.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using PA.proof + Pr.add_step PA.proof + @@ SI.P_core_rules.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using in PA.add_clause lits pr @@ -388,7 +393,7 @@ module Make (A : ARG) : S with module A = A = struct proxy, A.Q.one) (* look for subterms of type Real, for they will need theory combination *) - let on_subterm (self : state) _ (t : T.t) : unit = + let on_subterm (self : state) (t : T.t) : unit = Log.debugf 50 (fun k -> k "(@[lra.cc-on-subterm@ %a@])" T.pp t); match A.view_as_lra t with | LRA_other _ when not (A.has_ty_real t) -> () @@ -408,8 +413,8 @@ module Make (A : ARG) : S with module A = A = struct (* tell the CC this term exists *) let declare_term_to_cc ~sub t = Log.debugf 50 (fun k -> k "(@[lra.declare-term-to-cc@ %a@])" T.pp t); - ignore (SI.CC.add_term (SI.cc si) t : SI.CC.N.t); - if sub then on_subterm self () t + ignore (SI.CC.add_term (SI.cc si) t : N.t); + if sub then on_subterm self t in match A.view_as_lra t with @@ -491,15 +496,14 @@ module Make (A : ARG) : S with module A = A = struct | LRA_other _ -> () let simplify (self : state) (_recurse : _) (t : T.t) : - (T.t * SI.proof_step Iter.t) option = + (T.t * SI.step_id Iter.t) option = let proof_eq t u = - A.lemma_lra - (Iter.return (SI.Lit.atom self.tst (A.mk_eq self.tst t u))) - self.proof + Pr.add_step self.proof + @@ A.lemma_lra (Iter.return (SI.Lit.atom self.tst (A.mk_eq self.tst t u))) in let proof_bool t ~sign:b = let lit = SI.Lit.atom ~sign:b self.tst t in - A.lemma_lra (Iter.return lit) self.proof + Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) in match A.view_as_lra t with @@ -564,7 +568,7 @@ module Make (A : ARG) : S with module A = A = struct |> CCList.flat_map (Tag.to_lits si) |> List.rev_map SI.Lit.neg in - let pr = A.lemma_lra (Iter.of_list confl) (SI.proof si) in + let pr = Pr.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) in SI.raise_conflict si acts confl pr let on_propagate_ si acts lit ~reason = @@ -573,7 +577,10 @@ module Make (A : ARG) : S with module A = A = struct (* TODO: more detailed proof certificate *) SI.propagate si acts lit ~reason:(fun () -> let lits = CCList.flat_map (Tag.to_lits si) reason in - let pr = A.lemma_lra Iter.(cons lit (of_list lits)) (SI.proof si) in + let pr = + Pr.add_step (SI.proof si) + @@ A.lemma_lra Iter.(cons lit (of_list lits)) + in CCList.flat_map (Tag.to_lits si) reason, pr) | _ -> () @@ -616,7 +623,7 @@ module Make (A : ARG) : S with module A = A = struct if A.Q.(le_const <> zero) then ( (* [c=0] when [c] is not 0 *) let lit = SI.Lit.neg @@ SI.mk_lit si acts @@ A.mk_eq self.tst t1 t2 in - let pr = A.lemma_lra (Iter.return lit) self.proof in + let pr = Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) in SI.add_clause_permanent si acts [ lit ] pr ) ) else ( @@ -791,14 +798,14 @@ module Make (A : ARG) : S with module A = A = struct SI.on_final_check si (final_check_ st); SI.on_partial_check si (partial_check_ st); SI.on_model si ~ask:(model_ask_ st) ~complete:(model_complete_ st); - SI.on_cc_is_subterm si (on_subterm st); - SI.on_cc_pre_merge si (fun si acts n1 n2 expl -> + SI.on_cc_is_subterm si (fun (_, _, t) -> on_subterm st t); + SI.on_cc_pre_merge si (fun (cc, acts, n1, n2, expl) -> match as_const_ (N.term n1), as_const_ (N.term n2) with | Some q1, Some q2 when A.Q.(q1 <> q2) -> (* classes with incompatible constants *) Log.debugf 30 (fun k -> k "(@[lra.merge-incompatible-consts@ %a@ %a@])" N.pp n1 N.pp n2); - SI.CC.raise_conflict_from_expl si acts expl + SI.CC.raise_conflict_from_expl cc acts expl | _ -> ()); SI.on_th_combination si (do_th_combination st); st diff --git a/src/main/pure_sat_solver.ml b/src/main/pure_sat_solver.ml index 47df0b09..88206499 100644 --- a/src/main/pure_sat_solver.ml +++ b/src/main/pure_sat_solver.ml @@ -22,7 +22,13 @@ end (* TODO: on the fly compression *) module Proof : sig - include Sidekick_sat.PROOF with type lit = Lit.t + include Sidekick_sigs_proof_trace.S + + module Rule : + Sidekick_sat.PROOF_RULES + with type lit = Lit.t + and type rule = A.rule + and type step_id = A.step_id type in_memory @@ -51,12 +57,20 @@ end = struct | Inner of in_memory | Out of { oc: out_channel; close: unit -> unit } - type proof_step = unit - type proof_rule = t -> proof_step + module A = struct + type step_id = unit + type rule = t -> unit - module Step_vec = Vec_unit + module Step_vec = Vec_unit + end - let[@inline] enabled pr = + open A + + let[@inline] add_step (self : t) r = r self + let add_unsat _ _ = () + let delete _ _ = () + + let[@inline] enabled (pr : t) = match pr with | Dummy -> false | Inner _ | Out _ -> true @@ -64,29 +78,37 @@ end = struct let[@inline] emit_lits_buf_ buf lits = lits (fun i -> bpf buf "%d " i) let[@inline] emit_lits_out_ oc lits = lits (fun i -> fpf oc "%d " i) - let emit_input_clause lits self = - match self with - | Dummy -> () - | Inner buf -> - bpf buf "i "; - emit_lits_buf_ buf lits; - bpf buf "0\n" - | Out { oc; _ } -> - fpf oc "i "; - emit_lits_out_ oc lits; - fpf oc "0\n" + module Rule = struct + type nonrec lit = lit + type nonrec rule = rule + type nonrec step_id = step_id - let emit_redundant_clause lits ~hyps:_ self = - match self with - | Dummy -> () - | Inner buf -> - bpf buf "r "; - emit_lits_buf_ buf lits; - bpf buf "0\n" - | Out { oc; _ } -> - fpf oc "r "; - emit_lits_out_ oc lits; - fpf oc "0\n" + let sat_input_clause lits self = + match self with + | Dummy -> () + | Inner buf -> + bpf buf "i "; + emit_lits_buf_ buf lits; + bpf buf "0\n" + | Out { oc; _ } -> + fpf oc "i "; + emit_lits_out_ oc lits; + fpf oc "0\n" + + let sat_redundant_clause lits ~hyps:_ self = + match self with + | Dummy -> () + | Inner buf -> + bpf buf "r "; + emit_lits_buf_ buf lits; + bpf buf "0\n" + | Out { oc; _ } -> + fpf oc "r "; + emit_lits_out_ oc lits; + fpf oc "0\n" + + let sat_unsat_core _ _ = () + end let del_clause () lits self = match self with @@ -100,9 +122,6 @@ end = struct emit_lits_out_ oc lits; fpf oc "0\n" - let emit_unsat _ _ = () - let emit_unsat_core _ _ = () - (* lifetime *) let dummy : t = Dummy @@ -153,10 +172,11 @@ module Arg = struct type lit = Lit.t - module Proof = Proof + module Proof_trace = Proof + module Proof_rules = Proof.Rule type proof = Proof.t - type proof_step = Proof.proof_step + type step_id = Proof.A.step_id end module SAT = Sidekick_sat.Make_pure_sat (Arg) diff --git a/src/mini-cc/Sidekick_mini_cc.ml b/src/mini-cc/Sidekick_mini_cc.ml index 444c0f2f..6decc650 100644 --- a/src/mini-cc/Sidekick_mini_cc.ml +++ b/src/mini-cc/Sidekick_mini_cc.ml @@ -5,7 +5,7 @@ module type TERM = Sidekick_sigs_term.S module type ARG = sig module T : TERM - val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t + val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t end module type S = sig @@ -165,7 +165,7 @@ module Make (A : ARG) = struct () let sub_ t k : unit = - match A.cc_view t with + match A.view_as_cc t with | Bool _ | Opaque _ -> () | App_fun (_, args) -> args k | App_ho (f, a) -> @@ -202,7 +202,7 @@ module Make (A : ARG) = struct let compute_sig (self : t) (n : node) : Signature.t option = let[@inline] return x = Some x in - match A.cc_view n.n_t with + match A.view_as_cc n.n_t with | Bool _ | Opaque _ -> None | Eq (a, b) -> let a = find_t_ self a in @@ -318,7 +318,7 @@ module Make (A : ARG) = struct (* API *) let add_lit (self : t) (p : T.t) (sign : bool) : unit = - match A.cc_view p with + match A.view_as_cc p with | Eq (t1, t2) when sign -> let n1 = add_t self t1 in let n2 = add_t self t2 in diff --git a/src/mini-cc/Sidekick_mini_cc.mli b/src/mini-cc/Sidekick_mini_cc.mli index 85d5b588..413d2518 100644 --- a/src/mini-cc/Sidekick_mini_cc.mli +++ b/src/mini-cc/Sidekick_mini_cc.mli @@ -15,7 +15,7 @@ module type TERM = Sidekick_sigs_term.S module type ARG = sig module T : TERM - val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t + val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t end (** Main signature for an instance of the mini congruence closure *) diff --git a/src/mini-cc/tests/sidekick_test_minicc.ml b/src/mini-cc/tests/sidekick_test_minicc.ml index 0d96fd3e..1a3969bb 100644 --- a/src/mini-cc/tests/sidekick_test_minicc.ml +++ b/src/mini-cc/tests/sidekick_test_minicc.ml @@ -4,7 +4,7 @@ module A = Alcotest module CC = Sidekick_mini_cc.Make (struct module T = Sidekick_base.Solver_arg - let cc_view = Term.cc_view + let view_as_cc = Term.cc_view end) module Setup () = struct diff --git a/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml b/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml new file mode 100644 index 00000000..da1d2c0c --- /dev/null +++ b/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml @@ -0,0 +1,18 @@ +module type S = Sidekick_sigs_proof_trace.S + +module type ARG = sig + include Sidekick_sigs_proof_trace.ARG + + val dummy_step_id : step_id +end + +module Make (A : ARG) : S with type t = unit and module A = A = struct + module A = A + + type t = unit + + let enabled _ = false + let add_step _ _ = A.dummy_step_id + let add_unsat _ _ = () + let delete _ _ = () +end diff --git a/src/proof-trace/dummy/dune b/src/proof-trace/dummy/dune new file mode 100644 index 00000000..57140a75 --- /dev/null +++ b/src/proof-trace/dummy/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_proof_trace_dummy) + (public_name sidekick.proof-trace.dummy) + (synopsis "Dummy proof trace that stores nothing") + (libraries sidekick.util sidekick.sigs.proof-trace) + (flags :standard -open Sidekick_util)) diff --git a/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml b/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml new file mode 100644 index 00000000..9deee8f7 --- /dev/null +++ b/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml @@ -0,0 +1,23 @@ +module type ARG = Sidekick_sigs_proof_trace.ARG +module type S = Sidekick_sigs_proof_trace.S + +(** Dynamic version. + + The proof trace is a first-class module that can be provided at runtime. *) +module Make_dyn (A : ARG) : S with module A = A = struct + module A = A + + module type DYN = sig + val enabled : unit -> bool + val add_step : A.rule -> A.step_id + val add_unsat : A.step_id -> unit + val delete : A.step_id -> unit + end + + type t = (module DYN) + + let[@inline] enabled ((module Tr) : t) : bool = Tr.enabled () + let[@inline] add_step ((module Tr) : t) rule : A.step_id = Tr.add_step rule + let[@inline] add_unsat ((module Tr) : t) s : unit = Tr.add_unsat s + let[@inline] delete ((module Tr) : t) s : unit = Tr.delete s +end diff --git a/src/proof-trace/dyn/dune b/src/proof-trace/dyn/dune new file mode 100644 index 00000000..24ca6785 --- /dev/null +++ b/src/proof-trace/dyn/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_proof_trace_dyn) + (public_name sidekick.proof-trace.dyn) + (synopsis "Dynamic version of the proof trace") + (libraries sidekick.util sidekick.sigs.proof-trace) + (flags :standard -open Sidekick_util)) diff --git a/src/sat/Proof_dummy.ml b/src/sat/Proof_dummy.ml index 063e7654..7fe4b9f3 100644 --- a/src/sat/Proof_dummy.ml +++ b/src/sat/Proof_dummy.ml @@ -1,21 +1,17 @@ +(** Dummy proof module for rule=empty *) + module Make (Lit : sig type t end) : - Solver_intf.PROOF + Solver_intf.PROOF_RULES with type lit = Lit.t - and type t = unit - and type proof_step = unit = struct + and type rule = unit + and type step_id = unit = struct type lit = Lit.t - type t = unit - type proof_step = unit - type proof_rule = t -> proof_step + type rule = unit + type step_id = unit - module Step_vec = Vec_unit - - let enabled (_pr : t) = false - let del_clause _ _ (_pr : t) = () - let emit_redundant_clause _ ~hyps:_ _ = () - let emit_input_clause _ _ = () - let emit_unsat _ _ = () - let emit_unsat_core _ (_pr : t) = () + let sat_input_clause _ = () + let sat_redundant_clause _ ~hyps:_ = () + let sat_unsat_core _ = () end diff --git a/src/sat/Proof_dummy.mli b/src/sat/Proof_dummy.mli deleted file mode 100644 index 673a4395..00000000 --- a/src/sat/Proof_dummy.mli +++ /dev/null @@ -1,11 +0,0 @@ -(** Dummy proof module that does nothing. *) - -module Make (Lit : sig - type t -end) : sig - include - Solver_intf.PROOF - with type lit = Lit.t - and type t = unit - and type proof_step = unit -end diff --git a/src/sat/Sidekick_sat.ml b/src/sat/Sidekick_sat.ml index b64bacf8..2210b271 100644 --- a/src/sat/Sidekick_sat.ml +++ b/src/sat/Sidekick_sat.ml @@ -5,7 +5,8 @@ module Solver_intf = Solver_intf module type S = Solver_intf.S module type LIT = Solver_intf.LIT module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T -module type PROOF = Solver_intf.PROOF +module type PLUGIN_SAT = Solver_intf.PLUGIN_SAT +module type PROOF_RULES = Solver_intf.PROOF_RULES type lbool = Solver_intf.lbool = L_true | L_false | L_undefined diff --git a/src/sat/Solver.ml b/src/sat/Solver.ml index 75cfa446..08d7d7f0 100644 --- a/src/sat/Solver.ml +++ b/src/sat/Solver.ml @@ -13,10 +13,16 @@ let invalid_argf fmt = Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt module Make (Plugin : PLUGIN) = struct - type lit = Plugin.lit + module Lit = Plugin.Lit + module Proof_trace = Plugin.Proof_trace + module Proof_rules = Plugin.Proof_rules + module Step_vec = Proof_trace.A.Step_vec + + type lit = Plugin.Lit.t type theory = Plugin.t - type proof = Plugin.proof - type proof_step = Plugin.proof_step + type proof_rule = Proof_trace.A.rule + type proof_step = Proof_trace.A.step_id + type proof_trace = Proof_trace.t module Clause_pool_id : sig type t = private int @@ -28,10 +34,6 @@ module Make (Plugin : PLUGIN) = struct let _unsafe_of_int x = x end - module Lit = Plugin.Lit - module Proof = Plugin.Proof - module Step_vec = Proof.Step_vec - (* ### types ### *) (* a boolean variable (positive int) *) @@ -835,7 +837,7 @@ module Make (Plugin : PLUGIN) = struct type t = { store: store; (* atom/var/clause store *) th: theory; (* user defined theory *) - proof: Proof.t; (* the proof object *) + proof: Proof_trace.t; (* the proof object *) (* Clauses are simplified for efficiency purposes. In the following vectors, the comments actually refer to the original non-simplified clause. *) @@ -878,10 +880,11 @@ module Make (Plugin : PLUGIN) = struct temp_step_vec: Step_vec.t; mutable var_incr: float; (* increment for variables' activity *) mutable clause_incr: float; (* increment for clauses' activity *) - mutable on_conflict: (t -> Clause.t -> unit) option; - mutable on_decision: (t -> lit -> unit) option; - mutable on_learnt: (t -> Clause.t -> unit) option; - mutable on_gc: (t -> lit array -> unit) option; + (* FIXME: use event *) + on_conflict: Clause.t Event.Emitter.t; + on_decision: lit Event.Emitter.t; + on_learnt: Clause.t Event.Emitter.t; + on_gc: lit array Event.Emitter.t; stat: Stat.t; n_conflicts: int Stat.counter; n_propagations: int Stat.counter; @@ -930,21 +933,21 @@ module Make (Plugin : PLUGIN) = struct n_propagations = Stat.mk_int stat "sat.n-propagations"; n_restarts = Stat.mk_int stat "sat.n-restarts"; n_minimized_away = Stat.mk_int stat "sat.n-confl-lits-minimized-away"; - on_conflict = None; - on_decision = None; - on_learnt = None; - on_gc = None; + on_conflict = Event.Emitter.create (); + on_decision = Event.Emitter.create (); + on_learnt = Event.Emitter.create (); + on_gc = Event.Emitter.create (); } - let create ?on_conflict ?on_decision ?on_learnt ?on_gc ?(stat = Stat.global) - ?(size = `Big) ~proof (th : theory) : t = + let on_gc self = Event.of_emitter self.on_gc + let on_conflict self = Event.of_emitter self.on_conflict + let on_decision self = Event.of_emitter self.on_decision + let on_learnt self = Event.of_emitter self.on_learnt + + let create ?(stat = Stat.global) ?(size = `Big) ~proof (th : theory) : t = let store = Store.create ~size ~stat () in let max_clauses_learnt = ref 0 in let self = create_ ~max_clauses_learnt ~store ~proof ~stat th in - self.on_decision <- on_decision; - self.on_conflict <- on_conflict; - self.on_learnt <- on_learnt; - self.on_gc <- on_gc; self (* iterate on all learnt clauses, pools included *) @@ -1071,10 +1074,10 @@ module Make (Plugin : PLUGIN) = struct if !steps = [] then proof_c2 else - Proof.emit_redundant_clause - (Iter.return (Atom.lit self.store a)) - ~hyps:Iter.(cons proof_c2 (of_list !steps)) - self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause + (Iter.return (Atom.lit self.store a)) + ~hyps:Iter.(cons proof_c2 (of_list !steps)) in Atom.set_proof_lvl0 self.store a p; @@ -1164,10 +1167,11 @@ module Make (Plugin : PLUGIN) = struct (Atom.debug_a store) atoms); let proof = let lits = Iter.of_array atoms |> Iter.map (Atom.lit store) in - Proof.emit_redundant_clause lits - ~hyps: - Iter.(cons (Clause.proof_step self.store c) (of_list !res0_proofs)) - self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause lits + ~hyps: + Iter.( + cons (Clause.proof_step self.store c) (of_list !res0_proofs)) in Clause.make_a store atoms proof ~removable:(Clause.removable store c) ) @@ -1260,7 +1264,7 @@ module Make (Plugin : PLUGIN) = struct (Clause.debug self.store) c let prove_unsat self (us : clause) : clause = - if Proof.enabled self.proof && Clause.n_atoms self.store us > 0 then ( + if Proof_trace.enabled self.proof && Clause.n_atoms self.store us > 0 then ( (* reduce [c] to an empty clause, all its literals should be false at level 0 *) Log.debugf 1 (fun k -> k "(@[sat.prove-unsat@ :from %a@])" (Clause.debug self.store) us); @@ -1277,8 +1281,9 @@ module Make (Plugin : PLUGIN) = struct | _ -> assert false); let p_empty = - Proof.emit_redundant_clause Iter.empty ~hyps:(Step_vec.to_iter pvec) - self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause Iter.empty + ~hyps:(Step_vec.to_iter pvec) in Step_vec.clear pvec; let c_empty = Clause.make_l self.store [] ~removable:false p_empty in @@ -1296,11 +1301,9 @@ module Make (Plugin : PLUGIN) = struct match us with | US_false c -> self.unsat_at_0 <- Some c; - (match self.on_learnt with - | Some f -> f self c - | None -> ()); + Event.emit self.on_learnt c; let p = Clause.proof_step self.store c in - Proof.emit_unsat p self.proof; + Proof_trace.add_unsat self.proof p; US_false c | US_local _ -> us in @@ -1405,7 +1408,7 @@ module Make (Plugin : PLUGIN) = struct | Some (Bcp c | Bcp_lazy (lazy c)) -> let c_atoms = Clause.atoms_a store c in assert (Var.equal v (Atom.var c_atoms.(0))); - if Proof.enabled self.proof then + if Proof_trace.enabled self.proof then Step_vec.push steps (Clause.proof_step self.store c); (* check that all the other lits of [c] are marked or redundant *) @@ -1418,7 +1421,7 @@ module Make (Plugin : PLUGIN) = struct | _ when lvl_v2 = 0 -> (* can always remove literals at level 0, but got to update proof properly *) - if Proof.enabled self.proof then ( + if Proof_trace.enabled self.proof then ( let p = proof_of_atom_lvl0_ self (Atom.neg c_atoms.(i)) in Step_vec.push steps p ) @@ -1536,7 +1539,7 @@ module Make (Plugin : PLUGIN) = struct clause); if Clause.removable store clause then clause_bump_activity self clause; - if Proof.enabled self.proof then + if Proof_trace.enabled self.proof then Step_vec.push steps (Clause.proof_step self.store clause); (* visit the current predecessors *) @@ -1548,7 +1551,7 @@ module Make (Plugin : PLUGIN) = struct if Atom.level store q = 0 then ( (* skip [q] entirely, resolved away at level 0 *) assert (Atom.is_false store q); - if Proof.enabled self.proof then ( + if Proof_trace.enabled self.proof then ( let step = proof_of_atom_lvl0_ self (Atom.neg q) in Step_vec.push steps step ) @@ -1639,15 +1642,13 @@ module Make (Plugin : PLUGIN) = struct assert (cr.cr_backtrack_lvl = 0 && decision_level self = 0); let p = - Proof.emit_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) - self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause + (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) + ~hyps:(Step_vec.to_iter cr.cr_steps) in let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in - (match self.on_learnt with - | Some f -> f self uclause - | None -> ()); + Event.emit self.on_learnt uclause; if Atom.is_false store fuip then (* incompatible at level 0 *) @@ -1658,19 +1659,17 @@ module Make (Plugin : PLUGIN) = struct | _ -> let fuip = cr.cr_learnt.(0) in let p = - Proof.emit_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) - self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause + (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) + ~hyps:(Step_vec.to_iter cr.cr_steps) in let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in add_clause_to_vec_ ~pool self lclause; attach_clause self lclause; clause_bump_activity self lclause; - (match self.on_learnt with - | Some f -> f self lclause - | None -> ()); + Event.emit self.on_learnt lclause; assert cr.cr_is_uip; enqueue_bool self fuip ~level:cr.cr_backtrack_lvl (Bcp lclause)); var_decay_activity self; @@ -2004,7 +2003,7 @@ module Make (Plugin : PLUGIN) = struct let[@inline] current_slice st : _ Solver_intf.acts = let module M = struct - type nonrec proof = proof + type nonrec proof = Proof_trace.t type nonrec proof_step = proof_step type nonrec lit = lit @@ -2022,7 +2021,7 @@ module Make (Plugin : PLUGIN) = struct (* full slice, for [if_sat] final check *) let[@inline] full_slice st : _ Solver_intf.acts = let module M = struct - type nonrec proof = proof + type nonrec proof = Proof_trace.t type nonrec proof_step = proof_step type nonrec lit = lit @@ -2185,14 +2184,8 @@ module Make (Plugin : PLUGIN) = struct mark_dirty_atom (Atom.neg atoms.(0)); (* need to remove from watchlists *) mark_dirty_atom (Atom.neg atoms.(1)); - (match self.on_gc with - | Some f -> - let lits = Clause.lits_a store c in - f self lits - | None -> ()); - Proof.del_clause - (Clause.proof_step store c) - (Clause.lits_iter store c) self.proof + Event.emit self.on_gc (Clause.lits_a store c); + Proof_trace.delete self.proof (Clause.proof_step store c) in let gc_arg = @@ -2281,9 +2274,7 @@ module Make (Plugin : PLUGIN) = struct let current_level = decision_level self in enqueue_bool self atom ~level:current_level Decision; Stat.incr self.n_decisions; - (match self.on_decision with - | Some f -> f self (Atom.lit self.store atom) - | None -> ()); + Event.emit self.on_decision (Atom.lit self.store atom); true ) in @@ -2291,13 +2282,13 @@ module Make (Plugin : PLUGIN) = struct (* do some amount of search, until the number of conflicts or clause learnt reaches the given parameters *) - let search (st : t) ~on_progress ~(max_conflicts : int) : unit = + let search (self : t) ~on_progress ~(max_conflicts : int) : unit = Log.debugf 3 (fun k -> k "(@[sat.search@ :max-conflicts %d@ :max-learnt %d@])" max_conflicts - !(st.max_clauses_learnt)); + !(self.max_clauses_learnt)); let n_conflicts = ref 0 in while true do - match propagate st with + match propagate self with | Some confl -> (* Conflict *) incr n_conflicts; @@ -2305,38 +2296,36 @@ module Make (Plugin : PLUGIN) = struct might 'forget' the initial conflict clause, and only add the analyzed backtrack clause. So in those case, we use add_clause to make sure the initial conflict clause is also added. *) - if Clause.attached st.store confl then - add_boolean_conflict st confl + if Clause.attached self.store confl then + add_boolean_conflict self confl else - add_clause_ ~pool:st.clauses_learnt st confl; - Stat.incr st.n_conflicts; - (match st.on_conflict with - | Some f -> f st confl - | None -> ()) + add_clause_ ~pool:self.clauses_learnt self confl; + Stat.incr self.n_conflicts; + Event.emit self.on_conflict confl | None -> (* No Conflict *) - assert (st.elt_head = AVec.size st.trail); - assert (st.elt_head = st.th_head); + assert (self.elt_head = AVec.size self.trail); + assert (self.elt_head = self.th_head); if max_conflicts > 0 && !n_conflicts >= max_conflicts then ( Log.debug 1 "(sat.restarting)"; - cancel_until st 0; - Stat.incr st.n_restarts; + cancel_until self 0; + Stat.incr self.n_restarts; raise_notrace Restart ); (* if decision_level() = 0 then simplify (); *) let do_gc = - !(st.max_clauses_learnt) > 0 - && cp_size_ st.clauses_learnt - AVec.size st.trail - > !(st.max_clauses_learnt) - || Vec.exists cp_needs_gc_ st.clause_pools + !(self.max_clauses_learnt) > 0 + && cp_size_ self.clauses_learnt - AVec.size self.trail + > !(self.max_clauses_learnt) + || Vec.exists cp_needs_gc_ self.clause_pools in if do_gc then ( - reduce_clause_db st; + reduce_clause_db self; on_progress () ); - let decided = pick_branch_lit ~full:true st in + let decided = pick_branch_lit ~full:true self in if not decided then raise_notrace E_sat done @@ -2401,9 +2390,7 @@ module Make (Plugin : PLUGIN) = struct k "(@[sat.theory-conflict-clause@ %a@])" (Clause.debug self.store) c); Stat.incr self.n_conflicts; - (match self.on_conflict with - | Some f -> f self c - | None -> ()); + Event.emit self.on_conflict c; Delayed_actions.add_clause_learnt self.delayed_actions c; perform_delayed_actions self; on_progress ()) @@ -2414,7 +2401,10 @@ module Make (Plugin : PLUGIN) = struct List.iter (fun l -> let atoms = Util.array_of_list_map (make_atom_ self) l in - let proof = Proof.emit_input_clause (Iter.of_list l) self.proof in + let proof = + Proof_trace.add_step self.proof + @@ Proof_rules.sat_input_clause (Iter.of_list l) + in let c = Clause.make_a self.store ~removable:false atoms proof in Log.debugf 10 (fun k -> k "(@[sat.assume-clause@ @[%a@]@])" (Clause.debug self.store) @@ -2504,7 +2494,8 @@ module Make (Plugin : PLUGIN) = struct let proof = let lits = Iter.of_list !res |> Iter.map (Atom.lit self.store) in let hyps = Iter.of_list (Clause.proof_step self.store c :: !lvl0) in - Proof.emit_redundant_clause lits ~hyps self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_redundant_clause lits ~hyps in Clause.make_l self.store ~removable:false !res proof ) @@ -2539,7 +2530,8 @@ module Make (Plugin : PLUGIN) = struct assert (Atom.equal first @@ List.hd core); let proof = let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in - Proof.emit_unsat_core lits self.proof + Proof_trace.add_step self.proof + @@ Proof_rules.sat_unsat_core lits in Clause.make_l self.store ~removable:false [] proof) in @@ -2547,7 +2539,7 @@ module Make (Plugin : PLUGIN) = struct in let module M = struct type nonrec lit = lit - type nonrec proof = proof_step + type nonrec proof_step = proof_step type clause = Clause.t let unsat_conflict = unsat_conflict @@ -2615,11 +2607,17 @@ module Make (Plugin : PLUGIN) = struct add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr let add_input_clause self (c : lit list) = - let pr = Proof.emit_input_clause (Iter.of_list c) self.proof in + let pr = + Proof_trace.add_step self.proof + @@ Proof_rules.sat_input_clause (Iter.of_list c) + in add_clause self c pr let add_input_clause_a self c = - let pr = Proof.emit_input_clause (Iter.of_array c) self.proof in + let pr = + Proof_trace.add_step self.proof + @@ Proof_rules.sat_input_clause (Iter.of_array c) + in add_clause_a self c pr (* run [f()] with additional assumptions *) @@ -2693,12 +2691,9 @@ end) [@@inline] [@@specialise] module Make_pure_sat (Plugin : Solver_intf.PLUGIN_SAT) = Make (struct - type lit = Plugin.lit - type proof = Plugin.proof - type proof_step = Plugin.proof_step - module Lit = Plugin.Lit - module Proof = Plugin.Proof + module Proof_trace = Plugin.Proof_trace + module Proof_rules = Plugin.Proof_rules type t = unit diff --git a/src/sat/Solver.mli b/src/sat/Solver.mli index 24be6a99..3a0858d0 100644 --- a/src/sat/Solver.mli +++ b/src/sat/Solver.mli @@ -3,18 +3,14 @@ module type S = Solver_intf.S module Make_pure_sat (Th : Solver_intf.PLUGIN_SAT) : S - with type lit = Th.lit - and module Lit = Th.Lit - and type proof = Th.proof - and type proof_step = Th.proof_step - and module Proof = Th.Proof + with module Lit = Th.Lit + and module Proof_trace = Th.Proof_trace + and module Proof_rules = Th.Proof_rules and type theory = unit module Make_cdcl_t (Th : Solver_intf.PLUGIN_CDCL_T) : S - with type lit = Th.lit - and module Lit = Th.Lit - and type proof = Th.proof - and type proof_step = Th.proof_step - and module Proof = Th.Proof + with module Lit = Th.Lit + and module Proof_trace = Th.Proof_trace + and module Proof_rules = Th.Proof_rules and type theory = Th.t diff --git a/src/sat/Solver_intf.ml b/src/sat/Solver_intf.ml index f098011b..e38954a6 100644 --- a/src/sat/Solver_intf.ml +++ b/src/sat/Solver_intf.ml @@ -42,7 +42,7 @@ type 'form sat_state = (module SAT_STATE with type lit = 'form) module type UNSAT_STATE = sig type lit type clause - type proof + type proof_step val unsat_conflict : unit -> clause (** Returns the unsat clause found at the toplevel *) @@ -50,14 +50,14 @@ module type UNSAT_STATE = sig val unsat_assumptions : unit -> lit Iter.t (** Subset of assumptions responsible for "unsat" *) - val unsat_proof : unit -> proof + val unsat_proof : unit -> proof_step end -type ('lit, 'clause, 'proof) unsat_state = +type ('lit, 'clause, 'proof_step) unsat_state = (module UNSAT_STATE with type lit = 'lit and type clause = 'clause - and type proof = 'proof) + and type proof_step = 'proof_step) (** The type of values returned when the solver reaches an UNSAT state. *) type same_sign = bool @@ -65,7 +65,8 @@ type same_sign = bool [true] means the literal stayed the same, [false] that its sign was flipped. *) (** The type of reasons for propagations of a lit [f]. *) -type ('lit, 'proof) reason = Consequence of (unit -> 'lit list * 'proof) +type ('lit, 'proof_step) reason = + | Consequence of (unit -> 'lit list * 'proof_step) [@@unboxed] (** [Consequence (l, p)] means that the lits in [l] imply the propagated lit [f]. The proof should be a proof of the clause "[l] implies [f]". @@ -168,28 +169,21 @@ module type LIT = sig but one returns [false] and the other [true]. *) end -module type PROOF = Sidekick_core.SAT_PROOF +module type PROOF_RULES = Sidekick_sigs_proof_sat.S (** Signature for theories to be given to the CDCL(T) solver *) module type PLUGIN_CDCL_T = sig type t (** The plugin state itself *) - type lit + module Lit : LIT + module Proof_trace : Sidekick_sigs_proof_trace.S - module Lit : LIT with type t = lit - - type proof - (** Proof storage/recording *) - - type proof_step - (** Identifier for a clause precendently added/proved *) - - module Proof : - PROOF - with type t = proof - and type lit = lit - and type proof_step = proof_step + module Proof_rules : + PROOF_RULES + with type lit = Lit.t + and type rule = Proof_trace.A.rule + and type step_id = Proof_trace.A.step_id val push_level : t -> unit (** Create a new backtrack level *) @@ -197,12 +191,14 @@ module type PLUGIN_CDCL_T = sig val pop_levels : t -> int -> unit (** Pop [n] levels of the theory *) - val partial_check : t -> (lit, proof, proof_step) acts -> unit + val partial_check : + t -> (Lit.t, Proof_trace.t, Proof_trace.A.step_id) acts -> unit (** Assume the lits in the slice, possibly using the [slice] to push new lits to be propagated or to raising a conflict or to add new lemmas. *) - val final_check : t -> (lit, proof, proof_step) acts -> unit + val final_check : + t -> (Lit.t, Proof_trace.t, Proof_trace.A.step_id) acts -> unit (** Called at the end of the search in case a model has been found. If no new clause is pushed, then proof search ends and "sat" is returned; if lemmas are added, search is resumed; @@ -211,18 +207,14 @@ end (** Signature for pure SAT solvers *) module type PLUGIN_SAT = sig - type lit + module Lit : LIT + module Proof_trace : Sidekick_sigs_proof_trace.S - module Lit : LIT with type t = lit - - type proof - type proof_step - - module Proof : - PROOF - with type t = proof - and type lit = lit - and type proof_step = proof_step + module Proof_rules : + PROOF_RULES + with type lit = Lit.t + and type rule = Proof_trace.A.rule + and type step_id = Proof_trace.A.step_id end exception Resource_exhausted @@ -235,19 +227,20 @@ module type S = sig These are the internal modules used, you should probably not use them if you're not familiar with the internals of mSAT. *) - type lit - (** literals *) + module Lit : LIT + module Proof_trace : Sidekick_sigs_proof_trace.S - module Lit : LIT with type t = lit + type lit = Lit.t + (** literals *) type clause type theory + type proof_rule = Proof_trace.A.rule + type proof_step = Proof_trace.A.step_id - type proof + type proof_trace = Proof_trace.t (** A representation of a full proof *) - type proof_step - type solver (** The main solver type. *) @@ -279,8 +272,12 @@ module type S = sig (** List of atoms of a clause *) end - (** A module to manipulate proofs. *) - module Proof : PROOF with type lit = lit and type t = proof + (** Proof rules for SAT solving *) + module Proof_rules : + PROOF_RULES + with type lit = lit + and type rule = proof_rule + and type step_id = proof_step (** {2 Main Solver Type} *) @@ -288,13 +285,9 @@ module type S = sig (** Main solver type, containing all state for solving. *) val create : - ?on_conflict:(t -> Clause.t -> unit) -> - ?on_decision:(t -> lit -> unit) -> - ?on_learnt:(t -> Clause.t -> unit) -> - ?on_gc:(t -> lit array -> unit) -> ?stat:Stat.t -> ?size:[ `Tiny | `Small | `Big ] -> - proof:Proof.t -> + proof:proof_trace -> theory -> t (** Create new solver @@ -312,9 +305,14 @@ module type S = sig val stat : t -> Stat.t (** Statistics *) - val proof : t -> proof + val proof : t -> proof_trace (** Access the inner proof *) + val on_conflict : t -> Clause.t Event.t + val on_decision : t -> lit Event.t + val on_learnt : t -> Clause.t Event.t + val on_gc : t -> lit array Event.t + (** {2 Types} *) (** Result type for the solver *) diff --git a/src/sat/dune b/src/sat/dune index 89966075..505da013 100644 --- a/src/sat/dune +++ b/src/sat/dune @@ -1,8 +1,6 @@ (library (name sidekick_sat) (public_name sidekick.sat) - (libraries iter sidekick.util sidekick.core) + (libraries iter sidekick.util sidekick.core sidekick.sigs.proof-trace) (synopsis "Pure OCaml SAT solver implementation for sidekick") - (flags :standard -warn-error -a+8 -open Sidekick_util) - (ocamlopt_flags :standard -O3 -bin-annot -unbox-closures - -unbox-closures-factor 20)) + (flags :standard -open Sidekick_util)) diff --git a/src/sigs/cc/sidekick_sigs_cc.ml b/src/sigs/cc/sidekick_sigs_cc.ml index 6338b365..5162ba26 100644 --- a/src/sigs/cc/sidekick_sigs_cc.ml +++ b/src/sigs/cc/sidekick_sigs_cc.ml @@ -12,15 +12,15 @@ module type PROOF_TRACE = Sidekick_sigs_proof_trace.S it detects that they are true or false; it must also be able to create conflicts when the set of (dis)equalities is inconsistent *) -module type ACTIONS = sig +module type DYN_ACTIONS = sig type term type lit - type proof - type proof_step + type proof_trace + type step_id - val proof : unit -> proof + val proof_trace : unit -> proof_trace - val raise_conflict : lit list -> proof_step -> 'a + val raise_conflict : lit list -> step_id -> 'a (** [raise_conflict c pr] declares that [c] is a tautology of the theory of congruence. This does not return (it should raise an exception). @@ -37,7 +37,7 @@ module type ACTIONS = sig This does not return. It should raise an exception. *) - val propagate : lit -> reason:(unit -> lit list * proof_step) -> unit + val propagate : lit -> reason:(unit -> lit list * step_id) -> unit (** [propagate lit ~reason pr] declares that [reason() => lit] is a tautology. @@ -55,40 +55,22 @@ module type ARG = sig module Proof_trace : PROOF_TRACE (** Arguments for the congruence closure *) - module CC : sig - val view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) View.t - (** View the term through the lens of the congruence closure *) + val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) View.t + (** View the term through the lens of the congruence closure *) - val mk_lit_eq : ?sign:bool -> T.Term.store -> T.Term.t -> T.Term.t -> Lit.t - (** [mk_lit_eq store t u] makes the literal [t=u] *) + val mk_lit_eq : ?sign:bool -> T.Term.store -> T.Term.t -> T.Term.t -> Lit.t + (** [mk_lit_eq store t u] makes the literal [t=u] *) - module Proof_rules : - Sidekick_sigs_proof_core.S - with type term = T.Term.t - and type lit = Lit.t - and type step_id = Proof_trace.step_id - and type rule = Proof_trace.rule - end + module Rule_core : + Sidekick_sigs_proof_core.S + with type term = T.Term.t + and type lit = Lit.t + and type step_id = Proof_trace.A.step_id + and type rule = Proof_trace.A.rule end -(** Main congruence closure signature. - - The congruence closure handles the theory QF_UF (uninterpreted - function symbols). - It is also responsible for {i theory combination}, and provides - a general framework for equality reasoning that other - theories piggyback on. - - For example, the theory of datatypes relies on the congruence closure - to do most of the work, and "only" adds injectivity/disjointness/acyclicity - lemmas when needed. - - Similarly, a theory of arrays would hook into the congruence closure and - assert (dis)equalities as needed. -*) -module type S = sig - (** first, some aliases. *) - +(** Collection of input types, and types defined by the congruence closure *) +module type ARGS_CLASSES_EXPL_EVENT = sig module T : TERM module Lit : LIT with module T = T module Proof_trace : PROOF_TRACE @@ -98,22 +80,17 @@ module type S = sig type value = term type fun_ = T.Fun.t type lit = Lit.t - type proof = Proof_trace.t - type proof_step = Proof_trace.step_id + type proof_trace = Proof_trace.t + type step_id = Proof_trace.A.step_id type actions = - (module ACTIONS + (module DYN_ACTIONS with type term = T.Term.t and type lit = Lit.t - and type proof = proof - and type proof_step = proof_step) + and type proof_trace = proof_trace + and type step_id = step_id) (** Actions available to the congruence closure *) - type t - (** The congruence closure object. - It contains a fair amount of state and is mutable - and backtrackable. *) - (** Equivalence classes. An equivalence class is a set of terms that are currently equal @@ -122,7 +99,7 @@ module type S = sig distinguished and is called the "representative". All information pertaining to the whole equivalence class is stored - in this representative's node. + in this representative's Class.t. When two classes become equal (are "merged"), one of the two representatives is picked as the representative of the new class. @@ -140,6 +117,8 @@ module type S = sig A value of type [t] points to a particular term, but see {!find} to get the representative of the class. *) + include Sidekick_sigs.PRINT with type t := t + val term : t -> term (** Term contained in this equivalence class. If [is_root n], then [term n] is the class' representative term. *) @@ -150,14 +129,10 @@ module type S = sig which checks for equality of representatives. *) val hash : t -> int - (** An opaque hash of this node. *) - - val pp : t Fmt.printer - (** Unspecified printing of the node, for example its term, - a unique ID, etc. *) + (** An opaque hash of this Class.t. *) val is_root : t -> bool - (** Is the node a root (ie the representative of its class)? + (** Is the Class.t a root (ie the representative of its class)? See {!find} to get the root. *) val iter_class : t -> t Iter.t @@ -168,6 +143,10 @@ module type S = sig (** Traverse the parents of the class. Precondition: [is_root n] (see {!find} below) *) + (* FIXME: + [@@alert refactor "this should be replaced with a Per_class concept"] + *) + type bitfield (** A field in the bitfield of this node. This should only be allocated when a theory is initialized. @@ -182,11 +161,11 @@ module type S = sig (** Explanations Explanations are specialized proofs, created by the congruence closure - when asked to justify why twp terms are equal. *) + when asked to justify why two terms are equal. *) module Expl : sig type t - val pp : t Fmt.printer + include Sidekick_sigs.PRINT with type t := t val mk_merge : Class.t -> Class.t -> t (** Explanation: the nodes were explicitly merged *) @@ -200,12 +179,12 @@ module type S = sig or [t] and [false] because of literal [¬t] *) val mk_same_value : Class.t -> Class.t -> t + (** The two classes have the same value during model construction *) val mk_list : t list -> t (** Conjunction of explanations *) - val mk_theory : - term -> term -> (term * term * t list) list -> proof_step -> t + val mk_theory : term -> term -> (term * term * t list) list -> step_id -> t (** [mk_theory t u expl_sets pr] builds a theory explanation for why [|- t=u]. It depends on sub-explanations [expl_sets] which are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are @@ -241,28 +220,97 @@ module type S = sig type t = { lits: lit list; same_value: (Class.t * Class.t) list; - pr: proof -> proof_step; + pr: proof_trace -> step_id; } + include Sidekick_sigs.PRINT with type t := t + val is_semantic : t -> bool (** [is_semantic expl] is [true] if there's at least one pair in [expl.same_value]. *) - - val pp : t Fmt.printer end type node = Class.t (** A node of the congruence closure *) type repr = Class.t - (** Node that is currently a representative *) + (** Node that is currently a representative. *) type explanation = Expl.t +end + +(* TODO: can we have that meaningfully? the type of Class.t would depend on + the implementation, so it can't be pre-defined, but nor can it be accessed from + shortcuts from the inside. That means one cannot point to classes from outside + the opened module. + + Potential solution: + - make Expl polymorphic and lift it to toplevel, like View + - do not expose Class, only Term-based API + (** The type for a congruence closure, as a first-class module *) + module type DYN = sig + include ARGS_CLASSES_EXPL_EVENT + include Sidekick_sigs.DYN_BACKTRACKABLE + + val term_store : unit -> term_store + val proof : unit -> proof_trace + val find : node -> repr + val add_term : term -> node + val mem_term : term -> bool + val allocate_bitfield : descr:string -> Class.bitfield + val get_bitfield : Class.bitfield -> Class.t -> bool + val set_bitfield : Class.bitfield -> bool -> Class.t -> unit + val on_event : unit -> event Event.t + val set_as_lit : Class.t -> lit -> unit + val find_t : term -> repr + val add_iter : term Iter.t -> unit + val all_classes : repr Iter.t + val assert_lit : lit -> unit + val assert_lits : lit Iter.t -> unit + val explain_eq : Class.t -> Class.t -> Resolved_expl.t + val raise_conflict_from_expl : actions -> Expl.t -> 'a + val n_true : unit -> Class.t + val n_false : unit -> Class.t + val n_bool : bool -> Class.t + val merge : Class.t -> Class.t -> Expl.t -> unit + val merge_t : term -> term -> Expl.t -> unit + val set_model_value : term -> value -> unit + val with_model_mode : (unit -> 'a) -> 'a + val get_model_for_each_class : (repr * Class.t Iter.t * value) Iter.t + val check : actions -> unit + val push_level : unit -> unit + val pop_levels : int -> unit + val get_model : Class.t Iter.t Iter.t + end +*) + +(** Main congruence closure signature. + + The congruence closure handles the theory QF_UF (uninterpreted + function symbols). + It is also responsible for {i theory combination}, and provides + a general framework for equality reasoning that other + theories piggyback on. + + For example, the theory of datatypes relies on the congruence closure + to do most of the work, and "only" adds injectivity/disjointness/acyclicity + lemmas when needed. + + Similarly, a theory of arrays would hook into the congruence closure and + assert (dis)equalities as needed. +*) +module type S = sig + include ARGS_CLASSES_EXPL_EVENT + + type t + (** The congruence closure object. + It contains a fair amount of state and is mutable + and backtrackable. *) (** {3 Accessors} *) val term_store : t -> term_store - val proof : t -> proof + val proof : t -> proof_trace val find : t -> node -> repr (** Current representative *) @@ -274,66 +322,12 @@ module type S = sig val mem_term : t -> term -> bool (** Returns [true] if the term is explicitly present in the congruence closure *) - (** {3 Events} - - Events triggered by the congruence closure, to which - other plugins can subscribe. *) - - type ev_on_pre_merge = t -> actions -> Class.t -> Class.t -> Expl.t -> unit - (** [ev_on_pre_merge cc acts n1 n2 expl] is called right before [n1] - and [n2] are merged with explanation [expl]. *) - - type ev_on_post_merge = t -> actions -> Class.t -> Class.t -> unit - (** [ev_on_post_merge cc acts n1 n2] is called right after [n1] - and [n2] were merged. [find cc n1] and [find cc n2] will return - the same node. *) - - type ev_on_new_term = t -> Class.t -> term -> unit - (** [ev_on_new_term cc n t] is called whenever a new term [t] - is added to the congruence closure. Its node is [n]. *) - - type ev_on_conflict = t -> th:bool -> lit list -> unit - (** [ev_on_conflict acts ~th c] is called when the congruence - closure triggers a conflict by asserting the tautology [c]. - - @param th true if the explanation for this conflict involves - at least one "theory" explanation; i.e. some of the equations - participating in the conflict are purely syntactic theories - like injectivity of constructors. *) - - type ev_on_propagate = t -> lit -> (unit -> lit list * proof_step) -> unit - (** [ev_on_propagate cc lit reason] is called whenever [reason() => lit] - is a propagated lemma. See {!CC_ACTIONS.propagate}. *) - - type ev_on_is_subterm = Class.t -> term -> unit - (** [ev_on_is_subterm n t] is called when [n] is a subterm of - another node for the first time. [t] is the term corresponding to - the node [n]. This can be useful for theory combination. *) - - val create : - ?stat:Stat.t -> - ?on_pre_merge:ev_on_pre_merge list -> - ?on_post_merge:ev_on_post_merge list -> - ?on_new_term:ev_on_new_term list -> - ?on_conflict:ev_on_conflict list -> - ?on_propagate:ev_on_propagate list -> - ?on_is_subterm:ev_on_is_subterm list -> - ?size:[ `Small | `Big ] -> - term_store -> - proof -> - t - (** Create a new congruence closure. - - @param term_store used to be able to create new terms. All terms - interacting with this congruence closure must belong in this term state - as well. *) - - val allocate_bitfield : descr:string -> t -> Class.bitfield + val allocate_bitfield : t -> descr:string -> Class.bitfield (** Allocate a new node field (see {!Class.bitfield}). This field descriptor is henceforth reserved for all nodes in this congruence closure, and can be set using {!set_bitfield} - for each node individually. + for each class_ individually. This can be used to efficiently store some metadata on nodes (e.g. "is there a numeric value in the class" or "is there a constructor term in the class"). @@ -349,24 +343,47 @@ module type S = sig (** Set the bitfield for the node. This will be backtracked. See {!Class.bitfield}. *) - (* TODO: remove? this is managed by the solver anyway? *) - val on_pre_merge : t -> ev_on_pre_merge -> unit - (** Add a function to be called when two classes are merged *) + (** {3 Events} - val on_post_merge : t -> ev_on_post_merge -> unit - (** Add a function to be called when two classes are merged *) + Events triggered by the congruence closure, to which + other plugins can subscribe. *) - val on_new_term : t -> ev_on_new_term -> unit - (** Add a function to be called when a new node is created *) + (** Events emitted by the congruence closure when something changes. *) + val on_pre_merge : t -> (t * actions * Class.t * Class.t * Expl.t) Event.t + (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] + and [n2] are merged with explanation [expl]. *) - val on_conflict : t -> ev_on_conflict -> unit - (** Called when the congruence closure finds a conflict *) + val on_post_merge : t -> (t * actions * Class.t * Class.t) Event.t + (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] + and [n2] were merged. [find cc n1] and [find cc n2] will return + the same Class.t. *) - val on_propagate : t -> ev_on_propagate -> unit - (** Called when the congruence closure propagates a literal *) + val on_new_term : t -> (t * Class.t * term) Event.t + (** [ev_on_new_term n t] is emitted whenever a new term [t] + is added to the congruence closure. Its Class.t is [n]. *) - val on_is_subterm : t -> ev_on_is_subterm -> unit - (** Called on terms that are subterms of function symbols *) + type ev_on_conflict = { cc: t; th: bool; c: lit list } + (** Event emitted when a conflict occurs in the CC. + + [th] is true if the explanation for this conflict involves + at least one "theory" explanation; i.e. some of the equations + participating in the conflict are purely syntactic theories + like injectivity of constructors. *) + + val on_conflict : t -> ev_on_conflict Event.t + (** [ev_on_conflict {th; c}] is emitted when the congruence + closure triggers a conflict by asserting the tautology [c]. *) + + val on_propagate : t -> (t * lit * (unit -> lit list * step_id)) Event.t + (** [ev_on_propagate lit reason] is emitted whenever [reason() => lit] + is a propagated lemma. See {!CC_ACTIONS.propagate}. *) + + val on_is_subterm : t -> (t * Class.t * term) Event.t + (** [ev_on_is_subterm n t] is emitted when [n] is a subterm of + another Class.t for the first time. [t] is the term corresponding to + the Class.t [n]. This can be useful for theory combination. *) + + (** {3 Misc} *) val set_as_lit : t -> Class.t -> lit -> unit (** map the given node to a literal. *) @@ -440,17 +457,14 @@ module type S = sig val get_model : t -> Class.t Iter.t Iter.t (** get all the equivalence classes so they can be merged in the model *) - - (**/**) - - module Debug_ : sig - val pp : t Fmt.printer - (** Print the whole CC *) - end - - (**/**) end +(* TODO + module type DYN_BUILDER = sig + include ARGS_CLASSES_EXPL_EVENT + end +*) + (* TODO: full EGG, also have a function to update the value when the subterms (produced in [of_term]) are updated *) @@ -460,7 +474,7 @@ end The state of a class is the monoidal combination of the state for each term in the class (for example, the set of terms in the class whose head symbol is a datatype constructor). *) -module type MONOID_ARG = sig +module type MONOID_PLUGIN_ARG = sig module CC : S type t @@ -511,38 +525,32 @@ end aggregate some theory-specific state over all terms, with the information of what terms are already known to be equal potentially saving work for the theory. *) -module type PLUGIN = sig - module CC : S - module M : MONOID_ARG with module CC = CC +module type DYN_MONOID_PLUGIN = sig + module M : MONOID_PLUGIN_ARG + include Sidekick_sigs.DYN_BACKTRACKABLE - val push_level : unit -> unit - (** Push backtracking point *) + val pp : unit Fmt.printer - val pop_levels : int -> unit - (** Pop [n] backtracking points *) + val mem : M.CC.Class.t -> bool + (** Does the CC Class.t have a monoid value? *) - val n_levels : unit -> int + val get : M.CC.Class.t -> M.t option + (** Get monoid value for this CC Class.t, if any *) - val mem : CC.Class.t -> bool - (** Does the CC node have a monoid value? *) - - val get : CC.Class.t -> M.t option - (** Get monoid value for this CC node, if any *) - - val iter_all : (CC.repr * M.t) Iter.t + val iter_all : (M.CC.repr * M.t) Iter.t end (** Builder for a plugin. The builder takes a congruence closure, and instantiate the plugin on it. *) -module type PLUGIN_BUILDER = sig - module M : MONOID_ARG +module type MONOID_PLUGIN_BUILDER = sig + module M : MONOID_PLUGIN_ARG - module type PL = PLUGIN with module CC = M.CC and module M = M + module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M - type plugin = (module PL) + type t = (module DYN_PL_FOR_M) - val create_and_setup : ?size:int -> M.CC.t -> plugin + val create_and_setup : ?size:int -> M.CC.t -> t (** Create a new monoid state *) end diff --git a/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml b/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml index 5e81fafc..c9b20417 100644 --- a/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml +++ b/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml @@ -1,4 +1,5 @@ -(** Signature for SAT-solver proof emission. *) +(** Proof rules for SAT Solver reasoning *) + module type S = sig type rule (** The stored proof (possibly nil, possibly on disk, possibly in memory) *) @@ -16,9 +17,6 @@ module type S = sig (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. The clause must be RUP wrt [hyps]. *) - (* FIXME: goes in proof trace itself? not exactly a rule… - val sat_unsat_core : lit Iter.t -> rule - (** Produce a proof of the empty clause given this subset of the assumptions. - FIXME: probably needs the list of proof_step that disprove the lits? *) - *) + val sat_unsat_core : lit Iter.t -> rule + (** TODO: is this relevant here? *) end diff --git a/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml b/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml index 012957c3..83ee8d3f 100644 --- a/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml +++ b/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml @@ -3,16 +3,21 @@ open Sidekick_util -module type S = sig +module type ARG = sig type rule type step_id (** Identifier for a tracing step (like a unique ID for a clause previously added/proved) *) - module Step_vec : Vec_sig.BASE with type t = step_id + module Step_vec : Vec_sig.BASE with type elt = step_id (** A vector indexed by steps. *) +end +module type S = sig + module A : ARG + + type t (** The proof trace itself. A proof trace is a log of all deductive steps taken by the solver, @@ -21,30 +26,17 @@ module type S = sig Each step in the proof trace should be a {b valid lemma} (of its theory) or a {b valid consequence} of previous steps. *) - module type PROOF_TRACE = sig - val enabled : unit -> bool - (** Is proof tracing enabled? *) - val add_step : rule -> step_id - (** Create a new step in the trace. *) + val enabled : t -> bool + (** Is proof tracing enabled? *) - val add_unsat : step_id -> unit - (** Signal "unsat" result at the given proof *) + val add_step : t -> A.rule -> A.step_id + (** Create a new step in the trace. *) - val delete : step_id -> unit - (** Forget a step that won't be used in the rest of the trace. - Only useful for performance/memory considerations. *) - end + val add_unsat : t -> A.step_id -> unit + (** Signal "unsat" result at the given proof *) - type t = (module PROOF_TRACE) -end - -module Utils_ (Trace : S) = struct - let[@inline] enabled ((module Tr) : Trace.t) : bool = Tr.enabled () - - let[@inline] add_step ((module Tr) : Trace.t) rule : Trace.step_id = - Tr.add_step rule - - let[@inline] add_unsat ((module Tr) : Trace.t) s : unit = Tr.add_unsat s - let[@inline] delete ((module Tr) : Trace.t) s : unit = Tr.delete s + val delete : t -> A.step_id -> unit + (** Forget a step that won't be used in the rest of the trace. + Only useful for performance/memory considerations. *) end diff --git a/src/sigs/smt/Sidekick_sigs_smt.ml b/src/sigs/smt/Sidekick_sigs_smt.ml new file mode 100644 index 00000000..be68256d --- /dev/null +++ b/src/sigs/smt/Sidekick_sigs_smt.ml @@ -0,0 +1,597 @@ +(** Signature for the main SMT solver types. + + Theories and concrete solvers rely on an environment that defines + several important types: + + - sorts + - terms (to represent logic expressions and formulas) + - a congruence closure instance + - a bridge to some SAT solver + + In this module we collect signatures defined elsewhere and define + the module types for the main SMT solver. +*) + +module type TERM = Sidekick_sigs_term.S +module type LIT = Sidekick_sigs_lit.S +module type PROOF_TRACE = Sidekick_sigs_proof_trace.S + +module type SAT_PROOF_RULES = Sidekick_sigs_proof_sat.S +(** Signature for SAT-solver proof emission. *) + +module type PROOF_CORE = Sidekick_sigs_proof_core.S +(** Proofs of unsatisfiability. *) + +(** Registry to extract values *) +module type REGISTRY = sig + type t + type 'a key + + val create_key : unit -> 'a key + (** Call this statically, typically at program initialization, for + each distinct key. *) + + val create : unit -> t + val get : t -> 'a key -> 'a option + val set : t -> 'a key -> 'a -> unit +end + +(** A view of the solver from a theory's point of view. + + Theories should interact with the solver via this module, to assert + new lemmas, propagate literals, access the congruence closure, etc. *) +module type SOLVER_INTERNAL = sig + module T : TERM + module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE + + type ty = T.Ty.t + type term = T.Term.t + type value = T.Term.t + type lit = Lit.t + type term_store = T.Term.store + type ty_store = T.Ty.store + type clause_pool + type proof_trace = Proof_trace.t + type step_id = Proof_trace.A.step_id + + type t + (** {3 Main type for a solver} *) + + type solver = t + + val tst : t -> term_store + val ty_st : t -> ty_store + val stats : t -> Stat.t + + val proof : t -> proof_trace + (** Access the proof object *) + + (** {3 Registry} *) + + module Registry : REGISTRY + + val registry : t -> Registry.t + (** A solver contains a registry so that theories can share data *) + + (** {3 Exported Proof rules} *) + + module P_core_rules : + Sidekick_sigs_proof_core.S + with type rule = Proof_trace.A.rule + and type step_id = Proof_trace.A.step_id + and type term = term + and type lit = lit + + (** {3 Actions for the theories} *) + + type theory_actions + (** Handle that the theories can use to perform actions. *) + + (** {3 Congruence Closure} *) + + (** Congruence closure instance *) + module CC : + Sidekick_sigs_cc.S + with module T = T + and module Lit = Lit + and module Proof_trace = Proof_trace + + val cc : t -> CC.t + (** Congruence closure for this solver *) + + (** {3 Simplifiers} *) + + (* TODO: move into its own library *) + + (** Simplify terms *) + module Simplify : sig + type t + + val tst : t -> term_store + val ty_st : t -> ty_store + + val clear : t -> unit + (** Reset internal cache, etc. *) + + val proof : t -> proof_trace + (** Access proof *) + + type hook = t -> term -> (term * step_id Iter.t) option + (** Given a term, try to simplify it. Return [None] if it didn't change. + + A simple example could be a hook that takes a term [t], + and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, + returns [Some (const (x+y))], and [None] otherwise. + + The simplifier will take care of simplifying the resulting term further, + caching (so that work is not duplicated in subterms), etc. + *) + + val normalize : t -> term -> (term * step_id) option + (** Normalize a term using all the hooks. This performs + a fixpoint, i.e. it only stops when no hook applies anywhere inside + the term. *) + + val normalize_t : t -> term -> term * step_id option + (** Normalize a term using all the hooks, along with a proof that the + simplification is correct. + returns [t, ø] if no simplification occurred. *) + end + + type simplify_hook = Simplify.hook + + val add_simplifier : t -> Simplify.hook -> unit + (** Add a simplifier hook for preprocessing. *) + + val simplify_t : t -> term -> (term * step_id) option + (** Simplify input term, returns [Some u] if some + simplification occurred. *) + + val simp_t : t -> term -> term * step_id option + (** [simp_t si t] returns [u] even if no simplification occurred + (in which case [t == u] syntactically). + It emits [|- t=u]. + (see {!simplifier}) *) + + (** {3 Preprocessors} + These preprocessors turn mixed, raw literals (possibly simplified) into + literals suitable for reasoning. + Typically some clauses are also added to the solver. *) + + (* TODO: move into its own sig + library *) + module type PREPROCESS_ACTS = sig + val proof : proof_trace + + val mk_lit : ?sign:bool -> term -> lit + (** [mk_lit t] creates a new literal for a boolean term [t]. *) + + val add_clause : lit list -> step_id -> unit + (** pushes a new clause into the SAT solver. *) + + val add_lit : ?default_pol:bool -> lit -> unit + (** Ensure the literal will be decided/handled by the SAT solver. *) + end + + type preprocess_actions = (module PREPROCESS_ACTS) + (** Actions available to the preprocessor *) + + type preprocess_hook = t -> preprocess_actions -> term -> unit + (** Given a term, preprocess it. + + The idea is to add literals and clauses to help define the meaning of + the term, if needed. For example for boolean formulas, clauses + for their Tseitin encoding can be added, with the formula acting + as its own proxy symbol. + + @param preprocess_actions actions available during preprocessing. + *) + + val on_preprocess : t -> preprocess_hook -> unit + (** Add a hook that will be called when terms are preprocessed *) + + (** {3 hooks for the theory} *) + + val raise_conflict : t -> theory_actions -> lit list -> step_id -> 'a + (** Give a conflict clause to the solver *) + + val push_decision : t -> theory_actions -> lit -> unit + (** Ask the SAT solver to decide the given literal in an extension of the + current trail. This is useful for theory combination. + If the SAT solver backtracks, this (potential) decision is removed + and forgotten. *) + + val propagate : + t -> theory_actions -> lit -> reason:(unit -> lit list * step_id) -> unit + (** Propagate a boolean using a unit clause. + [expl => lit] must be a theory lemma, that is, a T-tautology *) + + val propagate_l : t -> theory_actions -> lit -> lit list -> step_id -> unit + (** Propagate a boolean using a unit clause. + [expl => lit] must be a theory lemma, that is, a T-tautology *) + + val add_clause_temp : t -> theory_actions -> lit list -> step_id -> unit + (** Add local clause to the SAT solver. This clause will be + removed when the solver backtracks. *) + + val add_clause_permanent : t -> theory_actions -> lit list -> step_id -> unit + (** Add toplevel clause to the SAT solver. This clause will + not be backtracked. *) + + val mk_lit : t -> theory_actions -> ?sign:bool -> term -> lit + (** Create a literal. This automatically preprocesses the term. *) + + val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit + (** Add the given literal to the SAT solver, so it gets assigned + a boolean value. + @param default_pol default polarity for the corresponding atom *) + + val add_lit_t : t -> theory_actions -> ?sign:bool -> term -> unit + (** Add the given (signed) bool term to the SAT solver, so it gets assigned + a boolean value *) + + val cc_raise_conflict_expl : t -> theory_actions -> CC.Expl.t -> 'a + (** Raise a conflict with the given congruence closure explanation. + it must be a theory tautology that [expl ==> absurd]. + To be used in theories. *) + + val cc_find : t -> CC.Class.t -> CC.Class.t + (** Find representative of the node *) + + val cc_are_equal : t -> term -> term -> bool + (** Are these two terms equal in the congruence closure? *) + + val cc_merge : + t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit + (** Merge these two nodes in the congruence closure, given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + + val cc_merge_t : t -> theory_actions -> term -> term -> CC.Expl.t -> unit + (** Merge these two terms in the congruence closure, given this explanation. + See {!cc_merge} *) + + val cc_add_term : t -> term -> CC.Class.t + (** Add/retrieve congruence closure node for this term. + To be used in theories *) + + val cc_mem_term : t -> term -> bool + (** Return [true] if the term is explicitly in the congruence closure. + To be used in theories *) + + val on_cc_pre_merge : + t -> + (CC.t * CC.actions * CC.Class.t * CC.Class.t * CC.Expl.t -> unit) -> + unit + (** Callback for when two classes containing data for this key are merged (called before) *) + + val on_cc_post_merge : + t -> (CC.t * CC.actions * CC.Class.t * CC.Class.t -> unit) -> unit + (** Callback for when two classes containing data for this key are merged (called after)*) + + val on_cc_new_term : t -> (CC.t * CC.Class.t * term -> unit) -> unit + (** Callback to add data on terms when they are added to the congruence + closure *) + + val on_cc_is_subterm : t -> (CC.t * CC.Class.t * term -> unit) -> unit + (** Callback for when a term is a subterm of another term in the + congruence closure *) + + val on_cc_conflict : t -> (CC.ev_on_conflict -> unit) -> unit + (** Callback called on every CC conflict *) + + val on_cc_propagate : + t -> (CC.t * lit * (unit -> lit list * step_id) -> unit) -> unit + (** Callback called on every CC propagation *) + + val on_partial_check : + t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit + (** Register callbacked to be called with the slice of literals + newly added on the trail. + + This is called very often and should be efficient. It doesn't have + to be complete, only correct. It's given only the slice of + the trail consisting in new literals. *) + + val on_final_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit + (** Register callback to be called during the final check. + + Must be complete (i.e. must raise a conflict if the set of literals is + not satisfiable) and can be expensive. The function + is given the whole trail. + *) + + val on_th_combination : + t -> (t -> theory_actions -> (term * value) Iter.t) -> unit + (** Add a hook called during theory combination. + The hook must return an iterator of pairs [(t, v)] + which mean that term [t] has value [v] in the model. + + Terms with the same value (according to {!Term.equal}) will be + merged in the CC; if two terms with different values are merged, + we get a semantic conflict and must pick another model. *) + + val declare_pb_is_incomplete : t -> unit + (** Declare that, in some theory, the problem is outside the logic fragment + that is decidable (e.g. if we meet proper NIA formulas). + The solver will not reply "SAT" from now on. *) + + (** {3 Model production} *) + + type model_ask_hook = + recurse:(t -> CC.Class.t -> term) -> t -> CC.Class.t -> term option + (** A model-production hook to query values from a theory. + + It takes the solver, a class, and returns + a term for this class. For example, an arithmetic theory + might detect that a class contains a numeric constant, and return + this constant as a model value. + + If no hook assigns a value to a class, a fake value is created for it. + *) + + type model_completion_hook = t -> add:(term -> term -> unit) -> unit + (** A model production hook, for the theory to add values. + The hook is given a [add] function to add bindings to the model. *) + + val on_model : + ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit + (** Add model production/completion hooks. *) +end + +(** User facing view of the solver. + + This is the solver a user of sidekick can see, after instantiating + everything. The user can add some theories, clauses, etc. and asks + the solver to check satisfiability. + + Theory implementors will mostly interact with {!SOLVER_INTERNAL}. *) +module type SOLVER = sig + module T : TERM + module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE + + (** Internal solver, available to theories. *) + module Solver_internal : + SOLVER_INTERNAL + with module T = T + and module Lit = Lit + and module Proof_trace = Proof_trace + + type t + (** The solver's state. *) + + type solver = t + type term = T.Term.t + type ty = T.Ty.t + type lit = Lit.t + type proof_trace = Proof_trace.t + type step_id = Proof_trace.A.step_id + + (** {3 Value registry} *) + + module Registry : REGISTRY + + val registry : t -> Registry.t + (** A solver contains a registry so that theories can share data *) + + (** {3 A theory} + + Theories are abstracted over the concrete implementation of the solver, + so they can work with any implementation. + + Typically a theory should be a functor taking an argument containing + a [SOLVER_INTERNAL] or even a full [SOLVER], + and some additional views on terms, literals, etc. + that are specific to the theory (e.g. to map terms to linear + expressions). + The theory can then be instantiated on any kind of solver for any + term representation that also satisfies the additional theory-specific + requirements. Instantiated theories (ie values of type {!SOLVER.theory}) + can be added to the solver. + *) + module type THEORY = sig + type t + (** The theory's state *) + + val name : string + (** Name of the theory (ideally, unique and short) *) + + val create_and_setup : Solver_internal.t -> t + (** Instantiate the theory's state for the given (internal) solver, + register callbacks, create keys, etc. + + Called once for every solver this theory is added to. *) + + val push_level : t -> unit + (** Push backtracking level. When the corresponding pop is called, + the theory's state should be restored to a state {b equivalent} + to what it was just before [push_level]. + + it does not have to be exactly the same state, it just needs to + be equivalent. *) + + val pop_levels : t -> int -> unit + (** [pop_levels theory n] pops [n] backtracking levels, + restoring [theory] to its state before calling [push_level] n times. *) + end + + type theory = (module THEORY) + (** A theory that can be used for this particular solver. *) + + type 'a theory_p = (module THEORY with type t = 'a) + (** A theory that can be used for this particular solver, with state + of type ['a]. *) + + val mk_theory : + name:string -> + create_and_setup:(Solver_internal.t -> 'th) -> + ?push_level:('th -> unit) -> + ?pop_levels:('th -> int -> unit) -> + unit -> + theory + (** Helper to create a theory. *) + + (** Models + + A model can be produced when the solver is found to be in a + satisfiable state after a call to {!solve}. *) + module Model : sig + 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 + end + + (* TODO *) + module Unknown : sig + type t + + val pp : t CCFormat.printer + + (* + type unknown = + | U_timeout + | U_incomplete + *) + end + + (** {3 Main API} *) + + val stats : t -> Stat.t + val tst : t -> T.Term.store + val ty_st : t -> T.Ty.store + val proof : t -> proof_trace + + val create : + ?stat:Stat.t -> + ?size:[ `Big | `Tiny | `Small ] -> + (* TODO? ?config:Config.t -> *) + proof:proof_trace -> + theories:theory list -> + T.Term.store -> + T.Ty.store -> + unit -> + t + (** Create a new solver. + + It needs a term state and a type state to manipulate terms and types. + All terms and types interacting with this solver will need to come + from these exact states. + + @param store_proof if true, proofs from the SAT solver and theories + are retained and potentially accessible after {!solve} + returns UNSAT. + @param size influences the size of initial allocations. + @param theories theories to load from the start. Other theories + can be added using {!add_theory}. *) + + val add_theory : t -> theory -> unit + (** Add a theory to the solver. This should be called before + any call to {!solve} or to {!add_clause} and the likes (otherwise + the theory will have a partial view of the problem). *) + + val add_theory_p : t -> 'a theory_p -> 'a + (** Add the given theory and obtain its state *) + + val add_theory_l : t -> theory list -> unit + + val mk_lit_t : t -> ?sign:bool -> term -> lit + (** [mk_lit_t _ ~sign t] returns [lit'], + where [lit'] is [preprocess(lit)] and [lit] is + an internal representation of [± t]. + + The proof of [|- lit = lit'] is directly added to the solver's proof. *) + + val add_clause : t -> lit array -> step_id -> unit + (** [add_clause solver cs] adds a boolean clause to the solver. + Subsequent calls to {!solve} will need to satisfy this clause. *) + + val add_clause_l : t -> lit list -> step_id -> unit + (** Add a clause to the solver, given as a list. *) + + val assert_terms : t -> term list -> unit + (** Helper that turns each term into an atom, before adding the result + to the solver as an assertion *) + + val assert_term : t -> term -> unit + (** Helper that turns the term into an atom, before adding the result + to the solver as a unit clause assertion *) + + (** Result of solving for the current set of clauses *) + type res = + | Sat of Model.t (** Satisfiable *) + | Unsat of { + unsat_core: unit -> lit Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_step_id: unit -> step_id option; + (** Proof step for the empty clause *) + } (** Unsatisfiable *) + | Unknown of Unknown.t + (** Unknown, obtained after a timeout, memory limit, etc. *) + + (* TODO: API to push/pop/clear assumptions, in addition to ~assumptions param *) + + val solve : + ?on_exit:(unit -> unit) list -> + ?check:bool -> + ?on_progress:(t -> unit) -> + ?should_stop:(t -> int -> bool) -> + assumptions:lit list -> + t -> + res + (** [solve s] checks the satisfiability of the clauses added so far to [s]. + @param check if true, the model is checked before returning. + @param on_progress called regularly during solving. + @param assumptions a set of atoms held to be true. The unsat core, + if any, will be a subset of [assumptions]. + @param should_stop a callback regularly called with the solver, + and with a number of "steps" done since last call. The exact notion + of step is not defined, but is guaranteed to increase regularly. + The function should return [true] if it judges solving + must stop (returning [Unknown]), [false] if solving can proceed. + @param on_exit functions to be run before this returns *) + + val last_res : t -> res option + (** Last result, if any. Some operations will erase this (e.g. {!assert_term}). *) + + val push_assumption : t -> lit -> unit + (** Pushes an assumption onto the assumption stack. It will remain + there until it's pop'd by {!pop_assumptions}. *) + + val pop_assumptions : t -> int -> unit + (** [pop_assumptions solver n] removes [n] assumptions from the stack. + It removes the assumptions that were the most + recently added via {!push_assumptions}. + Note that {!check_sat_propagations_only} can call this if it meets + a conflict. *) + + type propagation_result = + | PR_sat + | PR_conflict of { backtracked: int } + | PR_unsat of { unsat_core: unit -> lit Iter.t } + + val check_sat_propagations_only : + assumptions:lit list -> t -> propagation_result + (** [check_sat_propagations_only solver] uses assumptions (including + the [assumptions] parameter, and atoms previously added via {!push_assumptions}) + and boolean+theory propagation to quickly assess satisfiability. + It is not complete; calling {!solve} is required to get an accurate + result. + @returns one of: + + - [PR_sat] if the current state seems satisfiable + - [PR_conflict {backtracked=n}] if a conflict was found and resolved, + leading to backtracking [n] levels of assumptions + - [PR_unsat …] if the assumptions were found to be unsatisfiable, with + the given core. + *) + + (* TODO: allow on_progress to return a bool to know whether to stop? *) + + val pp_stats : t CCFormat.printer + (** Print some statistics. What it prints exactly is unspecified. *) +end diff --git a/src/sigs/smt/dune b/src/sigs/smt/dune new file mode 100644 index 00000000..063ba7ce --- /dev/null +++ b/src/sigs/smt/dune @@ -0,0 +1,8 @@ +(library + (name sidekick_sigs_smt) + (public_name sidekick.sigs.smt) + (synopsis "Signatures for the SMT solver") + (flags :standard -open Sidekick_util) + (libraries containers iter sidekick.sigs sidekick.sigs.term + sidekick.sigs.lit sidekick.sigs.proof-trace sidekick.sigs.proof.core + sidekick.sigs.proof.sat sidekick.util sidekick.sigs.cc)) diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml index 15ba0430..8c44e19a 100644 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ b/src/smt-solver/Sidekick_smt_solver.ml @@ -12,18 +12,26 @@ module type ARG = sig open Sidekick_core module T : TERM module Lit : LIT with module T = T + module Proof_trace : PROOF_TRACE - type proof - type proof_step + type step_id = Proof_trace.A.step_id + type rule = Proof_trace.A.rule - module P : - PROOF + module Rule_core : + Sidekick_sigs_proof_core.S with type term = T.Term.t - and type t = proof - and type proof_step = proof_step and type lit = Lit.t + and type step_id = step_id + and type rule = rule - val cc_view : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t + module Rule_sat : + Sidekick_sigs_proof_sat.S + with type lit = Lit.t + and type step_id = step_id + and type rule = rule + + val view_as_cc : + T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) Sidekick_sigs_cc.View.t val mk_eq : T.Term.store -> T.Term.t -> T.Term.t -> T.Term.t (** [mk_eq store t u] builds the term [t=u] *) @@ -33,9 +41,9 @@ module type ARG = sig a quantifier) *) end -module type S = Sidekick_core.SOLVER +module type S = Sidekick_sigs_smt.SOLVER -module Registry : Sidekick_core.REGISTRY = struct +module Registry : Sidekick_sigs_smt.REGISTRY = struct (* registry keys *) module type KEY = sig type elt @@ -78,24 +86,28 @@ end module Make (A : ARG) : S with module T = A.T - and type proof = A.proof - and type proof_step = A.proof_step and module Lit = A.Lit - and module P = A.P = struct + and module Proof_trace = A.Proof_trace = struct module T = A.T - module P = A.P + module Proof_trace = A.Proof_trace + module Lit = A.Lit module Ty = T.Ty module Term = T.Term - module Lit = A.Lit + + open struct + module P = Proof_trace + module Rule_ = A.Rule_core + end type term = Term.t type ty = Ty.t - type proof = A.proof - type proof_step = A.proof_step type lit = Lit.t + type rule = Proof_trace.A.rule + type step_id = Proof_trace.A.step_id + type proof_trace = Proof_trace.t (* actions from the sat solver *) - type sat_acts = (lit, proof, proof_step) Sidekick_sat.acts + type sat_acts = (lit, Proof_trace.t, step_id) Sidekick_sat.acts type th_combination_conflict = { lits: lit list; @@ -109,48 +121,20 @@ module Make (A : ARG) : exception Semantic_conflict of th_combination_conflict (* the full argument to the congruence closure *) - module CC_actions = struct + module CC_arg = struct module T = T - module P = P module Lit = Lit + module Proof_trace = Proof_trace + module Rule_core = A.Rule_core - type nonrec proof = proof - type nonrec proof_step = proof_step - - let cc_view = A.cc_view + let view_as_cc = A.view_as_cc let[@inline] mk_lit_eq ?sign store t u = A.Lit.atom ?sign store (A.mk_eq store t u) - - module Actions = struct - module T = T - module P = P - module Lit = Lit - - type nonrec proof = proof - type nonrec proof_step = proof_step - type t = sat_acts - - let[@inline] proof (a : t) = - let (module A) = a in - A.proof - - let[@inline] raise_conflict (a : t) lits (pr : proof_step) = - let (module A) = a in - A.raise_conflict lits pr - - let[@inline] raise_semantic_conflict (_ : t) lits semantic = - raise (Semantic_conflict { lits; semantic }) - - let[@inline] propagate (a : t) lit ~reason = - let (module A) = a in - let reason = Sidekick_sat.Consequence reason in - A.propagate lit reason - end end - module CC = Sidekick_cc.Make (CC_actions) - module N = CC.N + module CC = Sidekick_cc.Make (CC_arg) + module N = CC.Class module Model = struct type t = Empty | Map of term Term.Tbl.t @@ -180,19 +164,44 @@ module Make (A : ARG) : (* delayed actions. We avoid doing them on the spot because, when triggered by a theory, they might go back to the theory "too early". *) type delayed_action = - | DA_add_clause of { c: lit list; pr: proof_step; keep: bool } + | DA_add_clause of { c: lit list; pr: step_id; keep: bool } | DA_add_lit of { default_pol: bool option; lit: lit } + let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = + let (module A) = a in + + (module struct + module T = T + module Lit = Lit + + type nonrec lit = lit + type nonrec term = term + type nonrec proof_trace = Proof_trace.t + type nonrec step_id = step_id + + let proof_trace () = pr + let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr + + let[@inline] raise_semantic_conflict lits semantic = + raise (Semantic_conflict { lits; semantic }) + + let[@inline] propagate lit ~reason = + let reason = Sidekick_sat.Consequence reason in + A.propagate lit reason + end) + (** Internal solver, given to theories and to Msat *) module Solver_internal = struct module T = T - module P = P + module Proof_trace = Proof_trace + module Proof_rules = A.Rule_sat + module P_core_rules = A.Rule_core module Lit = Lit module CC = CC - module N = CC.N + module N = CC.Class - type nonrec proof = proof - type nonrec proof_step = proof_step + type nonrec proof_trace = Proof_trace.t + type nonrec step_id = step_id type term = Term.t type value = term type ty = Ty.t @@ -217,15 +226,15 @@ module Make (A : ARG) : type t = { tst: term_store; ty_st: ty_store; - proof: proof; + proof: proof_trace; mutable hooks: hook list; - (* store [t --> u by proof_steps] in the cache. + (* store [t --> u by step_ids] in the cache. We use a bag for the proof steps because it gives us structural sharing of subproofs. *) - cache: (Term.t * proof_step Bag.t) Term.Tbl.t; + cache: (Term.t * step_id Bag.t) Term.Tbl.t; } - and hook = t -> term -> (term * proof_step Iter.t) option + and hook = t -> term -> (term * step_id Iter.t) option let create tst ty_st ~proof : t = { tst; ty_st; proof; hooks = []; cache = Term.Tbl.create 32 } @@ -236,7 +245,7 @@ module Make (A : ARG) : let add_hook self f = self.hooks <- f :: self.hooks let clear self = Term.Tbl.clear self.cache - let normalize (self : t) (t : Term.t) : (Term.t * proof_step) option = + let normalize (self : t) (t : Term.t) : (Term.t * step_id) option = (* compute and cache normal form of [t] *) let rec loop t : Term.t * _ Bag.t = match Term.Tbl.find self.cache t with @@ -277,7 +286,8 @@ module Make (A : ARG) : else ( (* proof: [sub_proofs |- t=u] by CC + subproof *) let step = - P.lemma_preprocess t u ~using:(Bag.to_iter pr_u) self.proof + P.add_step self.proof + @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) in Some (u, step) ) @@ -291,9 +301,9 @@ module Make (A : ARG) : type simplify_hook = Simplify.hook module type PREPROCESS_ACTS = sig - val proof : proof + val proof : proof_trace val mk_lit : ?sign:bool -> term -> lit - val add_clause : lit list -> proof_step -> unit + val add_clause : lit list -> step_id -> unit val add_lit : ?default_pol:bool -> lit -> unit end @@ -305,7 +315,7 @@ module Make (A : ARG) : tst: Term.store; (** state for managing terms *) ty_st: Ty.store; cc: CC.t lazy_t; (** congruence closure *) - proof: proof; (** proof logger *) + proof: proof_trace; (** proof logger *) registry: Registry.t; mutable on_progress: unit -> unit; mutable on_partial_check: @@ -331,16 +341,11 @@ module Make (A : ARG) : } and preprocess_hook = t -> preprocess_actions -> term -> unit - - and model_ask_hook = - recurse:(t -> CC.N.t -> term) -> t -> CC.N.t -> term option - + and model_ask_hook = recurse:(t -> N.t -> term) -> t -> N.t -> term option and model_completion_hook = t -> add:(term -> term -> unit) -> unit type solver = t - module Proof = P - let[@inline] cc (t : t) = Lazy.force t.cc let[@inline] tst t = t.tst let[@inline] ty_st t = t.ty_st @@ -382,7 +387,7 @@ module Make (A : ARG) : propagate self acts p ~reason:(fun () -> cs, proof) let add_sat_clause_ self (acts : theory_actions) ~keep lits - (proof : proof_step) : unit = + (proof : step_id) : unit = let (module A) = acts in Stat.incr self.count_axiom; A.add_clause ~keep lits proof @@ -395,7 +400,7 @@ module Make (A : ARG) : let delayed_add_lit (self : t) ?default_pol (lit : Lit.t) : unit = Queue.push (DA_add_lit { default_pol; lit }) self.delayed_actions - let delayed_add_clause (self : t) ~keep (c : Lit.t list) (pr : proof_step) : + let delayed_add_clause (self : t) ~keep (c : Lit.t list) (pr : step_id) : unit = Queue.push (DA_add_clause { c; pr; keep }) self.delayed_actions @@ -445,7 +450,7 @@ module Make (A : ARG) : (* simplify literal, then preprocess the result *) let simplify_and_preproc_lit_ (self : t) (lit : Lit.t) : - Lit.t * proof_step option = + Lit.t * step_id option = let t = Lit.term lit in let sign = Lit.sign lit in let u, pr = @@ -476,8 +481,7 @@ module Make (A : ARG) : module Preprocess_clause (A : ARR) = struct (* preprocess a clause's literals, possibly emitting a proof for the preprocessing. *) - let top (self : t) (c : lit A.t) (pr_c : proof_step) : - lit A.t * proof_step = + let top (self : t) (c : lit A.t) (pr_c : step_id) : lit A.t * step_id = let steps = ref [] in (* simplify a literal, then preprocess it *) @@ -493,8 +497,9 @@ module Make (A : ARG) : pr_c else ( Stat.incr self.count_preprocess_clause; - P.lemma_rw_clause pr_c ~res:(A.to_iter c') - ~using:(Iter.of_list !steps) self.proof + P.add_step self.proof + @@ Rule_.lemma_rw_clause pr_c ~res:(A.to_iter c') + ~using:(Iter.of_list !steps) ) in c', pr_c' @@ -510,9 +515,7 @@ module Make (A : ARG) : module type PERFORM_ACTS = sig type t - val add_clause : - solver -> t -> keep:bool -> lit list -> proof_step -> unit - + val add_clause : solver -> t -> keep:bool -> lit list -> step_id -> unit val add_lit : solver -> t -> ?default_pol:bool -> lit -> unit end @@ -542,11 +545,11 @@ module Make (A : ARG) : add_sat_lit_ self acts ?default_pol lit end) - let[@inline] add_clause_temp self _acts c (proof : proof_step) : unit = + let[@inline] add_clause_temp self _acts c (proof : step_id) : unit = let c, proof = preprocess_clause_ self c proof in delayed_add_clause self ~keep:false c proof - let[@inline] add_clause_permanent self _acts c (proof : proof_step) : unit = + let[@inline] add_clause_permanent self _acts c (proof : step_id) : unit = let c, proof = preprocess_clause_ self c proof in delayed_add_clause self ~keep:true c proof @@ -566,12 +569,12 @@ module Make (A : ARG) : let on_partial_check self f = self.on_partial_check <- f :: self.on_partial_check - let on_cc_new_term self f = CC.on_new_term (cc self) f - let on_cc_pre_merge self f = CC.on_pre_merge (cc self) f - let on_cc_post_merge self f = CC.on_post_merge (cc self) f - let on_cc_conflict self f = CC.on_conflict (cc self) f - let on_cc_propagate self f = CC.on_propagate (cc self) f - let on_cc_is_subterm self f = CC.on_is_subterm (cc self) f + let on_cc_new_term self f = Event.on (CC.on_new_term (cc self)) ~f + let on_cc_pre_merge self f = Event.on (CC.on_pre_merge (cc self)) ~f + let on_cc_post_merge self f = Event.on (CC.on_post_merge (cc self)) ~f + let on_cc_conflict self f = Event.on (CC.on_conflict (cc self)) ~f + let on_cc_propagate self f = Event.on (CC.on_propagate (cc self)) ~f + let on_cc_is_subterm self f = Event.on (CC.on_is_subterm (cc self)) ~f let cc_add_term self t = CC.add_term (cc self) t let cc_mem_term self t = CC.mem_term (cc self) t let cc_find self n = CC.find (cc self) n @@ -584,10 +587,12 @@ module Make (A : ARG) : let cc_merge self _acts n1 n2 e = CC.merge (cc self) n1 n2 e let cc_merge_t self acts t1 t2 e = - cc_merge self acts (cc_add_term self t1) (cc_add_term self t2) e + let cc_acts = mk_cc_acts_ self.proof acts in + cc_merge self cc_acts (cc_add_term self t1) (cc_add_term self t2) e let cc_raise_conflict_expl self acts e = - CC.raise_conflict_from_expl (cc self) acts e + let cc_acts = mk_cc_acts_ self.proof acts in + CC.raise_conflict_from_expl (cc self) cc_acts e (** {2 Interface with the SAT solver} *) @@ -698,6 +703,8 @@ module Make (A : ARG) : let check_th_combination_ (self : t) (acts : theory_actions) : (Model.t, th_combination_conflict) result = let cc = cc self in + let cc_acts = mk_cc_acts_ self.proof acts in + (* entier model mode, disabling most of congruence closure *) CC.with_model_mode cc @@ fun () -> let set_val (t, v) : unit = @@ -715,7 +722,7 @@ module Make (A : ARG) : try List.iter add_th_values self.on_th_combination; - CC.check cc acts; + CC.check cc cc_acts; let m = mk_model_ self in Ok m with Semantic_conflict c -> Error c @@ -734,12 +741,14 @@ module Make (A : ARG) : lits); (* transmit to CC *) let cc = cc self in + let cc_acts = mk_cc_acts_ self.proof acts in + if not final then CC.assert_lits cc lits; (* transmit to theories. *) - CC.check cc acts; + CC.check cc cc_acts; if final then ( List.iter (fun f -> f self acts lits) self.on_final_check; - CC.check cc acts; + CC.check cc cc_acts; (match check_th_combination_ self acts with | Ok m -> self.last_model <- Some m @@ -765,7 +774,7 @@ module Make (A : ARG) : in let c = List.rev_append c1 c2 in - let pr = P.lemma_cc (Iter.of_list c) self.proof in + let pr = P.add_step self.proof @@ Rule_.lemma_cc (Iter.of_list c) in Log.debugf 20 (fun k -> k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" @@ -882,7 +891,7 @@ module Make (A : ARG) : | Unsat of { unsat_core: unit -> lit Iter.t; (** Unsat core (subset of assumptions), or empty *) - unsat_proof_step: unit -> proof_step option; + unsat_step_id: unit -> step_id option; (** Proof step for the empty clause *) } | Unknown of Unknown.t @@ -946,7 +955,7 @@ module Make (A : ARG) : let t_true = Term.bool tst true in Sat_solver.add_clause self.solver [ Lit.atom tst t_true ] - (P.lemma_true t_true self.proof)); + (P.add_step self.proof @@ Rule_.lemma_true t_true)); self let[@inline] solver self = self.solver @@ -960,8 +969,8 @@ module Make (A : ARG) : let reset_last_res_ self = self.last_res <- None (* preprocess clause, return new proof *) - let preprocess_clause_ (self : t) (c : lit array) (pr : proof_step) : - lit array * proof_step = + let preprocess_clause_ (self : t) (c : lit array) (pr : step_id) : + lit array * step_id = Solver_internal.preprocess_clause_iarray_ self.si c pr let mk_lit_t (self : t) ?sign (t : term) : lit = @@ -974,8 +983,8 @@ module Make (A : ARG) : let pp_stats out (self : t) : unit = Stat.pp_all out (Stat.all @@ stats self) (* add [c], without preprocessing its literals *) - let add_clause_nopreproc_ (self : t) (c : lit array) (proof : proof_step) : - unit = + let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit + = Stat.incr self.count_clause; reset_last_res_ self; Log.debugf 50 (fun k -> @@ -997,7 +1006,7 @@ module Make (A : ARG) : Sat_solver.add_lit solver.solver ?default_pol lit end) - let add_clause (self : t) (c : lit array) (proof : proof_step) : unit = + let add_clause (self : t) (c : lit array) (proof : step_id) : unit = let c, proof = preprocess_clause_ self c proof in add_clause_nopreproc_ self c proof; Perform_delayed_.top self.si self; @@ -1008,7 +1017,9 @@ module Make (A : ARG) : let assert_terms self c = let c = CCList.map (fun t -> Lit.atom (tst self) t) c in - let pr_c = P.emit_input_clause (Iter.of_list c) self.proof in + let pr_c = + P.add_step self.proof @@ A.Rule_sat.sat_input_clause (Iter.of_list c) + in add_clause_l self c pr_c let assert_term self t = assert_terms self [ t ] @@ -1064,9 +1075,9 @@ module Make (A : ARG) : Sat m | Sat_solver.Unsat (module UNSAT) -> let unsat_core () = UNSAT.unsat_assumptions () in - let unsat_proof_step () = Some (UNSAT.unsat_proof ()) in + let unsat_step_id () = Some (UNSAT.unsat_proof ()) in do_on_exit (); - Unsat { unsat_core; unsat_proof_step } + Unsat { unsat_core; unsat_step_id } | exception Resource_exhausted -> Unknown Unknown.U_asked_to_stop in self.last_res <- Some res; diff --git a/src/smt-solver/dune b/src/smt-solver/dune index 1b48ad7d..42a88c50 100644 --- a/src/smt-solver/dune +++ b/src/smt-solver/dune @@ -1,6 +1,6 @@ (library (name Sidekick_smt_solver) (public_name sidekick.smt-solver) - (libraries containers iter sidekick.core sidekick.util sidekick.cc + (libraries containers iter sidekick.sigs.smt sidekick.util sidekick.cc sidekick.sat) (flags :standard -warn-error -a+8 -open Sidekick_util)) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index fd3dae29..17f685ed 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -65,7 +65,7 @@ module Check_cc = struct let n_calls = Stat.mk_int (Solver.Solver_internal.stats si) "check-cc.call" in - Solver.Solver_internal.on_cc_conflict si (fun cc ~th c -> + Solver.Solver_internal.on_cc_conflict si (fun { cc; th; c } -> if not th then ( Stat.incr n_calls; check_conflict si cc c @@ -193,7 +193,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) *) let t3 = Sys.time () -. t2 in Format.printf "Sat (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 - | Solver.Unsat { unsat_proof_step; unsat_core = _ } -> + | Solver.Unsat { unsat_step_id; unsat_core = _ } -> if check then () (* FIXME: check trace? @@ -205,13 +205,13 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) (match proof_file with | Some file -> - (match unsat_proof_step () with + (match unsat_step_id () with | None -> () - | Some unsat_step -> + | Some step_id -> let proof = Solver.proof s in let proof_quip = Profile.with_ "proof.to-quip" @@ fun () -> - Proof_quip.of_proof proof ~unsat:unsat_step + Proof_quip.of_proof proof ~unsat:step_id in Profile.with_ "proof.write-file" @@ fun () -> with_file_out file @@ fun oc -> @@ -248,6 +248,8 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model (* TODO: more? *) in + let add_step r = Solver.Proof_trace.add_step (Solver.proof solver) r in + match stmt with | Statement.Stmt_set_logic logic -> if not @@ List.mem logic known_logics then @@ -281,7 +283,7 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model if pp_cnf then Format.printf "(@[assert@ %a@])@." Term.pp t; let lit = Solver.mk_lit_t solver t in Solver.add_clause solver [| lit |] - (Solver.P.emit_input_clause (Iter.singleton lit) (Solver.proof solver)); + (add_step @@ Proof.Rule_sat.sat_input_clause (Iter.singleton lit)); E.return () | Statement.Stmt_assert_clause c_ts -> if pp_cnf then @@ -291,10 +293,9 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model (* proof of assert-input + preprocessing *) let pr = - let module P = Solver.P in - let proof = Solver.proof solver in let tst = Solver.tst solver in - P.emit_input_clause (Iter.of_list c_ts |> Iter.map (Lit.atom tst)) proof + let lits = Iter.of_list c_ts |> Iter.map (Lit.atom tst) in + add_step @@ Proof.Rule_sat.sat_input_clause lits in Solver.add_clause solver (CCArray.of_list c) pr; diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index 544cbc40..1d67b33c 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -8,7 +8,7 @@ module Solver : and type T.Term.store = Term.store and type T.Ty.t = Ty.t and type T.Ty.store = Ty.store - and type proof = Proof.t + and type Proof_trace.t = Proof.t val th_bool : Solver.theory val th_data : Solver.theory diff --git a/src/tef/Sidekick_tef.real.ml b/src/tef/Sidekick_tef.real.ml index 68dc2149..0285da98 100644 --- a/src/tef/Sidekick_tef.real.ml +++ b/src/tef/Sidekick_tef.real.ml @@ -2,7 +2,7 @@ module P = Sidekick_util.Profile let active = lazy - (match Sys.getenv "TEF" with + (match Sys.getenv "TRACE" with | "1" | "true" -> true | _ -> false | exception Not_found -> false) diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 14cd7898..b986cc83 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -3,6 +3,8 @@ This handles formulas containing "and", "or", "=>", "if-then-else", etc. *) +open Sidekick_sigs_smt + (** Boolean-oriented view of terms *) type ('a, 'args) bool_view = | B_bool of bool @@ -18,32 +20,31 @@ type ('a, 'args) bool_view = | B_opaque_bool of 'a (* do not enter *) | B_atom of 'a -module type PROOF = sig - type proof - type proof_step +module type PROOF_RULES = sig + type rule type term type lit - val lemma_bool_tauto : lit Iter.t -> proof -> proof_step + val lemma_bool_tauto : lit Iter.t -> rule (** Boolean tautology lemma (clause) *) - val lemma_bool_c : string -> term list -> proof -> proof_step + val lemma_bool_c : string -> term list -> rule (** Basic boolean logic lemma for a clause [|- c]. [proof_bool_c b name cs] is the rule designated by [name]. *) - val lemma_bool_equiv : term -> term -> proof -> proof_step + val lemma_bool_equiv : term -> term -> rule (** Boolean tautology lemma (equivalence) *) - val lemma_ite_true : ite:term -> proof -> proof_step + val lemma_ite_true : ite:term -> rule (** lemma [a ==> ite a b c = b] *) - val lemma_ite_false : ite:term -> proof -> proof_step + val lemma_ite_false : ite:term -> rule (** lemma [¬a ==> ite a b c = c] *) end (** Argument to the theory *) module type ARG = sig - module S : Sidekick_core.SOLVER + module S : SOLVER type term = S.T.Term.t @@ -53,10 +54,9 @@ module type ARG = sig val mk_bool : S.T.Term.store -> (term, term array) bool_view -> term (** Make a term from the given boolean view. *) - include - PROOF - with type proof := S.P.t - and type proof_step := S.P.proof_step + module P : + PROOF_RULES + with type rule := S.Proof_trace.A.rule and type lit := S.Lit.t and type term := S.T.Term.t @@ -107,6 +107,11 @@ module Make (A : ARG) : S with module A = A = struct module Lit = A.S.Solver_internal.Lit module SI = A.S.Solver_internal + (* utils *) + open struct + module Pr = A.S.Proof_trace + end + type state = { tst: T.store; ty_st: Ty.store; gensym: A.Gensym.t } let create tst ty_st : state = { tst; ty_st; gensym = A.Gensym.create tst } @@ -124,23 +129,24 @@ module Make (A : ARG) : S with module A = A = struct | _ -> false let simplify (self : state) (simp : SI.Simplify.t) (t : T.t) : - (T.t * SI.proof_step Iter.t) option = + (T.t * SI.step_id Iter.t) option = let tst = self.tst in let proof = SI.Simplify.proof simp in let steps = ref [] in let add_step_ s = steps := s :: !steps in + let mk_step_ r = Pr.add_step proof r in let add_step_eq a b ~using ~c0 : unit = - add_step_ - @@ SI.P.lemma_rw_clause c0 (SI.Simplify.proof simp) ~using + add_step_ @@ mk_step_ + @@ SI.P_core_rules.lemma_rw_clause c0 ~using ~res:(Iter.return (Lit.atom tst (A.mk_bool tst (B_eq (a, b))))) in let[@inline] ret u = Some (u, Iter.of_list !steps) in (* proof is [t <=> u] *) let ret_bequiv t1 u = - add_step_ @@ A.lemma_bool_equiv t1 u @@ SI.Simplify.proof simp; + add_step_ @@ mk_step_ @@ A.P.lemma_bool_equiv t1 u; ret u in @@ -179,11 +185,11 @@ module Make (A : ARG) : S with module A = A = struct (match A.view_as_bool a with | B_bool true -> add_step_eq t b ~using:(Iter.of_opt prf_a) - ~c0:(A.lemma_ite_true ~ite:t proof); + ~c0:(mk_step_ @@ A.P.lemma_ite_true ~ite:t); ret b | B_bool false -> add_step_eq t c ~using:(Iter.of_opt prf_a) - ~c0:(A.lemma_ite_false ~ite:t proof); + ~c0:(mk_step_ @@ A.P.lemma_ite_false ~ite:t); ret c | _ -> None) | B_equiv (a, b) when is_true a -> ret_bequiv t b @@ -215,6 +221,7 @@ module Make (A : ARG) : S with module A = A = struct let cnf (self : state) (si : SI.t) (module PA : SI.PREPROCESS_ACTS) (t : T.t) : unit = Log.debugf 50 (fun k -> k "(@[th-bool.cnf@ %a@])" T.pp t); + let[@inline] mk_step_ r = Pr.add_step PA.proof r in (* handle boolean equality *) let equiv_ _si ~is_xor ~t t_a t_b : unit = @@ -234,26 +241,26 @@ module Make (A : ARG) : S with module A = A = struct PA.add_clause [ Lit.neg lit; Lit.neg a; b ] (if is_xor then - A.lemma_bool_c "xor-e+" [ t ] PA.proof + mk_step_ @@ A.P.lemma_bool_c "xor-e+" [ t ] else - A.lemma_bool_c "eq-e" [ t; t_a ] PA.proof); + mk_step_ @@ A.P.lemma_bool_c "eq-e" [ t; t_a ]); PA.add_clause [ Lit.neg lit; Lit.neg b; a ] (if is_xor then - A.lemma_bool_c "xor-e-" [ t ] PA.proof + mk_step_ @@ A.P.lemma_bool_c "xor-e-" [ t ] else - A.lemma_bool_c "eq-e" [ t; t_b ] PA.proof); + mk_step_ @@ A.P.lemma_bool_c "eq-e" [ t; t_b ]); PA.add_clause [ lit; a; b ] (if is_xor then - A.lemma_bool_c "xor-i" [ t; t_a ] PA.proof + mk_step_ @@ A.P.lemma_bool_c "xor-i" [ t; t_a ] else - A.lemma_bool_c "eq-i+" [ t ] PA.proof); + mk_step_ @@ A.P.lemma_bool_c "eq-i+" [ t ]); PA.add_clause [ lit; Lit.neg a; Lit.neg b ] (if is_xor then - A.lemma_bool_c "xor-i" [ t; t_b ] PA.proof + mk_step_ @@ A.P.lemma_bool_c "xor-i" [ t; t_b ] else - A.lemma_bool_c "eq-i-" [ t ] PA.proof) + mk_step_ @@ A.P.lemma_bool_c "eq-i-" [ t ]) in (* make a literal for [t], with a proof of [|- abs(t) = abs(lit)] *) @@ -271,11 +278,11 @@ module Make (A : ARG) : S with module A = A = struct (fun t_u u -> PA.add_clause [ Lit.neg lit; u ] - (A.lemma_bool_c "and-e" [ t; t_u ] PA.proof)) + (mk_step_ @@ A.P.lemma_bool_c "and-e" [ t; t_u ])) t_subs subs; PA.add_clause (lit :: List.map Lit.neg subs) - (A.lemma_bool_c "and-i" [ t ] PA.proof) + (mk_step_ @@ A.P.lemma_bool_c "and-i" [ t ]) | B_or l -> let t_subs = Iter.to_list l in let subs = List.map PA.mk_lit t_subs in @@ -286,9 +293,10 @@ module Make (A : ARG) : S with module A = A = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (A.lemma_bool_c "or-i" [ t; t_u ] PA.proof)) + (mk_step_ @@ A.P.lemma_bool_c "or-i" [ t; t_u ])) t_subs subs; - PA.add_clause (Lit.neg lit :: subs) (A.lemma_bool_c "or-e" [ t ] PA.proof) + PA.add_clause (Lit.neg lit :: subs) + (mk_step_ @@ A.P.lemma_bool_c "or-e" [ t ]) | B_imply (t_args, t_u) -> (* transform into [¬args \/ u] on the fly *) let t_args = Iter.to_list t_args in @@ -304,18 +312,18 @@ module Make (A : ARG) : S with module A = A = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (A.lemma_bool_c "imp-i" [ t; t_u ] PA.proof)) + (mk_step_ @@ A.P.lemma_bool_c "imp-i" [ t; t_u ])) (t_u :: t_args) subs; PA.add_clause (Lit.neg lit :: subs) - (A.lemma_bool_c "imp-e" [ t ] PA.proof) + (mk_step_ @@ A.P.lemma_bool_c "imp-e" [ t ]) | B_ite (a, b, c) -> let lit_a = PA.mk_lit a in PA.add_clause [ Lit.neg lit_a; PA.mk_lit (eq self.tst t b) ] - (A.lemma_ite_true ~ite:t PA.proof); + (mk_step_ @@ A.P.lemma_ite_true ~ite:t); PA.add_clause [ lit_a; PA.mk_lit (eq self.tst t c) ] - (A.lemma_ite_false ~ite:t PA.proof) + (mk_step_ @@ A.P.lemma_ite_false ~ite:t) | B_eq _ | B_neq _ -> () | B_equiv (a, b) -> equiv_ si ~t ~is_xor:false a b | B_xor (a, b) -> equiv_ si ~t ~is_xor:true a b diff --git a/src/th-bool-static/dune b/src/th-bool-static/dune index ae7257a1..0cb1c59f 100644 --- a/src/th-bool-static/dune +++ b/src/th-bool-static/dune @@ -2,4 +2,4 @@ (name sidekick_th_bool_static) (public_name sidekick.th-bool-static) (flags :standard -open Sidekick_util) - (libraries sidekick.core sidekick.util)) + (libraries sidekick.sigs.smt sidekick.util sidekick.cc.plugin)) diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index 1a266f26..2aaa9b26 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -1,14 +1,16 @@ (** {1 Theory for constructors} *) +open Sidekick_sigs_smt + type ('c, 't) cstor_view = T_cstor of 'c * 't array | T_other of 't let name = "th-cstor" module type ARG = sig - module S : Sidekick_core.SOLVER + module S : SOLVER val view_as_cstor : S.T.Term.t -> (S.T.Fun.t, S.T.Term.t) cstor_view - val lemma_cstor : S.proof -> S.Lit.t Iter.t -> unit + val lemma_cstor : S.Lit.t Iter.t -> S.Proof_trace.A.rule end module type S = sig @@ -21,12 +23,12 @@ module Make (A : ARG) : S with module A = A = struct module A = A module SI = A.S.Solver_internal module T = A.S.T.Term - module N = SI.CC.N + module N = SI.CC.Class module Fun = A.S.T.Fun module Expl = SI.CC.Expl module Monoid = struct - module SI = SI + module CC = SI.CC (* associate to each class a unique constructor term in the class (if any) *) type t = { t: T.t; n: N.t; cstor: Fun.t; args: N.t array } @@ -65,16 +67,17 @@ module Make (A : ARG) : S with module A = A = struct Error expl end - module ST = Sidekick_core.Monoid_of_repr (Monoid) + module ST = Sidekick_cc_plugin.Make (Monoid) type t = ST.t - let push_level = ST.push_level - let pop_levels = ST.pop_levels + let push_level ((module P) : t) = P.push_level () + let pop_levels ((module P) : t) n = P.pop_levels n + let n_levels ((module P) : t) = P.n_levels () - let create_and_setup (solver : SI.t) : t = + let create_and_setup (si : SI.t) : t = Log.debug 1 "(setup :th-cstor)"; - let self = ST.create_and_setup ~size:32 solver in + let self = ST.create_and_setup ~size:32 (SI.cc si) in self let theory = A.S.mk_theory ~name ~push_level ~pop_levels ~create_and_setup () diff --git a/src/th-cstor/dune b/src/th-cstor/dune index a76f8ce9..bd39edcf 100644 --- a/src/th-cstor/dune +++ b/src/th-cstor/dune @@ -1,5 +1,5 @@ (library (name Sidekick_th_cstor) (public_name sidekick.th-cstor) - (libraries containers sidekick.core sidekick.util) + (libraries containers sidekick.sigs.smt sidekick.util sidekick.cc.plugin) (flags :standard -open Sidekick_util)) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 672f0aef..736e5fab 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -1,5 +1,6 @@ (** Theory for datatypes. *) +open Sidekick_sigs_smt include Th_intf let name = "th-data" @@ -159,15 +160,19 @@ module Make (A : ARG) : S with module A = A = struct module A = A module SI = A.S.Solver_internal module T = A.S.T.Term - module N = SI.CC.N + module N = SI.CC.Class module Ty = A.S.T.Ty module Expl = SI.CC.Expl module Card = Compute_card (A) + open struct + module Pr = SI.Proof_trace + end + (** Monoid mapping each class to the (unique) constructor it contains, if any *) module Monoid_cstor = struct - module SI = SI + module CC = SI.CC let name = "th-data.cstor" @@ -201,12 +206,13 @@ module Make (A : ARG) : S with module A = A = struct pr in + let proof = SI.CC.proof cc in if A.Cstor.equal c1.c_cstor c2.c_cstor then ( (* same function: injectivity *) let expl_merge i = let t1 = N.term c1.c_n in let t2 = N.term c2.c_n in - mk_expl t1 t2 @@ A.P.lemma_cstor_inj t1 t2 i (SI.CC.proof cc) + mk_expl t1 t2 @@ Pr.add_step proof @@ A.P.lemma_cstor_inj t1 t2 i in assert (CCArray.length c1.c_args = CCArray.length c2.c_args); @@ -217,7 +223,7 @@ module Make (A : ARG) : S with module A = A = struct (* different function: disjointness *) let expl = let t1 = N.term c1.c_n and t2 = N.term c2.c_n in - mk_expl t1 t2 @@ A.P.lemma_cstor_distinct t1 t2 (SI.CC.proof cc) + mk_expl t1 t2 @@ Pr.add_step proof @@ A.P.lemma_cstor_distinct t1 t2 in Error expl @@ -227,7 +233,7 @@ module Make (A : ARG) : S with module A = A = struct (** Monoid mapping each class to the set of is-a/select of which it is the argument *) module Monoid_parents = struct - module SI = SI + module CC = SI.CC let name = "th-data.parents" @@ -291,13 +297,13 @@ module Make (A : ARG) : S with module A = A = struct Ok { parent_is_a; parent_select } end - module ST_cstors = Sidekick_core.Monoid_of_repr (Monoid_cstor) - module ST_parents = Sidekick_core.Monoid_of_repr (Monoid_parents) + module ST_cstors = Sidekick_cc_plugin.Make (Monoid_cstor) + module ST_parents = Sidekick_cc_plugin.Make (Monoid_parents) module N_tbl = Backtrackable_tbl.Make (N) type t = { tst: T.store; - proof: SI.P.t; + proof: SI.Proof_trace.t; cstors: ST_cstors.t; (* repr -> cstor for the class *) parents: ST_parents.t; (* repr -> parents for the class *) cards: Card.t; (* remember finiteness *) @@ -350,11 +356,13 @@ module Make (A : ARG) : S with module A = A = struct with exhaustiveness: [|- is-c(t)] *) let proof = let pr_isa = - A.P.lemma_isa_split t - (Iter.return @@ Act.mk_lit (A.mk_is_a self.tst cstor t)) - self.proof - and pr_eq_sel = A.P.lemma_select_cstor ~cstor_t:u t self.proof in - SI.P.proof_r1 pr_isa pr_eq_sel self.proof + Pr.add_step self.proof + @@ A.P.lemma_isa_split t + (Iter.return @@ Act.mk_lit (A.mk_is_a self.tst cstor t)) + and pr_eq_sel = + Pr.add_step self.proof @@ A.P.lemma_select_cstor ~cstor_t:u t + in + Pr.add_step self.proof @@ SI.P_core_rules.proof_r1 pr_isa pr_eq_sel in T.Tbl.add self.single_cstor_preproc_done t (); @@ -386,7 +394,7 @@ module Make (A : ARG) : S with module A = A = struct N_tbl.add self.to_decide_for_complete_model n () | _ -> () - let on_new_term (self : t) cc (n : N.t) (t : T.t) : unit = + let on_new_term (self : t) ((cc, n, t) : _ * N.t * T.t) : unit = on_new_term_look_at_ty self n t; (* might have to decide [t] *) match A.view_as_data t with @@ -404,7 +412,8 @@ module Make (A : ARG) : S with module A = A = struct %a@])" name T.pp t is_true N.pp n Monoid_cstor.pp cstor); let pr = - A.P.lemma_isa_cstor ~cstor_t:(N.term cstor.c_n) t (SI.CC.proof cc) + Pr.add_step self.proof + @@ A.P.lemma_isa_cstor ~cstor_t:(N.term cstor.c_n) t in let n_bool = SI.CC.n_bool cc is_true in SI.CC.merge cc n n_bool @@ -423,7 +432,8 @@ module Make (A : ARG) : S with module A = A = struct assert (i < CCArray.length cstor.c_args); let u_i = CCArray.get cstor.c_args i in let pr = - A.P.lemma_select_cstor ~cstor_t:(N.term cstor.c_n) t (SI.CC.proof cc) + Pr.add_step self.proof + @@ A.P.lemma_select_cstor ~cstor_t:(N.term cstor.c_n) t in SI.CC.merge cc n u_i Expl.( @@ -439,7 +449,7 @@ module Make (A : ARG) : S with module A = A = struct | Ty_data { cstors } -> cstors | _ -> assert false - let on_pre_merge (self : t) (cc : SI.CC.t) acts n1 n2 expl : unit = + let on_pre_merge (self : t) (cc, acts, n1, n2, expl) : unit = let merge_is_a n1 (c1 : Monoid_cstor.t) n2 (is_a2 : Monoid_parents.is_a) = let is_true = A.Cstor.equal c1.c_cstor is_a2.is_a_cstor in Log.debugf 50 (fun k -> @@ -449,8 +459,8 @@ module Make (A : ARG) : S with module A = A = struct name Monoid_parents.pp_is_a is_a2 is_true N.pp n1 N.pp n2 Monoid_cstor.pp c1); let pr = - A.P.lemma_isa_cstor ~cstor_t:(N.term c1.c_n) (N.term is_a2.is_a_n) - self.proof + Pr.add_step self.proof + @@ A.P.lemma_isa_cstor ~cstor_t:(N.term c1.c_n) (N.term is_a2.is_a_n) in let n_bool = SI.CC.n_bool cc is_true in SI.CC.merge cc is_a2.is_a_n n_bool @@ -474,8 +484,8 @@ module Make (A : ARG) : S with module A = A = struct N.pp n2 sel2.sel_idx Monoid_cstor.pp c1); assert (sel2.sel_idx < CCArray.length c1.c_args); let pr = - A.P.lemma_select_cstor ~cstor_t:(N.term c1.c_n) (N.term sel2.sel_n) - self.proof + Pr.add_step self.proof + @@ A.P.lemma_select_cstor ~cstor_t:(N.term c1.c_n) (N.term sel2.sel_n) in let u_i = CCArray.get c1.c_args sel2.sel_idx in SI.CC.merge cc sel2.sel_n u_i @@ -578,10 +588,10 @@ module Make (A : ARG) : S with module A = A = struct (* conflict: the [path] forms a cycle *) let path = (n, node) :: path in let pr = - A.P.lemma_acyclicity - (Iter.of_list path - |> Iter.map (fun (a, b) -> N.term a, N.term b.repr)) - self.proof + Pr.add_step self.proof + @@ A.P.lemma_acyclicity + (Iter.of_list path + |> Iter.map (fun (a, b) -> N.term a, N.term b.repr)) in let expl = let subs = @@ -601,7 +611,7 @@ module Make (A : ARG) : S with module A = A = struct Log.debugf 5 (fun k -> k "(@[%s.acyclicity.raise_confl@ %a@ @[:path %a@]@])" name Expl.pp expl pp_path path); - SI.CC.raise_conflict_from_expl cc acts expl + SI.cc_raise_conflict_expl solver acts expl | { flag = New; _ } as node_r -> node_r.flag <- Open; let path = (n, node_r) :: path in @@ -631,7 +641,7 @@ module Make (A : ARG) : S with module A = A = struct Log.debugf 50 (fun k -> k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name T.pp u T.pp rhs SI.Lit.pp lit); - let pr = A.P.lemma_isa_sel t self.proof in + let pr = Pr.add_step self.proof @@ A.P.lemma_isa_sel t in SI.cc_merge_t solver acts u rhs (Expl.mk_theory u rhs [ t, N.term (SI.CC.n_true @@ SI.cc solver), [ Expl.mk_lit lit ] ] @@ -656,10 +666,11 @@ module Make (A : ARG) : S with module A = A = struct |> Iter.to_rev_list in SI.add_clause_permanent solver acts c - (A.P.lemma_isa_split t (Iter.of_list c) self.proof); + (Pr.add_step self.proof @@ A.P.lemma_isa_split t (Iter.of_list c)); Iter.diagonal_l c (fun (l1, l2) -> let pr = - A.P.lemma_isa_disj (SI.Lit.neg l1) (SI.Lit.neg l2) self.proof + Pr.add_step self.proof + @@ A.P.lemma_isa_disj (SI.Lit.neg l1) (SI.Lit.neg l2) in SI.add_clause_permanent solver acts [ SI.Lit.neg l1; SI.Lit.neg l2 ] @@ -754,8 +765,8 @@ module Make (A : ARG) : S with module A = A = struct { tst = SI.tst solver; proof = SI.proof solver; - cstors = ST_cstors.create_and_setup ~size:32 solver; - parents = ST_parents.create_and_setup ~size:32 solver; + cstors = ST_cstors.create_and_setup ~size:32 (SI.cc solver); + parents = ST_parents.create_and_setup ~size:32 (SI.cc solver); to_decide = N_tbl.create ~size:16 (); to_decide_for_complete_model = N_tbl.create ~size:16 (); single_cstor_preproc_done = T.Tbl.create 8; diff --git a/src/th-data/dune b/src/th-data/dune index 4ac39554..8f959c7e 100644 --- a/src/th-data/dune +++ b/src/th-data/dune @@ -1,7 +1,7 @@ (library (name Sidekick_th_data) (public_name sidekick.th-data) - (libraries containers sidekick.core sidekick.util) + (libraries containers sidekick.sigs.smt sidekick.util sidekick.cc.plugin) (flags :standard -open Sidekick_util -w -27-32)) ; TODO get warning back diff --git a/src/th-data/th_intf.ml b/src/th-data/th_intf.ml index e0cafea7..aa1360d4 100644 --- a/src/th-data/th_intf.ml +++ b/src/th-data/th_intf.ml @@ -1,3 +1,5 @@ +open Sidekick_sigs_smt + (** Datatype-oriented view of terms. - ['c] is the representation of constructors @@ -16,47 +18,46 @@ type ('c, 'ty) data_ty_view = | Ty_data of { cstors: 'c } | Ty_other -module type PROOF = sig +module type PROOF_RULES = sig type term type lit - type proof_step - type proof + type rule - val lemma_isa_cstor : cstor_t:term -> term -> proof -> proof_step + val lemma_isa_cstor : cstor_t:term -> term -> rule (** [lemma_isa_cstor (d …) (is-c t)] returns the clause [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) - val lemma_select_cstor : cstor_t:term -> term -> proof -> proof_step + val lemma_select_cstor : cstor_t:term -> term -> rule (** [lemma_select_cstor (c t1…tn) (sel-c-i t)] returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) - val lemma_isa_split : term -> lit Iter.t -> proof -> proof_step + val lemma_isa_split : term -> lit Iter.t -> rule (** [lemma_isa_split t lits] is the proof of [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) - val lemma_isa_sel : term -> proof -> proof_step + val lemma_isa_sel : term -> rule (** [lemma_isa_sel (is-c t)] is the proof of [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) - val lemma_isa_disj : lit -> lit -> proof -> proof_step + val lemma_isa_disj : lit -> lit -> rule (** [lemma_isa_disj (is-c t) (is-d t)] is the proof of [¬ (is-c t) \/ ¬ (is-c t)] *) - val lemma_cstor_inj : term -> term -> int -> proof -> proof_step + val lemma_cstor_inj : term -> term -> int -> rule (** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of [c t1…tn = c u1…un |- ti = ui] *) - val lemma_cstor_distinct : term -> term -> proof -> proof_step + val lemma_cstor_distinct : term -> term -> rule (** [lemma_isa_distinct (c …) (d …)] is the proof of the unit clause [|- (c …) ≠ (d …)] *) - val lemma_acyclicity : (term * term) Iter.t -> proof -> proof_step + val lemma_acyclicity : (term * term) Iter.t -> rule (** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] by acyclicity. *) end module type ARG = sig - module S : Sidekick_core.SOLVER + module S : SOLVER (** Constructor symbols. @@ -102,9 +103,8 @@ module type ARG = sig (** Modify the "finite" field (see {!ty_is_finite}) *) module P : - PROOF - with type proof := S.P.t - and type proof_step := S.P.proof_step - and type term := S.T.Term.t - and type lit := S.Lit.t + PROOF_RULES + with type rule = S.Proof_trace.A.rule + and type term = S.T.Term.t + and type lit = S.Lit.t end diff --git a/src/util/Event.ml b/src/util/Event.ml index 4bee61c0..c0805bd2 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -10,5 +10,6 @@ module Emitter = struct let create () : _ t = { h = Vec.make 3 nop_handler_ } end -let on self f = Vec.push self.h f +let on self ~f = Vec.push self.h f let of_emitter x = x +let emit = Emitter.emit diff --git a/src/util/Event.mli b/src/util/Event.mli index 12599ef8..da060f10 100644 --- a/src/util/Event.mli +++ b/src/util/Event.mli @@ -4,9 +4,10 @@ type 'a t module Emitter : sig type 'a t - val emit : 'a t -> 'a -> unit val create : unit -> 'a t + val emit : 'a t -> 'a -> unit end -val on : 'a t -> ('a -> unit) -> unit +val on : 'a t -> f:('a -> unit) -> unit val of_emitter : 'a Emitter.t -> 'a t +val emit : 'a Emitter.t -> 'a -> unit diff --git a/src/util/gen/dune b/src/util/gen/dune new file mode 100644 index 00000000..de5cfcf8 --- /dev/null +++ b/src/util/gen/dune @@ -0,0 +1,2 @@ +;(executable +;(name gen_vec)) diff --git a/src/util/gen/gen_vec.ml.tmp b/src/util/gen/gen_vec.ml.tmp new file mode 100644 index 00000000..62cb390a --- /dev/null +++ b/src/util/gen/gen_vec.ml.tmp @@ -0,0 +1,2 @@ + +let () = From b0cb60ab67ad8e8383b09bd5d4f22e2c61d5c5f0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 18 Jul 2022 23:27:07 -0400 Subject: [PATCH 007/174] gitignore --- .gitignore | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.gitignore b/.gitignore index 406c3dbf..a6a7e982 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,5 @@ snapshots/ perf.* .mypy_cache *.gz +.git-blame-ignore-revs +*.json From 6dca63b0ea20b186fa9b7221accb99bd66cf72b8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 18 Jul 2022 23:27:12 -0400 Subject: [PATCH 008/174] renamings --- src/{ => algos}/lra/dune | 0 src/{ => algos}/lra/sidekick_arith_lra.ml | 0 src/{ => algos}/simplex/binary_op.ml | 0 src/{ => algos}/simplex/dune | 0 src/{ => algos}/simplex/linear_expr.ml | 0 src/{ => algos}/simplex/linear_expr.mli | 0 src/{ => algos}/simplex/linear_expr_intf.ml | 0 src/{ => algos}/simplex/predicate.ml | 0 src/{ => algos}/simplex/sidekick_simplex.ml | 0 src/{ => algos}/simplex/tests/dune | 0 src/{ => algos}/simplex/tests/test_simplex.real.ml | 0 src/{ => base}/proof-trace/Storage.ml | 0 src/{ => base}/proof-trace/Storage.mli | 0 src/{ => base}/proof-trace/dune | 0 src/{ => base}/proof-trace/proof_ser.bare | 0 src/{ => base}/proof-trace/proof_ser.ml | 0 src/{ => base}/proof-trace/sidekick_base_proof_trace.ml | 0 src/{base-solver => base/solver}/dune | 0 src/{base-solver => base/solver}/sidekick_base_solver.ml | 0 src/{mini-cc => cc/mini}/Sidekick_mini_cc.ml | 0 src/{mini-cc => cc/mini}/Sidekick_mini_cc.mli | 0 src/{mini-cc => cc/mini}/dune | 0 src/{mini-cc => cc/mini}/tests/dune | 0 src/{mini-cc => cc/mini}/tests/sidekick_test_minicc.ml | 0 src/{proof-trace-dump => proof-trace/bare/dump}/dune | 0 .../bare/dump}/proof_trace_dump.ml | 0 26 files changed, 0 insertions(+), 0 deletions(-) rename src/{ => algos}/lra/dune (100%) rename src/{ => algos}/lra/sidekick_arith_lra.ml (100%) rename src/{ => algos}/simplex/binary_op.ml (100%) rename src/{ => algos}/simplex/dune (100%) rename src/{ => algos}/simplex/linear_expr.ml (100%) rename src/{ => algos}/simplex/linear_expr.mli (100%) rename src/{ => algos}/simplex/linear_expr_intf.ml (100%) rename src/{ => algos}/simplex/predicate.ml (100%) rename src/{ => algos}/simplex/sidekick_simplex.ml (100%) rename src/{ => algos}/simplex/tests/dune (100%) rename src/{ => algos}/simplex/tests/test_simplex.real.ml (100%) rename src/{ => base}/proof-trace/Storage.ml (100%) rename src/{ => base}/proof-trace/Storage.mli (100%) rename src/{ => base}/proof-trace/dune (100%) rename src/{ => base}/proof-trace/proof_ser.bare (100%) rename src/{ => base}/proof-trace/proof_ser.ml (100%) rename src/{ => base}/proof-trace/sidekick_base_proof_trace.ml (100%) rename src/{base-solver => base/solver}/dune (100%) rename src/{base-solver => base/solver}/sidekick_base_solver.ml (100%) rename src/{mini-cc => cc/mini}/Sidekick_mini_cc.ml (100%) rename src/{mini-cc => cc/mini}/Sidekick_mini_cc.mli (100%) rename src/{mini-cc => cc/mini}/dune (100%) rename src/{mini-cc => cc/mini}/tests/dune (100%) rename src/{mini-cc => cc/mini}/tests/sidekick_test_minicc.ml (100%) rename src/{proof-trace-dump => proof-trace/bare/dump}/dune (100%) rename src/{proof-trace-dump => proof-trace/bare/dump}/proof_trace_dump.ml (100%) diff --git a/src/lra/dune b/src/algos/lra/dune similarity index 100% rename from src/lra/dune rename to src/algos/lra/dune diff --git a/src/lra/sidekick_arith_lra.ml b/src/algos/lra/sidekick_arith_lra.ml similarity index 100% rename from src/lra/sidekick_arith_lra.ml rename to src/algos/lra/sidekick_arith_lra.ml diff --git a/src/simplex/binary_op.ml b/src/algos/simplex/binary_op.ml similarity index 100% rename from src/simplex/binary_op.ml rename to src/algos/simplex/binary_op.ml diff --git a/src/simplex/dune b/src/algos/simplex/dune similarity index 100% rename from src/simplex/dune rename to src/algos/simplex/dune diff --git a/src/simplex/linear_expr.ml b/src/algos/simplex/linear_expr.ml similarity index 100% rename from src/simplex/linear_expr.ml rename to src/algos/simplex/linear_expr.ml diff --git a/src/simplex/linear_expr.mli b/src/algos/simplex/linear_expr.mli similarity index 100% rename from src/simplex/linear_expr.mli rename to src/algos/simplex/linear_expr.mli diff --git a/src/simplex/linear_expr_intf.ml b/src/algos/simplex/linear_expr_intf.ml similarity index 100% rename from src/simplex/linear_expr_intf.ml rename to src/algos/simplex/linear_expr_intf.ml diff --git a/src/simplex/predicate.ml b/src/algos/simplex/predicate.ml similarity index 100% rename from src/simplex/predicate.ml rename to src/algos/simplex/predicate.ml diff --git a/src/simplex/sidekick_simplex.ml b/src/algos/simplex/sidekick_simplex.ml similarity index 100% rename from src/simplex/sidekick_simplex.ml rename to src/algos/simplex/sidekick_simplex.ml diff --git a/src/simplex/tests/dune b/src/algos/simplex/tests/dune similarity index 100% rename from src/simplex/tests/dune rename to src/algos/simplex/tests/dune diff --git a/src/simplex/tests/test_simplex.real.ml b/src/algos/simplex/tests/test_simplex.real.ml similarity index 100% rename from src/simplex/tests/test_simplex.real.ml rename to src/algos/simplex/tests/test_simplex.real.ml diff --git a/src/proof-trace/Storage.ml b/src/base/proof-trace/Storage.ml similarity index 100% rename from src/proof-trace/Storage.ml rename to src/base/proof-trace/Storage.ml diff --git a/src/proof-trace/Storage.mli b/src/base/proof-trace/Storage.mli similarity index 100% rename from src/proof-trace/Storage.mli rename to src/base/proof-trace/Storage.mli diff --git a/src/proof-trace/dune b/src/base/proof-trace/dune similarity index 100% rename from src/proof-trace/dune rename to src/base/proof-trace/dune diff --git a/src/proof-trace/proof_ser.bare b/src/base/proof-trace/proof_ser.bare similarity index 100% rename from src/proof-trace/proof_ser.bare rename to src/base/proof-trace/proof_ser.bare diff --git a/src/proof-trace/proof_ser.ml b/src/base/proof-trace/proof_ser.ml similarity index 100% rename from src/proof-trace/proof_ser.ml rename to src/base/proof-trace/proof_ser.ml diff --git a/src/proof-trace/sidekick_base_proof_trace.ml b/src/base/proof-trace/sidekick_base_proof_trace.ml similarity index 100% rename from src/proof-trace/sidekick_base_proof_trace.ml rename to src/base/proof-trace/sidekick_base_proof_trace.ml diff --git a/src/base-solver/dune b/src/base/solver/dune similarity index 100% rename from src/base-solver/dune rename to src/base/solver/dune diff --git a/src/base-solver/sidekick_base_solver.ml b/src/base/solver/sidekick_base_solver.ml similarity index 100% rename from src/base-solver/sidekick_base_solver.ml rename to src/base/solver/sidekick_base_solver.ml diff --git a/src/mini-cc/Sidekick_mini_cc.ml b/src/cc/mini/Sidekick_mini_cc.ml similarity index 100% rename from src/mini-cc/Sidekick_mini_cc.ml rename to src/cc/mini/Sidekick_mini_cc.ml diff --git a/src/mini-cc/Sidekick_mini_cc.mli b/src/cc/mini/Sidekick_mini_cc.mli similarity index 100% rename from src/mini-cc/Sidekick_mini_cc.mli rename to src/cc/mini/Sidekick_mini_cc.mli diff --git a/src/mini-cc/dune b/src/cc/mini/dune similarity index 100% rename from src/mini-cc/dune rename to src/cc/mini/dune diff --git a/src/mini-cc/tests/dune b/src/cc/mini/tests/dune similarity index 100% rename from src/mini-cc/tests/dune rename to src/cc/mini/tests/dune diff --git a/src/mini-cc/tests/sidekick_test_minicc.ml b/src/cc/mini/tests/sidekick_test_minicc.ml similarity index 100% rename from src/mini-cc/tests/sidekick_test_minicc.ml rename to src/cc/mini/tests/sidekick_test_minicc.ml diff --git a/src/proof-trace-dump/dune b/src/proof-trace/bare/dump/dune similarity index 100% rename from src/proof-trace-dump/dune rename to src/proof-trace/bare/dump/dune diff --git a/src/proof-trace-dump/proof_trace_dump.ml b/src/proof-trace/bare/dump/proof_trace_dump.ml similarity index 100% rename from src/proof-trace-dump/proof_trace_dump.ml rename to src/proof-trace/bare/dump/proof_trace_dump.ml From 729c72a27d74f118195591658e4f12802dceabf4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 18 Jul 2022 23:28:45 -0400 Subject: [PATCH 009/174] sidekick.sh: make dune phase silent --- sidekick.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/sidekick.sh b/sidekick.sh index 15d7fdad..b55bb625 100755 --- a/sidekick.sh +++ b/sidekick.sh @@ -1,3 +1,3 @@ #!/bin/sh -OPTS=--profile=release +OPTS="--profile=release --display=quiet" exec dune exec $OPTS ./src/main/main.exe -- $@ From e1a4ce587fc386f49efde70f07efabcc22712144 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 20 Jul 2022 20:13:16 -0400 Subject: [PATCH 010/174] fix sudoku solver --- examples/sudoku/sudoku_solve.ml | 7 ++-- .../dummy/Sidekick_proof_trace_dummy.ml | 17 +++++++++ src/sat/Proof_dummy.ml | 38 +++++++++++++------ src/sat/dune | 3 +- 4 files changed, 48 insertions(+), 17 deletions(-) diff --git a/examples/sudoku/sudoku_solve.ml b/examples/sudoku/sudoku_solve.ml index 761ebc9f..df87a662 100644 --- a/examples/sudoku/sudoku_solve.ml +++ b/examples/sudoku/sudoku_solve.ml @@ -1,4 +1,4 @@ -(** {1 simple sudoku solver} *) +(** simple sudoku solver *) module Fmt = CCFormat module Vec = Sidekick_util.Vec @@ -179,15 +179,14 @@ end = struct end module Theory = struct + include Sidekick_sat.Proof_dummy.Make (F) + type proof = unit type proof_step = unit module Lit = F type lit = Lit.t - - module Proof = Sidekick_sat.Proof_dummy.Make (Lit) - type t = { grid: Grid.t B_ref.t } let create g : t = { grid = B_ref.create g } diff --git a/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml b/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml index da1d2c0c..15b463ed 100644 --- a/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml +++ b/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml @@ -1,3 +1,7 @@ +(** Dummy proof traces. + + These proof traces will not record information. *) + module type S = Sidekick_sigs_proof_trace.S module type ARG = sig @@ -16,3 +20,16 @@ module Make (A : ARG) : S with type t = unit and module A = A = struct let add_unsat _ _ = () let delete _ _ = () end + +(** Dummy proof trace where everything is [unit]. Use this if you don't care + for proofs at all. *) +module Unit : + S with type t = unit and type A.rule = unit and type A.step_id = unit = +Make (struct + type rule = unit + type step_id = unit + + module Step_vec = Vec_unit + + let dummy_step_id = () +end) diff --git a/src/sat/Proof_dummy.ml b/src/sat/Proof_dummy.ml index 7fe4b9f3..947be4b4 100644 --- a/src/sat/Proof_dummy.ml +++ b/src/sat/Proof_dummy.ml @@ -1,17 +1,31 @@ -(** Dummy proof module for rule=empty *) +(** Dummy proof module using rule=[unit]. + + These proof traces will not record anything. *) module Make (Lit : sig type t -end) : - Solver_intf.PROOF_RULES - with type lit = Lit.t - and type rule = unit - and type step_id = unit = struct - type lit = Lit.t - type rule = unit - type step_id = unit +end) : sig + module Proof_trace : + Sidekick_sigs_proof_trace.S + with type A.rule = unit + and type A.step_id = unit + and type t = unit - let sat_input_clause _ = () - let sat_redundant_clause _ ~hyps:_ = () - let sat_unsat_core _ = () + module Proof_rules : + Solver_intf.PROOF_RULES + with type lit = Lit.t + and type rule = unit + and type step_id = unit +end = struct + module Proof_trace = Sidekick_proof_trace_dummy.Unit + + module Proof_rules = struct + type lit = Lit.t + type rule = unit + type step_id = unit + + let sat_input_clause _ = () + let sat_redundant_clause _ ~hyps:_ = () + let sat_unsat_core _ = () + end end diff --git a/src/sat/dune b/src/sat/dune index 505da013..b912a7b6 100644 --- a/src/sat/dune +++ b/src/sat/dune @@ -1,6 +1,7 @@ (library (name sidekick_sat) (public_name sidekick.sat) - (libraries iter sidekick.util sidekick.core sidekick.sigs.proof-trace) + (libraries iter sidekick.util sidekick.core sidekick.sigs.proof-trace + sidekick.proof-trace.dummy) (synopsis "Pure OCaml SAT solver implementation for sidekick") (flags :standard -open Sidekick_util)) From b10aaf05f229ab6f062f9ff462dd4c4c517fdfa5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 20 Jul 2022 21:40:04 -0400 Subject: [PATCH 011/174] wip: expose bug caused by order of event handlers if plugin data is updated before `Th_data.on_pre_merge` is called, it never has a chance to observe the un-merged data and react accordingly. we need to ensure that all handlers see the same data before any change is made. --- src/th-data/Sidekick_th_data.ml | 1 + src/util/Vec.ml | 5 +++++ src/util/Vec.mli | 1 + 3 files changed, 7 insertions(+) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 736e5fab..d85c96b4 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -779,6 +779,7 @@ module Make (A : ARG) : S with module A = A = struct Log.debugf 1 (fun k -> k "(setup :%s)" name); SI.on_preprocess solver (preprocess self); SI.on_cc_new_term solver (on_new_term self); + (* note: this needs to happen before we modify the plugin data *) SI.on_cc_pre_merge solver (on_pre_merge self); SI.on_final_check solver (on_final_check self); SI.on_model solver ~ask:(on_model_gen self); diff --git a/src/util/Vec.ml b/src/util/Vec.ml index a25099bc..46750264 100644 --- a/src/util/Vec.ml +++ b/src/util/Vec.ml @@ -130,6 +130,11 @@ let iter ~f t = f (Array.unsafe_get t.data i) done +let rev_iter ~f t = + for i = size t - 1 downto 0 do + f (Array.unsafe_get t.data i) + done + let iteri ~f t = for i = 0 to size t - 1 do f i (Array.unsafe_get t.data i) diff --git a/src/util/Vec.mli b/src/util/Vec.mli index e94028a7..b3c71cd5 100644 --- a/src/util/Vec.mli +++ b/src/util/Vec.mli @@ -81,6 +81,7 @@ val sort : 'a t -> ('a -> 'a -> int) -> unit val iter : f:('a -> unit) -> 'a t -> unit (** Iterate on elements *) +val rev_iter : f:('a -> unit) -> 'a t -> unit val to_iter : 'a t -> 'a Iter.t val iteri : f:(int -> 'a -> unit) -> 'a t -> unit From 7a6d94e622ffcb1a96cdf013910df5a1e9f59383 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 21 Jul 2022 23:20:44 -0400 Subject: [PATCH 012/174] event: add a return type --- src/util/Event.ml | 23 ++++++++++++++++++----- src/util/Event.mli | 21 +++++++++++++-------- 2 files changed, 31 insertions(+), 13 deletions(-) diff --git a/src/util/Event.ml b/src/util/Event.ml index c0805bd2..e1561b3b 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -1,15 +1,28 @@ -type 'a handler = 'a -> unit -type 'a t = { h: 'a handler Vec.t } [@@unboxed] +type ('a, 'b) handler = 'a -> 'b +type ('a, 'b) t = { h: ('a, 'b) handler Vec.t } [@@unboxed] -let nop_handler_ = ignore +let nop_handler_ _ = assert false module Emitter = struct - type nonrec 'a t = 'a t + type nonrec ('a, 'b) t = ('a, 'b) t + + let emit (self : (_, unit) t) x = Vec.iter self.h ~f:(fun h -> h x) + + let emit_collect (self : _ t) x : _ list = + let l = ref [] in + Vec.iter self.h ~f:(fun h -> l := h x :: !l); + !l + + let emit_iter self x ~f = + Vec.iter self.h ~f:(fun h -> + let y = h x in + f y) - let emit (self : _ t) x : unit = Vec.iter self.h ~f:(fun h -> h x) let create () : _ t = { h = Vec.make 3 nop_handler_ } end let on self ~f = Vec.push self.h f let of_emitter x = x let emit = Emitter.emit +let emit_collect = Emitter.emit_collect +let emit_iter = Emitter.emit_iter diff --git a/src/util/Event.mli b/src/util/Event.mli index da060f10..c720405a 100644 --- a/src/util/Event.mli +++ b/src/util/Event.mli @@ -1,13 +1,18 @@ -type 'a t -(** An event emitting values of type ['a] *) +type ('a, 'b) t +(** An event emitting values of type ['a], where subscribers + return values of type ['b]. *) module Emitter : sig - type 'a t + type ('a, 'b) t - val create : unit -> 'a t - val emit : 'a t -> 'a -> unit + val create : unit -> ('a, 'b) t + val emit : ('a, unit) t -> 'a -> unit + val emit_collect : ('a, 'b) t -> 'a -> 'b list + val emit_iter : ('a, 'b) t -> 'a -> f:('b -> unit) -> unit end -val on : 'a t -> f:('a -> unit) -> unit -val of_emitter : 'a Emitter.t -> 'a t -val emit : 'a Emitter.t -> 'a -> unit +val on : ('a, 'b) t -> f:('a -> 'b) -> unit +val of_emitter : ('a, 'b) Emitter.t -> ('a, 'b) t +val emit : ('a, unit) Emitter.t -> 'a -> unit +val emit_collect : ('a, 'b) Emitter.t -> 'a -> 'b list +val emit_iter : ('a, 'b) Emitter.t -> 'a -> f:('b -> unit) -> unit From 6694ce856be14f5d6d6ce4aa71af268ad0c58017 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 21 Jul 2022 23:21:01 -0400 Subject: [PATCH 013/174] fix sat for new event --- src/sat/Solver.ml | 8 ++++---- src/sat/Solver_intf.ml | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/sat/Solver.ml b/src/sat/Solver.ml index 08d7d7f0..1d33c63c 100644 --- a/src/sat/Solver.ml +++ b/src/sat/Solver.ml @@ -881,10 +881,10 @@ module Make (Plugin : PLUGIN) = struct mutable var_incr: float; (* increment for variables' activity *) mutable clause_incr: float; (* increment for clauses' activity *) (* FIXME: use event *) - on_conflict: Clause.t Event.Emitter.t; - on_decision: lit Event.Emitter.t; - on_learnt: Clause.t Event.Emitter.t; - on_gc: lit array Event.Emitter.t; + on_conflict: (Clause.t, unit) Event.Emitter.t; + on_decision: (lit, unit) Event.Emitter.t; + on_learnt: (Clause.t, unit) Event.Emitter.t; + on_gc: (lit array, unit) Event.Emitter.t; stat: Stat.t; n_conflicts: int Stat.counter; n_propagations: int Stat.counter; diff --git a/src/sat/Solver_intf.ml b/src/sat/Solver_intf.ml index e38954a6..a0797607 100644 --- a/src/sat/Solver_intf.ml +++ b/src/sat/Solver_intf.ml @@ -308,10 +308,10 @@ module type S = sig val proof : t -> proof_trace (** Access the inner proof *) - val on_conflict : t -> Clause.t Event.t - val on_decision : t -> lit Event.t - val on_learnt : t -> Clause.t Event.t - val on_gc : t -> lit array Event.t + val on_conflict : t -> (Clause.t, unit) Event.t + val on_decision : t -> (lit, unit) Event.t + val on_learnt : t -> (Clause.t, unit) Event.t + val on_gc : t -> (lit array, unit) Event.t (** {2 Types} *) From dc68a60151de8cd124cbf469fce59d05a17bec35 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 21 Jul 2022 23:21:07 -0400 Subject: [PATCH 014/174] feat(cc): remove callbacks, return list of actions --- src/cc/Sidekick_cc.ml | 556 ++++++++++++++++------------ src/cc/plugin/sidekick_cc_plugin.ml | 71 ++-- 2 files changed, 351 insertions(+), 276 deletions(-) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 32792284..121d7ba6 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -11,7 +11,8 @@ module type S = sig @param term_store used to be able to create new terms. All terms interacting with this congruence closure must belong in this term state - as well. *) + as well. + *) (**/**) @@ -25,6 +26,48 @@ end module type ARG = ARG +(* small bitfield *) +module Bits : sig + type t = private int + type field + type bitfield_gen + + val empty : t + val equal : t -> t -> bool + val mk_field : bitfield_gen -> field + val mk_gen : unit -> bitfield_gen + val get : field -> t -> bool + val set : field -> bool -> t -> t + val merge : t -> t -> t +end = struct + type bitfield_gen = int ref + + let max_width = Sys.word_size - 2 + let mk_gen () = ref 0 + + type t = int + type field = int + + let empty : t = 0 + + let mk_field (gen : bitfield_gen) : field = + let n = !gen in + if n > max_width then Error.errorf "maximum number of CC bitfields reached"; + incr gen; + 1 lsl n + + let[@inline] get field x = x land field <> 0 + + let[@inline] set field b x = + if b then + x lor field + else + x land lnot field + + let merge = ( lor ) + let equal : t -> t -> bool = CCEqual.poly +end + module Make (A : ARG) : S with module T = A.T @@ -50,63 +93,14 @@ module Make (A : ARG) : type proof_trace = A.Proof_trace.t type step_id = A.Proof_trace.A.step_id - type actions = - (module DYN_ACTIONS - with type term = T.Term.t - and type lit = Lit.t - and type proof_trace = proof_trace - and type step_id = step_id) - - module Bits : sig - type t = private int - type field - type bitfield_gen - - val empty : t - val equal : t -> t -> bool - val mk_field : bitfield_gen -> field - val mk_gen : unit -> bitfield_gen - val get : field -> t -> bool - val set : field -> bool -> t -> t - val merge : t -> t -> t - end = struct - type bitfield_gen = int ref - - let max_width = Sys.word_size - 2 - let mk_gen () = ref 0 - - type t = int - type field = int - - let empty : t = 0 - - let mk_field (gen : bitfield_gen) : field = - let n = !gen in - if n > max_width then - Error.errorf "maximum number of CC bitfields reached"; - incr gen; - 1 lsl n - - let[@inline] get field x = x land field <> 0 - - let[@inline] set field b x = - if b then - x lor field - else - x land lnot field - - let merge = ( lor ) - let equal : t -> t -> bool = CCEqual.poly - end - - type node = { + type e_node = { n_term: term; mutable n_sig0: signature option; (* initial signature *) mutable n_bits: Bits.t; (* bitfield for various properties *) - mutable n_parents: node Bag.t; (* parent terms of this node *) - mutable n_root: node; + mutable n_parents: e_node Bag.t; (* parent terms of this node *) + mutable n_root: e_node; (* representative of congruence class (itself if a representative) *) - mutable n_next: node; (* pointer to next element of congruence class *) + mutable n_next: e_node; (* pointer to next element of congruence class *) mutable n_size: int; (* size of the class *) mutable n_as_lit: lit option; (* TODO: put into payload? and only in root? *) @@ -117,27 +111,27 @@ module Make (A : ARG) : An equivalence class is represented by its "root" element, the representative. *) - and signature = (fun_, node, node list) View.t + and signature = (fun_, e_node, e_node list) View.t and explanation_forest_link = | FL_none - | FL_some of { next: node; expl: explanation } + | FL_some of { next: e_node; expl: explanation } (* atomic explanation in the congruence closure *) and explanation = | E_trivial (* by pure reduction, tautologically equal *) | E_lit of lit (* because of this literal *) - | E_merge of node * node + | E_merge of e_node * e_node | E_merge_t of term * term - | E_congruence of node * node (* caused by normal congruence *) + | E_congruence of e_node * e_node (* caused by normal congruence *) | E_and of explanation * explanation | E_theory of term * term * (term * term * explanation list) list * step_id - | E_same_val of node * node + | E_same_val of e_node * e_node - type repr = node + type repr = e_node - module Class = struct - type t = node + module E_node = struct + type t = e_node let[@inline] equal (n1 : t) n2 = n1 == n2 let[@inline] hash n = Term.hash n.n_term @@ -162,10 +156,10 @@ module Make (A : ARG) : in n - let[@inline] is_root (n : node) : bool = n.n_root == n + let[@inline] is_root (n : e_node) : bool = n.n_root == n (* traverse the equivalence class of [n] *) - let iter_class_ (n : node) : node Iter.t = + let iter_class_ (n : e_node) : e_node Iter.t = fun yield -> let rec aux u = yield u; @@ -177,7 +171,7 @@ module Make (A : ARG) : assert (is_root n); iter_class_ n - let[@inline] iter_parents (n : node) : node Iter.t = + let[@inline] iter_parents (n : e_node) : e_node Iter.t = assert (is_root n); Bag.to_iter n.n_parents @@ -188,13 +182,13 @@ module Make (A : ARG) : end (* non-recursive, inlinable function for [find] *) - let[@inline] find_ (n : node) : repr = + let[@inline] find_ (n : e_node) : repr = let n2 = n.n_root in - assert (Class.is_root n2); + assert (E_node.is_root n2); n2 - let[@inline] same_class (n1 : node) (n2 : node) : bool = - Class.equal (find_ n1) (find_ n2) + let[@inline] same_class (n1 : e_node) (n2 : e_node) : bool = + E_node.equal (find_ n1) (find_ n2) let[@inline] find _ n = find_ n @@ -206,9 +200,9 @@ module Make (A : ARG) : | E_trivial -> Fmt.string out "reduction" | E_lit lit -> Lit.pp out lit | E_congruence (n1, n2) -> - Fmt.fprintf out "(@[congruence@ %a@ %a@])" Class.pp n1 Class.pp n2 + Fmt.fprintf out "(@[congruence@ %a@ %a@])" E_node.pp n1 E_node.pp n2 | E_merge (a, b) -> - Fmt.fprintf out "(@[merge@ %a@ %a@])" Class.pp a Class.pp b + Fmt.fprintf out "(@[merge@ %a@ %a@])" E_node.pp a E_node.pp b | E_merge_t (a, b) -> Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp a Term.pp b @@ -219,13 +213,13 @@ module Make (A : ARG) : es | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b | E_same_val (n1, n2) -> - Fmt.fprintf out "(@[same-value@ %a@ %a@])" Class.pp n1 Class.pp n2 + Fmt.fprintf out "(@[same-value@ %a@ %a@])" E_node.pp n1 E_node.pp n2 let mk_trivial : t = E_trivial let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) let[@inline] mk_merge a b : t = - if Class.equal a b then + if E_node.equal a b then mk_trivial else E_merge (a, b) @@ -240,7 +234,7 @@ module Make (A : ARG) : let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) let[@inline] mk_same_value t u = - if Class.equal t u then + if E_node.equal t u then mk_trivial else E_same_val (t, u) @@ -259,7 +253,7 @@ module Make (A : ARG) : module Resolved_expl = struct type t = { lits: lit list; - same_value: (Class.t * Class.t) list; + same_value: (E_node.t * E_node.t) list; pr: proof_trace -> step_id; } @@ -276,11 +270,26 @@ module Make (A : ARG) : let { lits; same_value; pr = _ } = self in Fmt.fprintf out "(@[resolved-expl@ (@[%a@])@ :same-val (@[%a@])@])" (Util.pp_list Lit.pp) lits - (Util.pp_list @@ Fmt.Dump.pair Class.pp Class.pp) + (Util.pp_list @@ Fmt.Dump.pair E_node.pp E_node.pp) same_value ) end + type propagation_reason = unit -> lit list * step_id + + type action = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of { lit: lit; reason: propagation_reason } + + type conflict = + | Conflict of lit list * step_id + (** [raise_conflict (c,pr)] declares that [c] is a tautology of + the theory of congruence. + @param pr the proof of [c] being a tautology *) + | Conflict_expl of Expl.t + + type actions_or_confl = (action list, conflict) result + (** A signature is a shallow term shape where immediate subterms are representative *) module Signature = struct @@ -291,14 +300,14 @@ module Make (A : ARG) : | Bool b1, Bool b2 -> b1 = b2 | App_fun (f1, []), App_fun (f2, []) -> Fun.equal f1 f2 | App_fun (f1, l1), App_fun (f2, l2) -> - Fun.equal f1 f2 && CCList.equal Class.equal l1 l2 + Fun.equal f1 f2 && CCList.equal E_node.equal l1 l2 | App_ho (f1, a1), App_ho (f2, a2) -> - Class.equal f1 f2 && Class.equal a1 a2 - | Not a, Not b -> Class.equal a b + E_node.equal f1 f2 && E_node.equal a1 a2 + | Not a, Not b -> E_node.equal a b | If (a1, b1, c1), If (a2, b2, c2) -> - Class.equal a1 a2 && Class.equal b1 b2 && Class.equal c1 c2 - | Eq (a1, b1), Eq (a2, b2) -> Class.equal a1 a2 && Class.equal b1 b2 - | Opaque u1, Opaque u2 -> Class.equal u1 u2 + E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 + | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 + | Opaque u1, Opaque u2 -> E_node.equal u1 u2 | Bool _, _ | App_fun _, _ | App_ho _, _ @@ -312,25 +321,26 @@ module Make (A : ARG) : let module H = CCHash in match s with | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list Class.hash l) - | App_ho (f, a) -> H.combine3 30 (Class.hash f) (Class.hash a) - | Eq (a, b) -> H.combine3 40 (Class.hash a) (Class.hash b) - | Opaque u -> H.combine2 50 (Class.hash u) + | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list E_node.hash l) + | App_ho (f, a) -> H.combine3 30 (E_node.hash f) (E_node.hash a) + | Eq (a, b) -> H.combine3 40 (E_node.hash a) (E_node.hash b) + | Opaque u -> H.combine2 50 (E_node.hash u) | If (a, b, c) -> - H.combine4 60 (Class.hash a) (Class.hash b) (Class.hash c) - | Not u -> H.combine2 70 (Class.hash u) + H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) + | Not u -> H.combine2 70 (E_node.hash u) let pp out = function | Bool b -> Fmt.bool out b | App_fun (f, []) -> Fun.pp out f | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list Class.pp) l - | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" Class.pp f Class.pp a - | Opaque t -> Class.pp out t - | Not u -> Fmt.fprintf out "(@[not@ %a@])" Class.pp u - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" Class.pp a Class.pp b + Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list E_node.pp) l + | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" E_node.pp f E_node.pp a + | Opaque t -> E_node.pp out t + | Not u -> Fmt.fprintf out "(@[not@ %a@])" E_node.pp u + | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" E_node.pp a E_node.pp b | If (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" Class.pp a Class.pp b Class.pp c + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" E_node.pp a E_node.pp b + E_node.pp c end module Sig_tbl = CCHashtbl.Make (Signature) @@ -338,40 +348,44 @@ module Make (A : ARG) : module T_b_tbl = Backtrackable_tbl.Make (Term) type combine_task = - | CT_merge of node * node * explanation - | CT_set_val of node * value + | CT_merge of e_node * e_node * explanation + | CT_set_val of e_node * value + | CT_act of action type t = { tst: term_store; proof: proof_trace; - tbl: node T_tbl.t; (* internalization [term -> node] *) - signatures_tbl: node Sig_tbl.t; - (* map a signature to the corresponding node in some equivalence class. + tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) + signatures_tbl: e_node Sig_tbl.t; + (* map a signature to the corresponding e_node in some equivalence class. A signature is a [term_cell] in which every immediate subterm that participates in the congruence/evaluation relation is normalized (i.e. is its own representative). The critical property is that all members of an equivalence class that have the same "shape" (including head symbol) have the same signature *) - pending: node Vec.t; + pending: e_node Vec.t; combine: combine_task Vec.t; - t_to_val: (node * value) T_b_tbl.t; + t_to_val: (e_node * value) T_b_tbl.t; (* TODO: remove this, make it a plugin/EGG instead *) (* [repr -> (t,val)] where [repr = t] and [t := val] in the model *) - val_to_t: node T_b_tbl.t; (* [val -> t] where [t := val] in the model *) + val_to_t: e_node T_b_tbl.t; (* [val -> t] where [t := val] in the model *) undo: (unit -> unit) Backtrack_stack.t; bitgen: Bits.bitfield_gen; field_marked_explain: Bits.field; (* used to mark traversed nodes when looking for a common ancestor *) - true_: node lazy_t; - false_: node lazy_t; + true_: e_node lazy_t; + false_: e_node lazy_t; mutable model_mode: bool; - on_pre_merge: (t * actions * Class.t * Class.t * Expl.t) Event.Emitter.t; - on_post_merge: (t * actions * Class.t * Class.t) Event.Emitter.t; - on_new_term: (t * Class.t * term) Event.Emitter.t; - on_conflict: ev_on_conflict Event.Emitter.t; - on_propagate: (t * lit * (unit -> lit list * step_id)) Event.Emitter.t; - on_is_subterm: (t * Class.t * term) Event.Emitter.t; + mutable in_loop: bool; (* currently being modified? *) + res_acts: action Vec.t; (* to return *) + on_pre_merge: + (t * E_node.t * E_node.t * Expl.t, actions_or_confl) Event.Emitter.t; + on_post_merge: (t * E_node.t * E_node.t, action list) Event.Emitter.t; + on_new_term: (t * E_node.t * term, action list) Event.Emitter.t; + on_conflict: (ev_on_conflict, unit) Event.Emitter.t; + on_propagate: (t * lit * propagation_reason, action list) Event.Emitter.t; + on_is_subterm: (t * E_node.t * term, action list) Event.Emitter.t; count_conflict: int Stat.counter; count_props: int Stat.counter; count_merge: int Stat.counter; @@ -405,13 +419,13 @@ module Make (A : ARG) : let[@inline] on_backtrack self f : unit = Backtrack_stack.push_if_nonzero_level self.undo f - let[@inline] get_bitfield _cc field n = Class.get_field field n + let[@inline] get_bitfield _cc field n = E_node.get_field field n let set_bitfield self field b n = - let old = Class.get_field field n in + let old = E_node.get_field field n in if old <> b then ( - on_backtrack self (fun () -> Class.set_field field old n); - Class.set_field field b n + on_backtrack self (fun () -> E_node.set_field field old n); + E_node.set_field field b n ) (* check if [t] is in the congruence closure. @@ -421,25 +435,25 @@ module Make (A : ARG) : module Debug_ = struct (* print full state *) let pp out (self : t) : unit = - let pp_next out n = Fmt.fprintf out "@ :next %a" Class.pp n.n_next in + let pp_next out n = Fmt.fprintf out "@ :next %a" E_node.pp n.n_next in let pp_root out n = - if Class.is_root n then + if E_node.is_root n then Fmt.string out " :is-root" else - Fmt.fprintf out "@ :root %a" Class.pp n.n_root + Fmt.fprintf out "@ :root %a" E_node.pp n.n_root in let pp_expl out n = match n.n_expl with | FL_none -> () | FL_some e -> - Fmt.fprintf out " (@[:forest %a :expl %a@])" Class.pp e.next Expl.pp + Fmt.fprintf out " (@[:forest %a :expl %a@])" E_node.pp e.next Expl.pp e.expl in let pp_n out n = Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp n.n_term pp_root n pp_next n pp_expl n and pp_sig_e out (s, n) = - Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s Class.pp n + Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s E_node.pp n pp_root n in Fmt.fprintf out @@ -461,29 +475,34 @@ module Make (A : ARG) : Sig_tbl.get cc.signatures_tbl s (* add to signature table. Assume it's not present already *) - let add_signature self (s : signature) (n : node) : unit = + let add_signature self (s : signature) (n : e_node) : unit = assert (not @@ Sig_tbl.mem self.signatures_tbl s); Log.debugf 50 (fun k -> - k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s Class.pp n); + k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s E_node.pp n); on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); Sig_tbl.add self.signatures_tbl s n let push_pending self t : unit = - Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" Class.pp t); + Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); Vec.push self.pending t + let push_action self (a : action) : unit = Vec.push self.combine (CT_act a) + + let push_action_l self (l : action list) : unit = + List.iter (push_action self) l + let merge_classes self t u e : unit = if t != u && not (same_class t u) then ( Log.debugf 50 (fun k -> - k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" Class.pp t Class.pp - u Expl.pp e); + k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" E_node.pp t + E_node.pp u Expl.pp e); Vec.push self.combine @@ CT_merge (t, u, e) ) (* re-root the explanation tree of the equivalence class of [n] so that it points to [n]. postcondition: [n.n_expl = None] *) - let[@unroll 2] rec reroot_expl (self : t) (n : node) : unit = + let[@unroll 2] rec reroot_expl (self : t) (n : e_node) : unit = match n.n_expl with | FL_none -> () (* already root *) | FL_some { next = u; expl = e_n_u } -> @@ -492,33 +511,33 @@ module Make (A : ARG) : u.n_expl <- FL_some { next = n; expl = e_n_u }; n.n_expl <- FL_none - let raise_conflict_ (cc : t) ~th (acts : actions) (e : lit list) (p : step_id) - : _ = + exception E_confl of conflict + + let raise_conflict_ (cc : t) ~th (e : lit list) (p : step_id) : _ = Profile.instant "cc.conflict"; (* clear tasks queue *) Vec.clear cc.pending; Vec.clear cc.combine; Event.emit cc.on_conflict { cc; th; c = e }; Stat.incr cc.count_conflict; - let (module A) = acts in - A.raise_conflict e p + raise (E_confl (Conflict (e, p))) let[@inline] all_classes self : repr Iter.t = - T_tbl.values self.tbl |> Iter.filter Class.is_root + T_tbl.values self.tbl |> Iter.filter E_node.is_root (* find the closest common ancestor of [a] and [b] in the proof forest. Precond: - [a] and [b] are in the same class - - no node has the flag [field_marked_explain] on + - no e_node has the flag [field_marked_explain] on Invariants: - if [n] is marked, then all the predecessors of [n] from [a] or [b] are marked too. *) - let find_common_ancestor self (a : node) (b : node) : node = - (* catch up to the other node *) + let find_common_ancestor self (a : e_node) (b : e_node) : e_node = + (* catch up to the other e_node *) let rec find1 a = - if Class.get_field self.field_marked_explain a then + if E_node.get_field self.field_marked_explain a then a else ( match a.n_expl with @@ -527,15 +546,15 @@ module Make (A : ARG) : ) in let rec find2 a b = - if Class.equal a b then + if E_node.equal a b then a - else if Class.get_field self.field_marked_explain a then + else if E_node.get_field self.field_marked_explain a then a - else if Class.get_field self.field_marked_explain b then + else if E_node.get_field self.field_marked_explain b then b else ( - Class.set_field self.field_marked_explain true a; - Class.set_field self.field_marked_explain true b; + E_node.set_field self.field_marked_explain true a; + E_node.set_field self.field_marked_explain true b; match a.n_expl, b.n_expl with | FL_some r1, FL_some r2 -> find2 r1.next r2.next | FL_some r, FL_none -> find1 r.next @@ -547,8 +566,8 @@ module Make (A : ARG) : (* cleanup tags on nodes traversed in [find2] *) let rec cleanup_ n = - if Class.get_field self.field_marked_explain n then ( - Class.set_field self.field_marked_explain false n; + if E_node.get_field self.field_marked_explain n then ( + E_node.set_field self.field_marked_explain false n; match n.n_expl with | FL_none -> () | FL_some { next; _ } -> cleanup_ next @@ -562,7 +581,7 @@ module Make (A : ARG) : module Expl_state = struct type t = { mutable lits: Lit.t list; - mutable same_val: (Class.t * Class.t) list; + mutable same_val: (E_node.t * E_node.t) list; mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * step_id) list; } @@ -671,7 +690,8 @@ module Make (A : ARG) : (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with | a, b -> explain_equal_rec_ self st a b | exception Not_found -> - Error.errorf "expl: cannot find node(s) for %a, %a" Term.pp a Term.pp b) + Error.errorf "expl: cannot find e_node(s) for %a, %a" Term.pp a Term.pp + b) | E_and (a, b) -> explain_decompose_expl self st a; explain_decompose_expl self st b @@ -681,19 +701,19 @@ module Make (A : ARG) : List.iter (explain_decompose_expl self st) es; st - and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : node) (b : node) : - unit = + and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) + : unit = Log.debugf 5 (fun k -> - k "(@[cc.explain_loop.at@ %a@ =?= %a@])" Class.pp a Class.pp b); - assert (Class.equal (find_ a) (find_ b)); + k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); + assert (E_node.equal (find_ a) (find_ b)); let ancestor = find_common_ancestor cc a b in explain_along_path cc st a ancestor; explain_along_path cc st b ancestor (* explain why [a = parent_a], where [a -> ... -> target] in the proof forest *) - and explain_along_path self (st : Expl_state.t) (a : node) (target : node) : - unit = + and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) + : unit = let rec aux n = if n == target then () @@ -709,16 +729,16 @@ module Make (A : ARG) : aux a (* add a term *) - let[@inline] rec add_term_rec_ self t : node = + let[@inline] rec add_term_rec_ self t : e_node = match T_tbl.find self.tbl t with | n -> n | exception Not_found -> add_new_term_ self t (* add [t] when not present already *) - and add_new_term_ self (t : term) : node = + and add_new_term_ self (t : term) : e_node = assert (not @@ mem self t); Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp t); - let n = Class.make t in + let n = E_node.make t in (* register sub-terms, add [t] to their parent list, and return the corresponding initial signature *) let sig0 = compute_sig0 self n in @@ -732,22 +752,24 @@ module Make (A : ARG) : if Option.is_some sig0 then (* [n] might be merged with other equiv classes *) push_pending self n; - if not self.model_mode then Event.emit self.on_new_term (self, n, t); + if not self.model_mode then + Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); n - (* compute the initial signature of the given node *) - and compute_sig0 (self : t) (n : node) : Signature.t option = + (* compute the initial signature of the given e_node *) + and compute_sig0 (self : t) (n : e_node) : Signature.t option = (* add sub-term to [cc], and register [n] to its parents. Note that we return the exact sub-term, to get proper explanations, but we add to the sub-term's root's parent list. *) - let deref_sub (u : term) : node = + let deref_sub (u : term) : e_node = let sub = add_term_rec_ self u in (* add [n] to [sub.root]'s parent list *) (let sub_r = find_ sub in let old_parents = sub_r.n_parents in if Bag.is_empty old_parents && not self.model_mode then (* first time it has parents: tell watchers that this is a subterm *) - Event.emit self.on_is_subterm (self, sub, u); + Event.emit_iter self.on_is_subterm (self, sub, u) + ~f:(push_action_l self); on_backtrack self (fun () -> sub_r.n_parents <- old_parents); sub_r.n_parents <- Bag.cons n sub_r.n_parents); sub @@ -772,21 +794,21 @@ module Make (A : ARG) : return @@ App_ho (f, a) | If (a, b, c) -> return @@ If (deref_sub a, deref_sub b, deref_sub c) - let[@inline] add_term self t : node = add_term_rec_ self t + let[@inline] add_term self t : e_node = add_term_rec_ self t let mem_term = mem - let set_as_lit self (n : node) (lit : lit) : unit = + let set_as_lit self (n : e_node) (lit : lit) : unit = match n.n_as_lit with | Some _ -> () | None -> Log.debugf 15 (fun k -> - k "(@[cc.set-as-lit@ %a@ %a@])" Class.pp n Lit.pp lit); + k "(@[cc.set-as-lit@ %a@ %a@])" E_node.pp n Lit.pp lit); on_backtrack self (fun () -> n.n_as_lit <- None); n.n_as_lit <- Some lit (* is [n] true or false? *) let n_is_bool_value (self : t) n : bool = - Class.equal n (n_true self) || Class.equal n (n_false self) + E_node.equal n (n_true self) || E_node.equal n (n_false self) (* gather a pair [lits, pr], where [lits] is the set of asserted literals needed in the explanation (which is useful for @@ -801,17 +823,17 @@ module Make (A : ARG) : (* main CC algo: add terms from [pending] to the signature table, check for collisions *) - let rec update_tasks (self : t) (acts : actions) : unit = + let rec update_tasks (self : t) : unit = while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do while not @@ Vec.is_empty self.pending do task_pending_ self (Vec.pop_exn self.pending) done; while not @@ Vec.is_empty self.combine do - task_combine_ self acts (Vec.pop_exn self.combine) + task_combine_ self (Vec.pop_exn self.combine) done done - and task_pending_ self (n : node) : unit = + and task_pending_ self (n : e_node) : unit = (* check if some parent collided *) match n.n_sig0 with | None -> () (* no-op *) @@ -820,28 +842,28 @@ module Make (A : ARG) : if same_class a b then ( let expl = Expl.mk_merge a b in Log.debugf 5 (fun k -> - k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" Class.pp n Class.pp a - Class.pp b); + k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a + E_node.pp b); merge_classes self n (n_true self) expl ) | Some (Not u) -> (* [u = bool ==> not u = not bool] *) let r_u = find_ u in - if Class.equal r_u (n_true self) then ( + if E_node.equal r_u (n_true self) then ( let expl = Expl.mk_merge u (n_true self) in merge_classes self n (n_false self) expl - ) else if Class.equal r_u (n_false self) then ( + ) else if E_node.equal r_u (n_false self) then ( let expl = Expl.mk_merge u (n_false self) in merge_classes self n (n_true self) expl ) | Some s0 -> - (* update the signature by using [find] on each sub-node *) + (* update the signature by using [find] on each sub-e_node *) let s = update_sig s0 in (match find_signature self s with | None -> (* add to the signature table [sig(n) --> n] *) add_signature self s n - | Some u when Class.equal n u -> () + | Some u when E_node.equal n u -> () | Some u -> (* [t1] and [t2] must be applications of the same symbol to arguments that are pairwise equal *) @@ -849,11 +871,15 @@ module Make (A : ARG) : let expl = Expl.mk_congruence n u in merge_classes self n u expl) - and task_combine_ self acts = function - | CT_merge (a, b, e_ab) -> task_merge_ self acts a b e_ab - | CT_set_val (n, v) -> task_set_val_ self acts n v + and task_combine_ self = function + | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab + | CT_set_val (n, v) -> task_set_val_ self n v + | CT_act (Act_merge (t, u, e)) -> task_merge_ self t u e + | CT_act (Act_propagate _ as a) -> + (* will return this propagation to the caller *) + Vec.push self.res_acts a - and task_set_val_ self acts n v = + and task_set_val_ self n v = let repr_n = find_ n in (* - if repr(n) has value [v], do nothing - else if repr(n) has value [v'], semantic conflict @@ -872,11 +898,15 @@ module Make (A : ARG) : k "(@[cc.semantic-conflict.set-val@ (@[set-val %a@ := %a@])@ \ (@[existing-val %a@ := %a@])@])" - Class.pp n Term.pp v Class.pp n' Term.pp v'); + E_node.pp n Term.pp v E_node.pp n' Term.pp v'); Stat.incr self.count_semantic_conflict; - let (module A) = acts in - A.raise_semantic_conflict lits tuples + (* FIXME + raise (E_confl(Conflict lits)) + let (module A) = acts in + A.raise_semantic_conflict lits tuples + *) + assert false | Some _ -> () | None -> T_b_tbl.add self.t_to_val repr_n.n_term (n, v)); (* now for the reverse map, look in self.val_to_t for [v]. @@ -890,23 +920,23 @@ module Make (A : ARG) : (* main CC algo: merge equivalence classes in [st.combine]. @raise Exn_unsat if merge fails *) - and task_merge_ self acts a b e_ab : unit = + and task_merge_ self a b e_ab : unit = let ra = find_ a in let rb = find_ b in - if not @@ Class.equal ra rb then ( - assert (Class.is_root ra); - assert (Class.is_root rb); + if not @@ E_node.equal ra rb then ( + assert (E_node.is_root ra); + assert (E_node.is_root rb); Stat.incr self.count_merge; (* check we're not merging [true] and [false] *) if - (Class.equal ra (n_true self) && Class.equal rb (n_false self)) - || (Class.equal rb (n_true self) && Class.equal ra (n_false self)) + (E_node.equal ra (n_true self) && E_node.equal rb (n_false self)) + || (E_node.equal rb (n_true self) && E_node.equal ra (n_false self)) then ( Log.debugf 5 (fun k -> k "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ %a@ :t2 %a@]@ :e_ab %a@])" - Class.pp ra Class.pp a Class.pp rb Class.pp b Expl.pp e_ab); + E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); let th = ref false in (* TODO: C1: P.true_neq_false @@ -923,16 +953,19 @@ module Make (A : ARG) : let lits = expl_st.lits in let same_val = expl_st.same_val - |> List.rev_map (fun (t, u) -> true, Class.term t, Class.term u) + |> List.rev_map (fun (t, u) -> true, E_node.term t, E_node.term u) in assert (same_val <> []); Stat.incr self.count_semantic_conflict; - let (module A) = acts in - A.raise_semantic_conflict lits same_val + (* FIXME + let (module A) = acts in + A.raise_semantic_conflict lits same_val + *) + assert false ) else ( (* regular conflict *) let lits, pr = lits_and_proof_of_expl self expl_st in - raise_conflict_ self ~th:!th acts (List.rev_map Lit.neg lits) pr + raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr ) ); (* We will merge [r_from] into [r_into]. @@ -950,10 +983,10 @@ module Make (A : ARG) : in (* when merging terms with [true] or [false], possibly propagate them to SAT *) let merge_bool r1 t1 r2 t2 = - if Class.equal r1 (n_true self) then - propagate_bools self acts r2 t2 r1 t1 e_ab true - else if Class.equal r1 (n_false self) then - propagate_bools self acts r2 t2 r1 t1 e_ab false + if E_node.equal r1 (n_true self) then + propagate_bools self r2 t2 r1 t1 e_ab true + else if E_node.equal r1 (n_false self) then + propagate_bools self r2 t2 r1 t1 e_ab false in if not self.model_mode then ( @@ -963,7 +996,8 @@ module Make (A : ARG) : (* perform [union r_from r_into] *) Log.debugf 15 (fun k -> - k "(@[cc.merge@ :from %a@ :into %a@])" Class.pp r_from Class.pp r_into); + k "(@[cc.merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp + r_into); (* call [on_pre_merge] functions, and merge theory data items *) if not self.model_mode then ( @@ -971,13 +1005,18 @@ module Make (A : ARG) : let expl = Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] in - Event.emit self.on_pre_merge (self, acts, r_into, r_from, expl) + Event.emit_iter self.on_pre_merge (self, r_into, r_from, expl) + ~f:(function + | Ok l -> push_action_l self l + | Error c -> raise (E_confl c)) ); + (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, + so they have a chance of observing pre-merge plugin data *) ((* parents might have a different signature, check for collisions *) - Class.iter_parents r_from (fun parent -> push_pending self parent); - (* for each node in [r_from]'s class, make it point to [r_into] *) - Class.iter_class r_from (fun u -> + E_node.iter_parents r_from (fun parent -> push_pending self parent); + (* for each e_node in [r_from]'s class, make it point to [r_into] *) + E_node.iter_class r_from (fun u -> assert (u.n_root == r_from); u.n_root <- r_into); (* capture current state *) @@ -994,15 +1033,15 @@ module Make (A : ARG) : (* on backtrack, unmerge classes and restore the pointers to [r_from] *) on_backtrack self (fun () -> Log.debugf 30 (fun k -> - k "(@[cc.undo_merge@ :from %a@ :into %a@])" Class.pp r_from - Class.pp r_into); + k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from + E_node.pp r_into); r_into.n_bits <- r_into_old_bits; r_into.n_next <- r_into_old_next; r_from.n_next <- r_from_old_next; r_into.n_parents <- r_into_old_parents; (* NOTE: this must come after the restoration of [next] pointers, otherwise we'd iterate on too big a class *) - Class.iter_class_ r_from (fun u -> u.n_root <- r_from); + E_node.iter_class_ r_from (fun u -> u.n_root <- r_from); r_into.n_size <- r_into.n_size - r_from.n_size)); (* check for semantic values, update the one of [r_into] @@ -1030,11 +1069,14 @@ module Make (A : ARG) : k "(@[cc.semantic-conflict.post-merge@ (@[n-from %a@ := %a@])@ \ (@[n-into %a@ := %a@])@])" - Class.pp n_from Term.pp v_from Class.pp n_into Term.pp v_into); + E_node.pp n_from Term.pp v_from E_node.pp n_into Term.pp v_into); Stat.incr self.count_semantic_conflict; - let (module A) = acts in - A.raise_semantic_conflict lits tuples + (* FIXME + let (module A) = acts in + A.raise_semantic_conflict lits tuples + *) + assert false | Some _ -> ())); (* update explanations (a -> b), arbitrarily. @@ -1046,20 +1088,21 @@ module Make (A : ARG) : that bridges between [a] and [b] *) on_backtrack self (fun () -> match a.n_expl, b.n_expl with - | FL_some e, _ when Class.equal e.next b -> a.n_expl <- FL_none - | _, FL_some e when Class.equal e.next a -> b.n_expl <- FL_none + | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none + | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none | _ -> assert false); a.n_expl <- FL_some { next = b; expl = e_ab }; (* call [on_post_merge] *) if not self.model_mode then - Event.emit self.on_post_merge (self, acts, r_into, r_from) + Event.emit_iter self.on_post_merge (self, r_into, r_from) + ~f:(push_action_l self) ) (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] in the equiv class of [r1] that is a known literal back to the SAT solver and which is not the one initially merged. We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) - and propagate_bools self acts r1 t1 r2 t2 (e_12 : explanation) sign : unit = + and propagate_bools self r1 t1 r2 t2 (e_12 : explanation) sign : unit = (* explanation for [t1 =e= t2 = r2] *) let half_expl_and_pr = lazy @@ -1070,14 +1113,14 @@ module Make (A : ARG) : in (* TODO: flag per class, `or`-ed on merge, to indicate if the class contains at least one lit *) - Class.iter_class r1 (fun u1 -> + E_node.iter_class r1 (fun u1 -> (* propagate if: - [u1] is a proper literal - [t2 != r2], because that can only happen after an explicit merge (no way to obtain that by propagation) *) - match Class.as_lit u1 with - | Some lit when not (Class.equal r2 t2) -> + match E_node.as_lit u1 with + | Some lit when not (E_node.equal r2 t2) -> let lit = if sign then lit @@ -1102,21 +1145,23 @@ module Make (A : ARG) : let _, pr = lits_and_proof_of_expl self st in guard, pr in - Event.emit self.on_propagate (self, lit, reason); - Stat.incr self.count_props; - let (module A) = acts in - A.propagate lit ~reason + push_action self (Act_propagate { lit; reason }); + Event.emit_iter self.on_propagate (self, lit, reason) + ~f:(push_action_l self); + Stat.incr self.count_props ) | _ -> ()) let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) - let[@inline] push_level (self : t) : unit = + let push_level (self : t) : unit = + assert (not self.in_loop); Backtrack_stack.push_level self.undo; T_b_tbl.push_level self.t_to_val; T_b_tbl.push_level self.val_to_t let pop_levels (self : t) n : unit = + assert (not self.in_loop); Vec.clear self.pending; Vec.clear self.combine; Log.debugf 15 (fun k -> @@ -1127,6 +1172,7 @@ module Make (A : ARG) : T_b_tbl.pop_levels self.val_to_t n; () + (* FIXME: remove *) (* run [f] in a local congruence closure level *) let with_model_mode self f = assert (not self.model_mode); @@ -1141,22 +1187,26 @@ module Make (A : ARG) : all_classes self |> Iter.filter_map (fun repr -> match T_b_tbl.get self.t_to_val repr.n_term with - | Some (_, v) -> Some (repr, Class.iter_class repr, v) + | Some (_, v) -> Some (repr, E_node.iter_class repr, v) | None -> None) + let assert_eq self t u expl : unit = + assert (not self.in_loop); + let t = add_term self t in + let u = add_term self u in + (* merge [a] and [b] *) + merge_classes self t u expl + (* assert that this boolean literal holds. if a lit is [= a b], merge [a] and [b]; otherwise merge the atom with true/false *) let assert_lit self lit : unit = + assert (not self.in_loop); let t = Lit.term lit in Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); let sign = Lit.sign lit in match A.view_as_cc t with - | Eq (a, b) when sign -> - let a = add_term self a in - let b = add_term self b in - (* merge [a] and [b] *) - merge_classes self a b (Expl.mk_lit lit) + | Eq (a, b) when sign -> assert_eq self a b (Expl.mk_lit lit) | _ -> (* equate t and true/false *) let rhs = n_bool self sign in @@ -1168,23 +1218,28 @@ module Make (A : ARG) : (* TODO: use oriented merge (force direction [n -> rhs]) *) merge_classes self n rhs (Expl.mk_lit lit) - let[@inline] assert_lits self lits : unit = Iter.iter (assert_lit self) lits + let[@inline] assert_lits self lits : unit = + assert (not self.in_loop); + Iter.iter (assert_lit self) lits - (* raise a conflict *) - let raise_conflict_from_expl self (acts : actions) expl = - Log.debugf 5 (fun k -> - k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); - let st = Expl_state.create () in - explain_decompose_expl self st expl; - let lits, pr = lits_and_proof_of_expl self st in - let c = List.rev_map Lit.neg lits in - let th = st.th_lemmas <> [] in - raise_conflict_ self ~th acts c pr + (* FIXME: remove? + (* raise a conflict *) + let raise_conflict_from_expl self (acts : actions_or_confl) expl = + Log.debugf 5 (fun k -> + k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); + let st = Expl_state.create () in + explain_decompose_expl self st expl; + let lits, pr = lits_and_proof_of_expl self st in + let c = List.rev_map Lit.neg lits in + let th = st.th_lemmas <> [] in + raise_conflict_ self ~th c pr + *) let merge self n1 n2 expl = + assert (not self.in_loop); Log.debugf 5 (fun k -> - k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" Class.pp n1 Class.pp - n2 Expl.pp expl); + k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" E_node.pp n1 + E_node.pp n2 Expl.pp expl); assert (T.Ty.equal (T.Term.ty n1.n_term) (T.Term.ty n2.n_term)); merge_classes self n1 n2 expl @@ -1192,6 +1247,7 @@ module Make (A : ARG) : merge self (add_term self t1) (add_term self t2) expl let set_model_value (self : t) (t : term) (v : value) : unit = + assert (not self.in_loop); assert self.model_mode; (* only valid in model mode *) match T_tbl.find_opt self.tbl t with @@ -1241,6 +1297,8 @@ module Make (A : ARG) : undo = Backtrack_stack.create (); true_; false_; + in_loop = false; + res_acts = Vec.create (); field_marked_explain; count_conflict = Stat.mk_int stat "cc.conflicts"; count_props = Stat.mk_int stat "cc.propagations"; @@ -1249,17 +1307,31 @@ module Make (A : ARG) : } and true_ = lazy (add_term cc (Term.bool tst true)) and false_ = lazy (add_term cc (Term.bool tst false)) in - ignore (Lazy.force true_ : node); - ignore (Lazy.force false_ : node); + ignore (Lazy.force true_ : e_node); + ignore (Lazy.force false_ : e_node); cc let[@inline] find_t self t : repr = let n = T_tbl.find self.tbl t in find_ n - let[@inline] check self acts : unit = + let pop_acts_ self = + let rec loop acc = + match Vec.pop self.res_acts with + | None -> acc + | Some x -> loop (x :: acc) + in + loop [] + + let check self : actions_or_confl = Log.debug 5 "(cc.check)"; - update_tasks self acts + self.in_loop <- true; + let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in + try + update_tasks self; + let l = pop_acts_ self in + Ok l + with E_confl c -> Error c let check_inv_enabled_ = true (* XXX NUDGE *) @@ -1268,7 +1340,7 @@ module Make (A : ARG) : if check_inv_enabled_ then ( Log.debug 2 "(cc.check-invariants)"; all_classes self - |> Iter.flat_map Class.iter_class + |> Iter.flat_map E_node.iter_class |> Iter.iter (fun n -> match n.n_sig0 with | None -> () @@ -1277,16 +1349,16 @@ module Make (A : ARG) : let ok = match find_signature self s' with | None -> false - | Some r -> Class.equal r n.n_root + | Some r -> E_node.equal r n.n_root in if not ok then Log.debugf 0 (fun k -> k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" - Class.pp n Signature.pp s Signature.pp s')) + E_node.pp n Signature.pp s Signature.pp s')) ) (* model: return all the classes *) let get_model (self : t) : repr Iter.t Iter.t = check_inv_ self; - all_classes self |> Iter.map Class.iter_class + all_classes self |> Iter.map E_node.iter_class end diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml index 211fd6be..2ddb9389 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -3,11 +3,11 @@ open Sidekick_sigs_cc module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER - val mem : t -> M.CC.Class.t -> bool - (** Does the CC Class.t have a monoid value? *) + val mem : t -> M.CC.E_node.t -> bool + (** Does the CC E_node.t have a monoid value? *) - val get : t -> M.CC.Class.t -> M.t option - (** Get monoid value for this CC Class.t, if any *) + val get : t -> M.CC.E_node.t -> M.t option + (** Get monoid value for this CC E_node.t, if any *) val iter_all : t -> (M.CC.repr * M.t) Iter.t @@ -19,8 +19,8 @@ module Make (M : MONOID_PLUGIN_ARG) : EXTENDED_PLUGIN_BUILDER with module M = M = struct module M = M module CC = M.CC - module Class = CC.Class - module Cls_tbl = Backtrackable_tbl.Make (Class) + module E_node = CC.E_node + module Cls_tbl = Backtrackable_tbl.Make (E_node) module Expl = CC.Expl type term = CC.term @@ -41,7 +41,7 @@ module Make (M : MONOID_PLUGIN_ARG) : let values : M.t Cls_tbl.t = Cls_tbl.create ?size () (* bit in CC to filter out quickly classes without value *) - let field_has_value : CC.Class.bitfield = + let field_has_value : CC.E_node.bitfield = CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc let push_level () = Cls_tbl.push_level values @@ -69,8 +69,8 @@ module Make (M : MONOID_PLUGIN_ARG) : (match maybe_m with | Some v -> Log.debugf 20 (fun k -> - k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name Class.pp n - M.pp v); + k "(@[monoid[%s].on-new-term@ :n %a@ :value %a@])" M.name E_node.pp + n M.pp v); CC.set_bitfield cc field_has_value true n; Cls_tbl.add values n v | None -> ()); @@ -78,25 +78,25 @@ module Make (M : MONOID_PLUGIN_ARG) : (fun (n_u, m_u) -> Log.debugf 20 (fun k -> k "(@[monoid[%s].on-new-term.sub@ :n %a@ :sub-t %a@ :value %a@])" - M.name Class.pp n Class.pp n_u M.pp m_u); + M.name E_node.pp n E_node.pp n_u M.pp m_u); let n_u = CC.find cc n_u in if CC.get_bitfield cc field_has_value n_u then ( let m_u' = try Cls_tbl.find values n_u with Not_found -> - Error.errorf "node %a has bitfield but no value" Class.pp n_u + Error.errorf "node %a has bitfield but no value" E_node.pp n_u in match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with | Error expl -> Error.errorf "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" - Class.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl + E_node.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl | Ok m_u_merged -> Log.debugf 20 (fun k -> k "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ :value %a@])" - M.name Class.pp n Class.pp n_u M.pp m_u_merged); + M.name E_node.pp n E_node.pp n_u M.pp m_u_merged); Cls_tbl.add values n_u m_u_merged ) else ( (* just add to [n_u] *) @@ -108,30 +108,33 @@ module Make (M : MONOID_PLUGIN_ARG) : let iter_all : _ Iter.t = Cls_tbl.to_iter values - let on_pre_merge cc acts n1 n2 e_n1_n2 : unit = - match get n1, get n2 with - | Some v1, Some v2 -> - Log.debugf 5 (fun k -> - k - "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 %a@ \ - :val2 %a@])@])" - M.name Class.pp n1 M.pp v1 Class.pp n2 M.pp v2); - (match M.merge cc n1 v1 n2 v2 e_n1_n2 with - | Ok v' -> - Cls_tbl.remove values n2; - (* only keep repr *) - Cls_tbl.add values n1 v' - | Error expl -> CC.raise_conflict_from_expl cc acts expl) - | None, Some cr -> - CC.set_bitfield cc field_has_value true n1; - Cls_tbl.add values n1 cr; - Cls_tbl.remove values n2 (* only keep reprs *) - | Some _, None -> () (* already there on the left *) - | None, None -> () + let on_pre_merge cc n1 n2 e_n1_n2 : CC.actions = + let exception E of M.CC.conflict in + try + match get n1, get n2 with + | Some v1, Some v2 -> + Log.debugf 5 (fun k -> + k + "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 \ + %a@ :val2 %a@])@])" + M.name E_node.pp n1 M.pp v1 E_node.pp n2 M.pp v2); + (match M.merge cc n1 v1 n2 v2 e_n1_n2 with + | Ok v' -> + Cls_tbl.remove values n2; + (* only keep repr *) + Cls_tbl.add values n1 v' + | Error expl -> raise (E (CC.Conflict_expl expl))) + | None, Some cr -> + CC.set_bitfield cc field_has_value true n1; + Cls_tbl.add values n1 cr; + Cls_tbl.remove values n2 (* only keep reprs *) + | Some _, None -> () (* already there on the left *) + | None, None -> () + with E c -> Error c let pp out () : unit = let pp_e out (t, v) = - Fmt.fprintf out "(@[%a@ :has %a@])" Class.pp t M.pp v + Fmt.fprintf out "(@[%a@ :has %a@])" E_node.pp t M.pp v in Fmt.fprintf out "(@[%a@])" (Fmt.iter pp_e) iter_all From e37f66c394e96d6c463c5d5e5c0b91d1ca38429d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 21 Jul 2022 23:29:07 -0400 Subject: [PATCH 015/174] feat(cc): remove same-val explanations and model mode --- src/cc/Sidekick_cc.ml | 255 ++++++------------------------------------ 1 file changed, 37 insertions(+), 218 deletions(-) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 121d7ba6..9a464a0e 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -126,7 +126,6 @@ module Make (A : ARG) : | E_congruence of e_node * e_node (* caused by normal congruence *) | E_and of explanation * explanation | E_theory of term * term * (term * term * explanation list) list * step_id - | E_same_val of e_node * e_node type repr = e_node @@ -212,8 +211,6 @@ module Make (A : ARG) : (Util.pp_list @@ Fmt.Dump.triple Term.pp Term.pp (Fmt.Dump.list pp)) es | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b - | E_same_val (n1, n2) -> - Fmt.fprintf out "(@[same-value@ %a@ %a@])" E_node.pp n1 E_node.pp n2 let mk_trivial : t = E_trivial let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) @@ -233,12 +230,6 @@ module Make (A : ARG) : let[@inline] mk_lit l : t = E_lit l let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) - let[@inline] mk_same_value t u = - if E_node.equal t u then - mk_trivial - else - E_same_val (t, u) - let rec mk_list l = match l with | [] -> mk_trivial @@ -251,28 +242,10 @@ module Make (A : ARG) : end module Resolved_expl = struct - type t = { - lits: lit list; - same_value: (E_node.t * E_node.t) list; - pr: proof_trace -> step_id; - } - - let[@inline] is_semantic (self : t) : bool = - match self.same_value with - | [] -> false - | _ :: _ -> true + type t = { lits: lit list; pr: proof_trace -> step_id } let pp out (self : t) = - if not (is_semantic self) then - Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) - self.lits - else ( - let { lits; same_value; pr = _ } = self in - Fmt.fprintf out "(@[resolved-expl@ (@[%a@])@ :same-val (@[%a@])@])" - (Util.pp_list Lit.pp) lits - (Util.pp_list @@ Fmt.Dump.pair E_node.pp E_node.pp) - same_value - ) + Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits end type propagation_reason = unit -> lit list * step_id @@ -345,11 +318,9 @@ module Make (A : ARG) : module Sig_tbl = CCHashtbl.Make (Signature) module T_tbl = CCHashtbl.Make (Term) - module T_b_tbl = Backtrackable_tbl.Make (Term) type combine_task = | CT_merge of e_node * e_node * explanation - | CT_set_val of e_node * value | CT_act of action type t = { @@ -366,17 +337,12 @@ module Make (A : ARG) : have the same signature *) pending: e_node Vec.t; combine: combine_task Vec.t; - t_to_val: (e_node * value) T_b_tbl.t; - (* TODO: remove this, make it a plugin/EGG instead *) - (* [repr -> (t,val)] where [repr = t] and [t := val] in the model *) - val_to_t: e_node T_b_tbl.t; (* [val -> t] where [t := val] in the model *) undo: (unit -> unit) Backtrack_stack.t; bitgen: Bits.bitfield_gen; field_marked_explain: Bits.field; (* used to mark traversed nodes when looking for a common ancestor *) true_: e_node lazy_t; false_: e_node lazy_t; - mutable model_mode: bool; mutable in_loop: bool; (* currently being modified? *) res_acts: action Vec.t; (* to return *) on_pre_merge: @@ -389,7 +355,6 @@ module Make (A : ARG) : count_conflict: int Stat.counter; count_props: int Stat.counter; count_merge: int Stat.counter; - count_semantic_conflict: int Stat.counter; } (* TODO: an additional union-find to keep track, for each term, of the terms they are known to be equal to, according @@ -581,31 +546,20 @@ module Make (A : ARG) : module Expl_state = struct type t = { mutable lits: Lit.t list; - mutable same_val: (E_node.t * E_node.t) list; mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * step_id) list; } - let create () : t = { lits = []; same_val = []; th_lemmas = [] } + let create () : t = { lits = []; th_lemmas = [] } let[@inline] copy self : t = { self with lits = self.lits } let[@inline] add_lit (self : t) lit = self.lits <- lit :: self.lits let[@inline] add_th (self : t) lit hyps pr : unit = self.th_lemmas <- (lit, hyps, pr) :: self.th_lemmas - let[@inline] add_same_val (self : t) n1 n2 : unit = - self.same_val <- (n1, n2) :: self.same_val - - (** Does this explanation contain at least one merge caused by - "same value"? *) - let[@inline] is_semantic (self : t) : bool = self.same_val <> [] - let merge self other = - let { lits = o_lits; th_lemmas = o_lemmas; same_val = o_same_val } = - other - in + let { lits = o_lits; th_lemmas = o_lemmas } = other in self.lits <- List.rev_append o_lits self.lits; self.th_lemmas <- List.rev_append o_lemmas self.th_lemmas; - self.same_val <- List.rev_append o_same_val self.same_val; () (* proof of [\/_i ¬lits[i]] *) @@ -643,10 +597,10 @@ module Make (A : ARG) : let to_resolved_expl (self : t) : Resolved_expl.t = (* FIXME: package the th lemmas too *) - let { lits; same_val; th_lemmas = _ } = self in + let { lits; th_lemmas = _ } = self in let s2 = copy self in let pr proof = proof_of_th_lemmas s2 proof in - { Resolved_expl.lits; same_value = same_val; pr } + { Resolved_expl.lits; pr } end (* decompose explanation [e] into a list of literals added to [acc] *) @@ -670,7 +624,6 @@ module Make (A : ARG) : explain_equal_rec_ self st c1 c2 | _ -> assert false) | E_lit lit -> Expl_state.add_lit st lit - | E_same_val (n1, n2) -> Expl_state.add_same_val st n1 n2 | E_theory (t, u, expl_sets, pr) -> let sub_proofs = List.map @@ -752,8 +705,7 @@ module Make (A : ARG) : if Option.is_some sig0 then (* [n] might be merged with other equiv classes *) push_pending self n; - if not self.model_mode then - Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); + Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); n (* compute the initial signature of the given e_node *) @@ -766,7 +718,7 @@ module Make (A : ARG) : (* add [n] to [sub.root]'s parent list *) (let sub_r = find_ sub in let old_parents = sub_r.n_parents in - if Bag.is_empty old_parents && not self.model_mode then + if Bag.is_empty old_parents then (* first time it has parents: tell watchers that this is a subterm *) Event.emit_iter self.on_is_subterm (self, sub, u) ~f:(push_action_l self); @@ -816,8 +768,7 @@ module Make (A : ARG) : merges. *) let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : Lit.t list * step_id = - let { Expl_state.lits; th_lemmas = _; same_val } = st in - assert (same_val = []); + let { Expl_state.lits; th_lemmas = _ } = st in let pr = Expl_state.proof_of_th_lemmas st self.proof in lits, pr @@ -873,51 +824,11 @@ module Make (A : ARG) : and task_combine_ self = function | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab - | CT_set_val (n, v) -> task_set_val_ self n v | CT_act (Act_merge (t, u, e)) -> task_merge_ self t u e | CT_act (Act_propagate _ as a) -> (* will return this propagation to the caller *) Vec.push self.res_acts a - and task_set_val_ self n v = - let repr_n = find_ n in - (* - if repr(n) has value [v], do nothing - - else if repr(n) has value [v'], semantic conflict - - else add [repr(n) -> (n,v)] to cc.t_to_val *) - (match T_b_tbl.get self.t_to_val repr_n.n_term with - | Some (n', v') when not (Term.equal v v') -> - (* semantic conflict *) - let expl = [ Expl.mk_merge n n' ] in - let expl_st = explain_expls self expl in - let lits = expl_st.lits in - let tuples = - List.rev_map (fun (t, u) -> true, t.n_term, u.n_term) expl_st.same_val - in - let tuples = (false, n.n_term, n'.n_term) :: tuples in - Log.debugf 5 (fun k -> - k - "(@[cc.semantic-conflict.set-val@ (@[set-val %a@ := %a@])@ \ - (@[existing-val %a@ := %a@])@])" - E_node.pp n Term.pp v E_node.pp n' Term.pp v'); - - Stat.incr self.count_semantic_conflict; - (* FIXME - raise (E_confl(Conflict lits)) - let (module A) = acts in - A.raise_semantic_conflict lits tuples - *) - assert false - | Some _ -> () - | None -> T_b_tbl.add self.t_to_val repr_n.n_term (n, v)); - (* now for the reverse map, look in self.val_to_t for [v]. - - if present, push a merge command with Expl.mk_same_value - - if not, add [v -> n] *) - match T_b_tbl.get self.val_to_t v with - | None -> T_b_tbl.add self.val_to_t v n - | Some n' when not (same_class n n') -> - merge_classes self n n' (Expl.mk_same_value n n') - | Some _ -> () - (* main CC algo: merge equivalence classes in [st.combine]. @raise Exn_unsat if merge fails *) and task_merge_ self a b e_ab : unit = @@ -948,25 +859,9 @@ module Make (A : ARG) : explain_equal_rec_ self expl_st a ra; explain_equal_rec_ self expl_st b rb; - if Expl_state.is_semantic expl_st then ( - (* conflict involving some semantic values *) - let lits = expl_st.lits in - let same_val = - expl_st.same_val - |> List.rev_map (fun (t, u) -> true, E_node.term t, E_node.term u) - in - assert (same_val <> []); - Stat.incr self.count_semantic_conflict; - (* FIXME - let (module A) = acts in - A.raise_semantic_conflict lits same_val - *) - assert false - ) else ( - (* regular conflict *) - let lits, pr = lits_and_proof_of_expl self expl_st in - raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr - ) + (* regular conflict *) + let lits, pr = lits_and_proof_of_expl self expl_st in + raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr ); (* We will merge [r_from] into [r_into]. we try to ensure that [size ra <= size rb] in general, but always @@ -989,10 +884,8 @@ module Make (A : ARG) : propagate_bools self r2 t2 r1 t1 e_ab false in - if not self.model_mode then ( - merge_bool ra a rb b; - merge_bool rb b ra a - ); + merge_bool ra a rb b; + merge_bool rb b ra a; (* perform [union r_from r_into] *) Log.debugf 15 (fun k -> @@ -1000,16 +893,14 @@ module Make (A : ARG) : r_into); (* call [on_pre_merge] functions, and merge theory data items *) - if not self.model_mode then ( - (* explanation is [a=ra & e_ab & b=rb] *) - let expl = - Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] - in - Event.emit_iter self.on_pre_merge (self, r_into, r_from, expl) - ~f:(function - | Ok l -> push_action_l self l - | Error c -> raise (E_confl c)) - ); + (* explanation is [a=ra & e_ab & b=rb] *) + let expl = + Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] + in + Event.emit_iter self.on_pre_merge (self, r_into, r_from, expl) + ~f:(function + | Ok l -> push_action_l self l + | Error c -> raise (E_confl c)); (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, so they have a chance of observing pre-merge plugin data *) @@ -1044,41 +935,6 @@ module Make (A : ARG) : E_node.iter_class_ r_from (fun u -> u.n_root <- r_from); r_into.n_size <- r_into.n_size - r_from.n_size)); - (* check for semantic values, update the one of [r_into] - if [r_from] has a value *) - (match T_b_tbl.get self.t_to_val r_from.n_term with - | None -> () - | Some (n_from, v_from) -> - (match T_b_tbl.get self.t_to_val r_into.n_term with - | None -> T_b_tbl.add self.t_to_val r_into.n_term (n_from, v_from) - | Some (n_into, v_into) when not (Term.equal v_from v_into) -> - (* semantic conflict, including [n_from != n_into] in model *) - let expl = - [ e_ab; Expl.mk_merge r_from n_from; Expl.mk_merge r_into n_into ] - in - let expl_st = explain_expls self expl in - let lits = expl_st.lits in - let tuples = - List.rev_map - (fun (t, u) -> true, t.n_term, u.n_term) - expl_st.same_val - in - let tuples = (false, n_from.n_term, n_into.n_term) :: tuples in - - Log.debugf 5 (fun k -> - k - "(@[cc.semantic-conflict.post-merge@ (@[n-from %a@ := %a@])@ \ - (@[n-into %a@ := %a@])@])" - E_node.pp n_from Term.pp v_from E_node.pp n_into Term.pp v_into); - - Stat.incr self.count_semantic_conflict; - (* FIXME - let (module A) = acts in - A.raise_semantic_conflict lits tuples - *) - assert false - | Some _ -> ())); - (* update explanations (a -> b), arbitrarily. Note that here we merge the classes by adding a bridge between [a] and [b], not their roots. *) @@ -1093,9 +949,8 @@ module Make (A : ARG) : | _ -> assert false); a.n_expl <- FL_some { next = b; expl = e_ab }; (* call [on_post_merge] *) - if not self.model_mode then - Event.emit_iter self.on_post_merge (self, r_into, r_from) - ~f:(push_action_l self) + Event.emit_iter self.on_post_merge (self, r_into, r_from) + ~f:(push_action_l self) ) (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] @@ -1136,29 +991,25 @@ module Make (A : ARG) : explain_equal_rec_ self st u1 t1; (* propagate only if this doesn't depend on some semantic values *) - if not (Expl_state.is_semantic st) then ( - let reason () = - (* true literals explaining why t1=t2 *) - let guard = st.lits in - (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) - Expl_state.add_lit st (Lit.neg lit); - let _, pr = lits_and_proof_of_expl self st in - guard, pr - in - push_action self (Act_propagate { lit; reason }); - Event.emit_iter self.on_propagate (self, lit, reason) - ~f:(push_action_l self); - Stat.incr self.count_props - ) + let reason () = + (* true literals explaining why t1=t2 *) + let guard = st.lits in + (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) + Expl_state.add_lit st (Lit.neg lit); + let _, pr = lits_and_proof_of_expl self st in + guard, pr + in + push_action self (Act_propagate { lit; reason }); + Event.emit_iter self.on_propagate (self, lit, reason) + ~f:(push_action_l self); + Stat.incr self.count_props | _ -> ()) let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) let push_level (self : t) : unit = assert (not self.in_loop); - Backtrack_stack.push_level self.undo; - T_b_tbl.push_level self.t_to_val; - T_b_tbl.push_level self.val_to_t + Backtrack_stack.push_level self.undo let pop_levels (self : t) n : unit = assert (not self.in_loop); @@ -1168,28 +1019,8 @@ module Make (A : ARG) : k "(@[cc.pop-levels %d@ :n-lvls %d@])" n (Backtrack_stack.n_levels self.undo)); Backtrack_stack.pop_levels self.undo n ~f:(fun f -> f ()); - T_b_tbl.pop_levels self.t_to_val n; - T_b_tbl.pop_levels self.val_to_t n; () - (* FIXME: remove *) - (* run [f] in a local congruence closure level *) - let with_model_mode self f = - assert (not self.model_mode); - self.model_mode <- true; - push_level self; - CCFun.protect f ~finally:(fun () -> - pop_levels self 1; - self.model_mode <- false) - - let get_model_for_each_class self : _ Iter.t = - assert self.model_mode; - all_classes self - |> Iter.filter_map (fun repr -> - match T_b_tbl.get self.t_to_val repr.n_term with - | Some (_, v) -> Some (repr, E_node.iter_class repr, v) - | None -> None) - let assert_eq self t u expl : unit = assert (not self.in_loop); let t = add_term self t in @@ -1246,14 +1077,6 @@ module Make (A : ARG) : let merge_t self t1 t2 expl = merge self (add_term self t1) (add_term self t2) expl - let set_model_value (self : t) (t : term) (v : value) : unit = - assert (not self.in_loop); - assert self.model_mode; - (* only valid in model mode *) - match T_tbl.find_opt self.tbl t with - | None -> () (* ignore, th combination not needed *) - | Some n -> Vec.push self.combine (CT_set_val (n, v)) - let explain_eq self n1 n2 : Resolved_expl.t = let st = Expl_state.create () in explain_equal_rec_ self st n1 n2; @@ -1283,9 +1106,6 @@ module Make (A : ARG) : tbl = T_tbl.create size; signatures_tbl = Sig_tbl.create size; bitgen; - t_to_val = T_b_tbl.create ~size:32 (); - val_to_t = T_b_tbl.create ~size:32 (); - model_mode = false; on_pre_merge = Event.Emitter.create (); on_post_merge = Event.Emitter.create (); on_new_term = Event.Emitter.create (); @@ -1303,7 +1123,6 @@ module Make (A : ARG) : count_conflict = Stat.mk_int stat "cc.conflicts"; count_props = Stat.mk_int stat "cc.propagations"; count_merge = Stat.mk_int stat "cc.merges"; - count_semantic_conflict = Stat.mk_int stat "cc.semantic-conflicts"; } and true_ = lazy (add_term cc (Term.bool tst true)) and false_ = lazy (add_term cc (Term.bool tst false)) in From 6da628471142df82ded589cb9c9d9870d0f25313 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 22 Jul 2022 21:26:21 -0400 Subject: [PATCH 016/174] refactor(cc): use explicit actions in CC, not effectful functions --- src/algos/lra/sidekick_arith_lra.ml | 20 +- src/cc/Sidekick_cc.ml | 101 ++++---- src/cc/plugin/sidekick_cc_plugin.ml | 30 ++- src/cc/plugin/sidekick_cc_plugin.mli | 8 +- src/sigs/cc/sidekick_sigs_cc.ml | 329 +++++++++++--------------- src/sigs/smt/Sidekick_sigs_smt.ml | 37 +-- src/smt-solver/Sidekick_smt_solver.ml | 127 ++++++---- src/th-cstor/Sidekick_th_cstor.ml | 15 +- src/th-data/Sidekick_th_data.ml | 112 +++++---- src/util/Event.ml | 6 +- src/util/Sidekick_util.ml | 2 + 11 files changed, 413 insertions(+), 374 deletions(-) diff --git a/src/algos/lra/sidekick_arith_lra.ml b/src/algos/lra/sidekick_arith_lra.ml index eb8efe82..ee3b990a 100644 --- a/src/algos/lra/sidekick_arith_lra.ml +++ b/src/algos/lra/sidekick_arith_lra.ml @@ -104,7 +104,7 @@ module Make (A : ARG) : S with module A = A = struct module T = A.S.T.Term module Lit = A.S.Solver_internal.Lit module SI = A.S.Solver_internal - module N = SI.CC.Class + module N = SI.CC.E_node open struct module Pr = SI.Proof_trace @@ -121,7 +121,9 @@ module Make (A : ARG) : S with module A = A = struct | Lit l -> [ l ] | CC_eq (n1, n2) -> let r = SI.CC.explain_eq (SI.cc si) n1 n2 in - assert (not (SI.CC.Resolved_expl.is_semantic r)); + (* FIXME + assert (not (SI.CC.Resolved_expl.is_semantic r)); + *) r.lits end @@ -214,8 +216,8 @@ module Make (A : ARG) : S with module A = A = struct in raise (Confl expl) )); - Ok (List.rev_append l1 l2) - with Confl expl -> Error expl + Ok (List.rev_append l1 l2, []) + with Confl expl -> Error (SI.CC.Handler_action.Conflict expl) end module ST_exprs = Sidekick_cc_plugin.Make (Monoid_exprs) @@ -798,15 +800,17 @@ module Make (A : ARG) : S with module A = A = struct SI.on_final_check si (final_check_ st); SI.on_partial_check si (partial_check_ st); SI.on_model si ~ask:(model_ask_ st) ~complete:(model_complete_ st); - SI.on_cc_is_subterm si (fun (_, _, t) -> on_subterm st t); - SI.on_cc_pre_merge si (fun (cc, acts, n1, n2, expl) -> + SI.on_cc_is_subterm si (fun (_, _, t) -> + on_subterm st t; + []); + SI.on_cc_pre_merge si (fun (_cc, n1, n2, expl) -> match as_const_ (N.term n1), as_const_ (N.term n2) with | Some q1, Some q2 when A.Q.(q1 <> q2) -> (* classes with incompatible constants *) Log.debugf 30 (fun k -> k "(@[lra.merge-incompatible-consts@ %a@ %a@])" N.pp n1 N.pp n2); - SI.CC.raise_conflict_from_expl cc acts expl - | _ -> ()); + Error (SI.CC.Handler_action.Conflict expl) + | _ -> Ok []); SI.on_th_combination si (do_th_combination st); st diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 9a464a0e..267703e8 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -248,21 +248,6 @@ module Make (A : ARG) : Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits end - type propagation_reason = unit -> lit list * step_id - - type action = - | Act_merge of E_node.t * E_node.t * Expl.t - | Act_propagate of { lit: lit; reason: propagation_reason } - - type conflict = - | Conflict of lit list * step_id - (** [raise_conflict (c,pr)] declares that [c] is a tautology of - the theory of congruence. - @param pr the proof of [c] being a tautology *) - | Conflict_expl of Expl.t - - type actions_or_confl = (action list, conflict) result - (** A signature is a shallow term shape where immediate subterms are representative *) module Signature = struct @@ -319,9 +304,26 @@ module Make (A : ARG) : module Sig_tbl = CCHashtbl.Make (Signature) module T_tbl = CCHashtbl.Make (Term) + type propagation_reason = unit -> lit list * step_id + + module Handler_action = struct + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of lit * propagation_reason + + type conflict = Conflict of Expl.t [@@unboxed] + type or_conflict = (t list, conflict) result + end + + module Result_action = struct + type t = Act_propagate of { lit: lit; reason: propagation_reason } + type conflict = Conflict of lit list * step_id + type or_conflict = (t list, conflict) result + end + type combine_task = | CT_merge of e_node * e_node * explanation - | CT_act of action + | CT_act of Handler_action.t type t = { tst: term_store; @@ -344,14 +346,18 @@ module Make (A : ARG) : true_: e_node lazy_t; false_: e_node lazy_t; mutable in_loop: bool; (* currently being modified? *) - res_acts: action Vec.t; (* to return *) + res_acts: Result_action.t Vec.t; (* to return *) on_pre_merge: - (t * E_node.t * E_node.t * Expl.t, actions_or_confl) Event.Emitter.t; - on_post_merge: (t * E_node.t * E_node.t, action list) Event.Emitter.t; - on_new_term: (t * E_node.t * term, action list) Event.Emitter.t; + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; + on_post_merge: + (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; + on_new_term: (t * E_node.t * term, Handler_action.t list) Event.Emitter.t; on_conflict: (ev_on_conflict, unit) Event.Emitter.t; - on_propagate: (t * lit * propagation_reason, action list) Event.Emitter.t; - on_is_subterm: (t * E_node.t * term, action list) Event.Emitter.t; + on_propagate: + (t * lit * propagation_reason, Handler_action.t list) Event.Emitter.t; + on_is_subterm: (t * E_node.t * term, Handler_action.t list) Event.Emitter.t; count_conflict: int Stat.counter; count_props: int Stat.counter; count_merge: int Stat.counter; @@ -451,10 +457,10 @@ module Make (A : ARG) : Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); Vec.push self.pending t - let push_action self (a : action) : unit = Vec.push self.combine (CT_act a) + let push_action self (a : Handler_action.t) : unit = + Vec.push self.combine (CT_act a) - let push_action_l self (l : action list) : unit = - List.iter (push_action self) l + let push_action_l self (l : _ list) : unit = List.iter (push_action self) l let merge_classes self t u e : unit = if t != u && not (same_class t u) then ( @@ -476,7 +482,7 @@ module Make (A : ARG) : u.n_expl <- FL_some { next = n; expl = e_n_u }; n.n_expl <- FL_none - exception E_confl of conflict + exception E_confl of Result_action.conflict let raise_conflict_ (cc : t) ~th (e : lit list) (p : step_id) : _ = Profile.instant "cc.conflict"; @@ -824,10 +830,10 @@ module Make (A : ARG) : and task_combine_ self = function | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab - | CT_act (Act_merge (t, u, e)) -> task_merge_ self t u e - | CT_act (Act_propagate _ as a) -> + | CT_act (Handler_action.Act_merge (t, u, e)) -> task_merge_ self t u e + | CT_act (Handler_action.Act_propagate (lit, reason)) -> (* will return this propagation to the caller *) - Vec.push self.res_acts a + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }) (* main CC algo: merge equivalence classes in [st.combine]. @raise Exn_unsat if merge fails *) @@ -900,7 +906,8 @@ module Make (A : ARG) : Event.emit_iter self.on_pre_merge (self, r_into, r_from, expl) ~f:(function | Ok l -> push_action_l self l - | Error c -> raise (E_confl c)); + | Error (Handler_action.Conflict expl) -> + raise_conflict_from_expl self expl); (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, so they have a chance of observing pre-merge plugin data *) @@ -999,12 +1006,24 @@ module Make (A : ARG) : let _, pr = lits_and_proof_of_expl self st in guard, pr in - push_action self (Act_propagate { lit; reason }); + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }); Event.emit_iter self.on_propagate (self, lit, reason) ~f:(push_action_l self); Stat.incr self.count_props | _ -> ()) + (* raise a conflict from an explanation, typically from an event handler. + Raises E_confl with a result conflict. *) + and raise_conflict_from_expl self (expl : Expl.t) : 'a = + Log.debugf 5 (fun k -> + k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); + let st = Expl_state.create () in + explain_decompose_expl self st expl; + let lits, pr = lits_and_proof_of_expl self st in + let c = List.rev_map Lit.neg lits in + let th = st.th_lemmas <> [] in + raise_conflict_ self ~th c pr + let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) let push_level (self : t) : unit = @@ -1053,19 +1072,6 @@ module Make (A : ARG) : assert (not self.in_loop); Iter.iter (assert_lit self) lits - (* FIXME: remove? - (* raise a conflict *) - let raise_conflict_from_expl self (acts : actions_or_confl) expl = - Log.debugf 5 (fun k -> - k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); - let st = Expl_state.create () in - explain_decompose_expl self st expl; - let lits, pr = lits_and_proof_of_expl self st in - let c = List.rev_map Lit.neg lits in - let th = st.th_lemmas <> [] in - raise_conflict_ self ~th c pr - *) - let merge self n1 n2 expl = assert (not self.in_loop); Log.debugf 5 (fun k -> @@ -1083,6 +1089,11 @@ module Make (A : ARG) : (* FIXME: also need to return the proof? *) Expl_state.to_resolved_expl st + let explain_expl (self : t) expl : Resolved_expl.t = + let expl_st = Expl_state.create () in + explain_decompose_expl self expl_st expl; + Expl_state.to_resolved_expl expl_st + let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge let[@inline] on_new_term self = Event.of_emitter self.on_new_term @@ -1142,7 +1153,7 @@ module Make (A : ARG) : in loop [] - let check self : actions_or_confl = + let check self : Result_action.or_conflict = Log.debug 5 "(cc.check)"; self.in_loop <- true; let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml index 2ddb9389..65e936d2 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -63,8 +63,9 @@ module Make (M : MONOID_PLUGIN_ARG) : else None - let on_new_term cc n (t : term) : unit = + let on_new_term cc n (t : term) : CC.Handler_action.t list = (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) + let acts = ref [] in let maybe_m, l = M.of_term cc n t in (match maybe_m with | Some v -> @@ -86,12 +87,14 @@ module Make (M : MONOID_PLUGIN_ARG) : with Not_found -> Error.errorf "node %a has bitfield but no value" E_node.pp n_u in + match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with - | Error expl -> + | Error (CC.Handler_action.Conflict expl) -> Error.errorf "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" E_node.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl - | Ok m_u_merged -> + | Ok (m_u_merged, merge_acts) -> + acts := List.rev_append merge_acts !acts; Log.debugf 20 (fun k -> k "(@[monoid[%s].on-new-term.sub.merged@ :n %a@ :sub-t %a@ \ @@ -104,14 +107,15 @@ module Make (M : MONOID_PLUGIN_ARG) : Cls_tbl.add values n_u m_u )) l; - () + !acts let iter_all : _ Iter.t = Cls_tbl.to_iter values - let on_pre_merge cc n1 n2 e_n1_n2 : CC.actions = - let exception E of M.CC.conflict in + let on_pre_merge cc n1 n2 e_n1_n2 : CC.Handler_action.or_conflict = + let exception E of M.CC.Handler_action.conflict in + let acts = ref [] in try - match get n1, get n2 with + (match get n1, get n2 with | Some v1, Some v2 -> Log.debugf 5 (fun k -> k @@ -119,17 +123,19 @@ module Make (M : MONOID_PLUGIN_ARG) : %a@ :val2 %a@])@])" M.name E_node.pp n1 M.pp v1 E_node.pp n2 M.pp v2); (match M.merge cc n1 v1 n2 v2 e_n1_n2 with - | Ok v' -> + | Ok (v', merge_acts) -> + acts := merge_acts; Cls_tbl.remove values n2; (* only keep repr *) Cls_tbl.add values n1 v' - | Error expl -> raise (E (CC.Conflict_expl expl))) + | Error c -> raise (E c)) | None, Some cr -> CC.set_bitfield cc field_has_value true n1; Cls_tbl.add values n1 cr; Cls_tbl.remove values n2 (* only keep reprs *) | Some _, None -> () (* already there on the left *) - | None, None -> () + | None, None -> ()); + Ok !acts with E c -> Error c let pp out () : unit = @@ -141,8 +147,8 @@ module Make (M : MONOID_PLUGIN_ARG) : (* setup *) let () = Event.on (CC.on_new_term cc) ~f:(fun (_, r, t) -> on_new_term cc r t); - Event.on (CC.on_pre_merge cc) ~f:(fun (_, acts, ra, rb, expl) -> - on_pre_merge cc acts ra rb expl); + Event.on (CC.on_pre_merge cc) ~f:(fun (_, ra, rb, expl) -> + on_pre_merge cc ra rb expl); () end diff --git a/src/cc/plugin/sidekick_cc_plugin.mli b/src/cc/plugin/sidekick_cc_plugin.mli index f70ae421..71ccdbc5 100644 --- a/src/cc/plugin/sidekick_cc_plugin.mli +++ b/src/cc/plugin/sidekick_cc_plugin.mli @@ -5,11 +5,11 @@ open Sidekick_sigs_cc module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER - val mem : t -> M.CC.Class.t -> bool - (** Does the CC Class.t have a monoid value? *) + val mem : t -> M.CC.E_node.t -> bool + (** Does the CC.E_node.t have a monoid value? *) - val get : t -> M.CC.Class.t -> M.t option - (** Get monoid value for this CC Class.t, if any *) + val get : t -> M.CC.E_node.t -> M.t option + (** Get monoid value for this CC.E_node.t, if any *) val iter_all : t -> (M.CC.repr * M.t) Iter.t diff --git a/src/sigs/cc/sidekick_sigs_cc.ml b/src/sigs/cc/sidekick_sigs_cc.ml index 5162ba26..c8647ca0 100644 --- a/src/sigs/cc/sidekick_sigs_cc.ml +++ b/src/sigs/cc/sidekick_sigs_cc.ml @@ -6,48 +6,6 @@ module type TERM = Sidekick_sigs_term.S module type LIT = Sidekick_sigs_lit.S module type PROOF_TRACE = Sidekick_sigs_proof_trace.S -(** Actions provided to the congruence closure. - - The congruence closure must be able to propagate literals when - it detects that they are true or false; it must also - be able to create conflicts when the set of (dis)equalities - is inconsistent *) -module type DYN_ACTIONS = sig - type term - type lit - type proof_trace - type step_id - - val proof_trace : unit -> proof_trace - - val raise_conflict : lit list -> step_id -> 'a - (** [raise_conflict c pr] declares that [c] is a tautology of - the theory of congruence. This does not return (it should raise an - exception). - @param pr the proof of [c] being a tautology *) - - val raise_semantic_conflict : lit list -> (bool * term * term) list -> 'a - (** [raise_semantic_conflict lits same_val] declares that - the conjunction of all [lits] (literals true in current trail) and tuples - [{=,≠}, t_i, u_i] implies false. - - The [{=,≠}, t_i, u_i] are pairs of terms with the same value (if [=] / true) - or distinct value (if [≠] / false)) in the current model. - - This does not return. It should raise an exception. - *) - - val propagate : lit -> reason:(unit -> lit list * step_id) -> unit - (** [propagate lit ~reason pr] declares that [reason() => lit] - is a tautology. - - - [reason()] should return a list of literals that are currently true. - - [lit] should be a literal of interest (see {!CC_S.set_as_lit}). - - This function might never be called, a congruence closure has the right - to not propagate and only trigger conflicts. *) -end - (** Arguments to a congruence closure's implementation *) module type ARG = sig module T : TERM @@ -83,23 +41,17 @@ module type ARGS_CLASSES_EXPL_EVENT = sig type proof_trace = Proof_trace.t type step_id = Proof_trace.A.step_id - type actions = - (module DYN_ACTIONS - with type term = T.Term.t - and type lit = Lit.t - and type proof_trace = proof_trace - and type step_id = step_id) - (** Actions available to the congruence closure *) - - (** Equivalence classes. + (** E-node. + An e-node is a node in the congruence closure that is contained + in some equivalence classe). An equivalence class is a set of terms that are currently equal in the partial model built by the solver. The class is represented by a collection of nodes, one of which is distinguished and is called the "representative". All information pertaining to the whole equivalence class is stored - in this representative's Class.t. + in its representative's {!E_node.t}. When two classes become equal (are "merged"), one of the two representatives is picked as the representative of the new class. @@ -109,10 +61,9 @@ module type ARGS_CLASSES_EXPL_EVENT = sig representative. This information can be used when two classes are merged, to detect conflicts and solve equations à la Shostak. *) - module Class : sig + module E_node : sig type t - (** An equivalent class, containing terms that are proved - to be equal. + (** An E-node. A value of type [t] points to a particular term, but see {!find} to get the representative of the class. *) @@ -125,14 +76,14 @@ module type ARGS_CLASSES_EXPL_EVENT = sig val equal : t -> t -> bool (** Are two classes {b physically} equal? To check for - logical equality, use [CC.Class.equal (CC.find cc n1) (CC.find cc n2)] + logical equality, use [CC.E_node.equal (CC.find cc n1) (CC.find cc n2)] which checks for equality of representatives. *) val hash : t -> int - (** An opaque hash of this Class.t. *) + (** An opaque hash of this E_node.t. *) val is_root : t -> bool - (** Is the Class.t a root (ie the representative of its class)? + (** Is the E_node.t a root (ie the representative of its class)? See {!find} to get the root. *) val iter_class : t -> t Iter.t @@ -167,7 +118,7 @@ module type ARGS_CLASSES_EXPL_EVENT = sig include Sidekick_sigs.PRINT with type t := t - val mk_merge : Class.t -> Class.t -> t + val mk_merge : E_node.t -> E_node.t -> t (** Explanation: the nodes were explicitly merged *) val mk_merge_t : term -> term -> t @@ -178,9 +129,6 @@ module type ARGS_CLASSES_EXPL_EVENT = sig or we merged [t] and [true] because of literal [t], or [t] and [false] because of literal [¬t] *) - val mk_same_value : Class.t -> Class.t -> t - (** The two classes have the same value during model construction *) - val mk_list : t list -> t (** Conjunction of explanations *) @@ -217,73 +165,22 @@ module type ARGS_CLASSES_EXPL_EVENT = sig However, we can also have merged classes because they have the same value in the current model. *) module Resolved_expl : sig - type t = { - lits: lit list; - same_value: (Class.t * Class.t) list; - pr: proof_trace -> step_id; - } + type t = { lits: lit list; pr: proof_trace -> step_id } include Sidekick_sigs.PRINT with type t := t - - val is_semantic : t -> bool - (** [is_semantic expl] is [true] if there's at least one - pair in [expl.same_value]. *) end - type node = Class.t + (** Per-node data *) + + type e_node = E_node.t (** A node of the congruence closure *) - type repr = Class.t + type repr = E_node.t (** Node that is currently a representative. *) type explanation = Expl.t end -(* TODO: can we have that meaningfully? the type of Class.t would depend on - the implementation, so it can't be pre-defined, but nor can it be accessed from - shortcuts from the inside. That means one cannot point to classes from outside - the opened module. - - Potential solution: - - make Expl polymorphic and lift it to toplevel, like View - - do not expose Class, only Term-based API - (** The type for a congruence closure, as a first-class module *) - module type DYN = sig - include ARGS_CLASSES_EXPL_EVENT - include Sidekick_sigs.DYN_BACKTRACKABLE - - val term_store : unit -> term_store - val proof : unit -> proof_trace - val find : node -> repr - val add_term : term -> node - val mem_term : term -> bool - val allocate_bitfield : descr:string -> Class.bitfield - val get_bitfield : Class.bitfield -> Class.t -> bool - val set_bitfield : Class.bitfield -> bool -> Class.t -> unit - val on_event : unit -> event Event.t - val set_as_lit : Class.t -> lit -> unit - val find_t : term -> repr - val add_iter : term Iter.t -> unit - val all_classes : repr Iter.t - val assert_lit : lit -> unit - val assert_lits : lit Iter.t -> unit - val explain_eq : Class.t -> Class.t -> Resolved_expl.t - val raise_conflict_from_expl : actions -> Expl.t -> 'a - val n_true : unit -> Class.t - val n_false : unit -> Class.t - val n_bool : bool -> Class.t - val merge : Class.t -> Class.t -> Expl.t -> unit - val merge_t : term -> term -> Expl.t -> unit - val set_model_value : term -> value -> unit - val with_model_mode : (unit -> 'a) -> 'a - val get_model_for_each_class : (repr * Class.t Iter.t * value) Iter.t - val check : actions -> unit - val push_level : unit -> unit - val pop_levels : int -> unit - val get_model : Class.t Iter.t Iter.t - end -*) - (** Main congruence closure signature. The congruence closure handles the theory QF_UF (uninterpreted @@ -312,18 +209,18 @@ module type S = sig val term_store : t -> term_store val proof : t -> proof_trace - val find : t -> node -> repr + val find : t -> e_node -> repr (** Current representative *) - val add_term : t -> term -> node + val add_term : t -> term -> e_node (** Add the term to the congruence closure, if not present already. Will be backtracked. *) val mem_term : t -> term -> bool (** Returns [true] if the term is explicitly present in the congruence closure *) - val allocate_bitfield : t -> descr:string -> Class.bitfield - (** Allocate a new node field (see {!Class.bitfield}). + val allocate_bitfield : t -> descr:string -> E_node.bitfield + (** Allocate a new e_node field (see {!E_node.bitfield}). This field descriptor is henceforth reserved for all nodes in this congruence closure, and can be set using {!set_bitfield} @@ -336,12 +233,62 @@ module type S = sig for a given congruence closure (e.g. at most {!Sys.int_size} fields). *) - val get_bitfield : t -> Class.bitfield -> Class.t -> bool - (** Access the bit field of the given node *) + val get_bitfield : t -> E_node.bitfield -> E_node.t -> bool + (** Access the bit field of the given e_node *) - val set_bitfield : t -> Class.bitfield -> bool -> Class.t -> unit - (** Set the bitfield for the node. This will be backtracked. - See {!Class.bitfield}. *) + val set_bitfield : t -> E_node.bitfield -> bool -> E_node.t -> unit + (** Set the bitfield for the e_node. This will be backtracked. + See {!E_node.bitfield}. *) + + type propagation_reason = unit -> lit list * step_id + + (** Handler Actions + + Actions that can be scheduled by event handlers. *) + module Handler_action : sig + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of lit * propagation_reason + + (* TODO: + - an action to modify data associated with a class + *) + + type conflict = Conflict of Expl.t [@@unboxed] + + type or_conflict = (t list, conflict) result + (** Actions or conflict scheduled by an event handler. + + - [Ok acts] is a list of merges and propagations + - [Error confl] is a conflict to resolve. + *) + end + + (** Result Actions. + + + Actions returned by the congruence closure after calling {!check}. *) + module Result_action : sig + type t = + | Act_propagate of { lit: lit; reason: propagation_reason } + (** [propagate (lit, reason)] declares that [reason() => lit] + is a tautology. + + - [reason()] should return a list of literals that are currently true, + as well as a proof. + - [lit] should be a literal of interest (see {!S.set_as_lit}). + + This function might never be called, a congruence closure has the right + to not propagate and only trigger conflicts. *) + + type conflict = + | Conflict of lit list * step_id + (** [raise_conflict (c,pr)] declares that [c] is a tautology of + the theory of congruence. + @param pr the proof of [c] being a tautology *) + + type or_conflict = (t list, conflict) result + end (** {3 Events} @@ -349,18 +296,20 @@ module type S = sig other plugins can subscribe. *) (** Events emitted by the congruence closure when something changes. *) - val on_pre_merge : t -> (t * actions * Class.t * Class.t * Expl.t) Event.t + val on_pre_merge : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] and [n2] are merged with explanation [expl]. *) - val on_post_merge : t -> (t * actions * Class.t * Class.t) Event.t + val on_post_merge : + t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] and [n2] were merged. [find cc n1] and [find cc n2] will return - the same Class.t. *) + the same E_node.t. *) - val on_new_term : t -> (t * Class.t * term) Event.t + val on_new_term : t -> (t * E_node.t * term, Handler_action.t list) Event.t (** [ev_on_new_term n t] is emitted whenever a new term [t] - is added to the congruence closure. Its Class.t is [n]. *) + is added to the congruence closure. Its E_node.t is [n]. *) type ev_on_conflict = { cc: t; th: bool; c: lit list } (** Event emitted when a conflict occurs in the CC. @@ -370,27 +319,37 @@ module type S = sig participating in the conflict are purely syntactic theories like injectivity of constructors. *) - val on_conflict : t -> ev_on_conflict Event.t + val on_conflict : t -> (ev_on_conflict, unit) Event.t (** [ev_on_conflict {th; c}] is emitted when the congruence closure triggers a conflict by asserting the tautology [c]. *) - val on_propagate : t -> (t * lit * (unit -> lit list * step_id)) Event.t + val on_propagate : + t -> (t * lit * (unit -> lit list * step_id), Handler_action.t list) Event.t (** [ev_on_propagate lit reason] is emitted whenever [reason() => lit] is a propagated lemma. See {!CC_ACTIONS.propagate}. *) - val on_is_subterm : t -> (t * Class.t * term) Event.t + val on_is_subterm : t -> (t * E_node.t * term, Handler_action.t list) Event.t (** [ev_on_is_subterm n t] is emitted when [n] is a subterm of - another Class.t for the first time. [t] is the term corresponding to - the Class.t [n]. This can be useful for theory combination. *) + another E_node.t for the first time. [t] is the term corresponding to + the E_node.t [n]. This can be useful for theory combination. *) (** {3 Misc} *) - val set_as_lit : t -> Class.t -> lit -> unit - (** map the given node to a literal. *) + val n_true : t -> E_node.t + (** Node for [true] *) + + val n_false : t -> E_node.t + (** Node for [false] *) + + val n_bool : t -> bool -> E_node.t + (** Node for either true or false *) + + val set_as_lit : t -> E_node.t -> lit -> unit + (** map the given e_node to a literal. *) val find_t : t -> term -> repr (** Current representative of the term. - @raise Class.t_found if the term is not already {!add}-ed. *) + @raise E_node.t_found if the term is not already {!add}-ed. *) val add_iter : t -> term Iter.t -> unit (** Add a sequence of terms to the congruence closure *) @@ -398,6 +357,36 @@ module type S = sig val all_classes : t -> repr Iter.t (** All current classes. This is costly, only use if there is no other solution *) + val explain_eq : t -> E_node.t -> E_node.t -> Resolved_expl.t + (** Explain why the two nodes are equal. + Fails if they are not, in an unspecified way. *) + + val explain_expl : t -> Expl.t -> Resolved_expl.t + (** Transform explanation into an actionable conflict clause *) + + (* FIXME: remove + val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a + (** Raise a conflict with the given explanation. + It must be a theory tautology that [expl ==> absurd]. + To be used in theories. + + This fails in an unspecified way if the explanation, once resolved, + satisfies {!Resolved_expl.is_semantic}. *) + *) + + val merge : t -> E_node.t -> E_node.t -> Expl.t -> unit + (** Merge these two nodes given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + + val merge_t : t -> term -> term -> Expl.t -> unit + (** Shortcut for adding + merging *) + + (** {3 Main API *) + + val assert_eq : t -> term -> term -> Expl.t -> unit + (** Assert that two terms are equal, using the given explanation. *) + val assert_lit : t -> lit -> unit (** Given a literal, assume it in the congruence closure and propagate its consequences. Will be backtracked. @@ -407,45 +396,7 @@ module type S = sig val assert_lits : t -> lit Iter.t -> unit (** Addition of many literals *) - val explain_eq : t -> Class.t -> Class.t -> Resolved_expl.t - (** Explain why the two nodes are equal. - Fails if they are not, in an unspecified way. *) - - val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a - (** Raise a conflict with the given explanation. - It must be a theory tautology that [expl ==> absurd]. - To be used in theories. - - This fails in an unspecified way if the explanation, once resolved, - satisfies {!Resolved_expl.is_semantic}. *) - - val n_true : t -> Class.t - (** Node for [true] *) - - val n_false : t -> Class.t - (** Node for [false] *) - - val n_bool : t -> bool -> Class.t - (** Node for either true or false *) - - val merge : t -> Class.t -> Class.t -> Expl.t -> unit - (** Merge these two nodes given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val merge_t : t -> term -> term -> Expl.t -> unit - (** Shortcut for adding + merging *) - - val set_model_value : t -> term -> value -> unit - (** Set the value of a term in the model. *) - - val with_model_mode : t -> (unit -> 'a) -> 'a - (** Enter model combination mode. *) - - val get_model_for_each_class : t -> (repr * Class.t Iter.t * value) Iter.t - (** In model combination mode, obtain classes with their values. *) - - val check : t -> actions -> unit + val check : t -> Result_action.or_conflict (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. Will use the {!actions} to propagate literals, declare conflicts, etc. *) @@ -455,7 +406,7 @@ module type S = sig val pop_levels : t -> int -> unit (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) - val get_model : t -> Class.t Iter.t Iter.t + val get_model : t -> E_node.t Iter.t Iter.t (** get all the equivalence classes so they can be merged in the model *) end @@ -485,8 +436,10 @@ module type MONOID_PLUGIN_ARG = sig val name : string (** name of the monoid structure (short) *) + (* FIXME: for subs, return list of e_nodes, and assume of_term already + returned data for them. *) val of_term : - CC.t -> CC.Class.t -> CC.term -> t option * (CC.Class.t * t) list + CC.t -> CC.E_node.t -> CC.term -> t option * (CC.E_node.t * t) list (** [of_term n t], where [t] is the term annotating node [n], must return [maybe_m, l], where: @@ -500,12 +453,12 @@ module type MONOID_PLUGIN_ARG = sig val merge : CC.t -> - CC.Class.t -> + CC.E_node.t -> t -> - CC.Class.t -> + CC.E_node.t -> t -> CC.Expl.t -> - (t, CC.Expl.t) result + (t * CC.Handler_action.t list, CC.Handler_action.conflict) result (** Monoidal combination of two values. [merge cc n1 mon1 n2 mon2 expl] returns the result of merging @@ -531,11 +484,11 @@ module type DYN_MONOID_PLUGIN = sig val pp : unit Fmt.printer - val mem : M.CC.Class.t -> bool - (** Does the CC Class.t have a monoid value? *) + val mem : M.CC.E_node.t -> bool + (** Does the CC E_node.t have a monoid value? *) - val get : M.CC.Class.t -> M.t option - (** Get monoid value for this CC Class.t, if any *) + val get : M.CC.E_node.t -> M.t option + (** Get monoid value for this CC E_node.t, if any *) val iter_all : (M.CC.repr * M.t) Iter.t end diff --git a/src/sigs/smt/Sidekick_sigs_smt.ml b/src/sigs/smt/Sidekick_sigs_smt.ml index be68256d..ddeb5b71 100644 --- a/src/sigs/smt/Sidekick_sigs_smt.ml +++ b/src/sigs/smt/Sidekick_sigs_smt.ml @@ -230,19 +230,22 @@ module type SOLVER_INTERNAL = sig (** Add the given (signed) bool term to the SAT solver, so it gets assigned a boolean value *) - val cc_raise_conflict_expl : t -> theory_actions -> CC.Expl.t -> 'a - (** Raise a conflict with the given congruence closure explanation. - it must be a theory tautology that [expl ==> absurd]. - To be used in theories. *) - - val cc_find : t -> CC.Class.t -> CC.Class.t + val cc_find : t -> CC.E_node.t -> CC.E_node.t (** Find representative of the node *) val cc_are_equal : t -> term -> term -> bool (** Are these two terms equal in the congruence closure? *) + val cc_resolve_expl : t -> CC.Expl.t -> lit list * step_id + + (* + val cc_raise_conflict_expl : t -> theory_actions -> CC.Expl.t -> 'a + (** Raise a conflict with the given congruence closure explanation. + it must be a theory tautology that [expl ==> absurd]. + To be used in theories. *) + val cc_merge : - t -> theory_actions -> CC.Class.t -> CC.Class.t -> CC.Expl.t -> unit + t -> theory_actions -> CC.E_node.t -> CC.E_node.t -> CC.Expl.t -> unit (** Merge these two nodes in the congruence closure, given this explanation. It must be a theory tautology that [expl ==> n1 = n2]. To be used in theories. *) @@ -250,8 +253,9 @@ module type SOLVER_INTERNAL = sig val cc_merge_t : t -> theory_actions -> term -> term -> CC.Expl.t -> unit (** Merge these two terms in the congruence closure, given this explanation. See {!cc_merge} *) + *) - val cc_add_term : t -> term -> CC.Class.t + val cc_add_term : t -> term -> CC.E_node.t (** Add/retrieve congruence closure node for this term. To be used in theories *) @@ -261,19 +265,22 @@ module type SOLVER_INTERNAL = sig val on_cc_pre_merge : t -> - (CC.t * CC.actions * CC.Class.t * CC.Class.t * CC.Expl.t -> unit) -> + (CC.t * CC.E_node.t * CC.E_node.t * CC.Expl.t -> + CC.Handler_action.or_conflict) -> unit (** Callback for when two classes containing data for this key are merged (called before) *) val on_cc_post_merge : - t -> (CC.t * CC.actions * CC.Class.t * CC.Class.t -> unit) -> unit + t -> (CC.t * CC.E_node.t * CC.E_node.t -> CC.Handler_action.t list) -> unit (** Callback for when two classes containing data for this key are merged (called after)*) - val on_cc_new_term : t -> (CC.t * CC.Class.t * term -> unit) -> unit + val on_cc_new_term : + t -> (CC.t * CC.E_node.t * term -> CC.Handler_action.t list) -> unit (** Callback to add data on terms when they are added to the congruence closure *) - val on_cc_is_subterm : t -> (CC.t * CC.Class.t * term -> unit) -> unit + val on_cc_is_subterm : + t -> (CC.t * CC.E_node.t * term -> CC.Handler_action.t list) -> unit (** Callback for when a term is a subterm of another term in the congruence closure *) @@ -281,7 +288,9 @@ module type SOLVER_INTERNAL = sig (** Callback called on every CC conflict *) val on_cc_propagate : - t -> (CC.t * lit * (unit -> lit list * step_id) -> unit) -> unit + t -> + (CC.t * lit * (unit -> lit list * step_id) -> CC.Handler_action.t list) -> + unit (** Callback called on every CC propagation *) val on_partial_check : @@ -319,7 +328,7 @@ module type SOLVER_INTERNAL = sig (** {3 Model production} *) type model_ask_hook = - recurse:(t -> CC.Class.t -> term) -> t -> CC.Class.t -> term option + recurse:(t -> CC.E_node.t -> term) -> t -> CC.E_node.t -> term option (** A model-production hook to query values from a theory. It takes the solver, a class, and returns diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml index 8c44e19a..403a61d8 100644 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ b/src/smt-solver/Sidekick_smt_solver.ml @@ -134,7 +134,7 @@ module Make (A : ARG) : end module CC = Sidekick_cc.Make (CC_arg) - module N = CC.Class + module N = CC.E_node module Model = struct type t = Empty | Map of term Term.Tbl.t @@ -167,28 +167,30 @@ module Make (A : ARG) : | DA_add_clause of { c: lit list; pr: step_id; keep: bool } | DA_add_lit of { default_pol: bool option; lit: lit } - let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = - let (module A) = a in + (* TODO + let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = + let (module A) = a in - (module struct - module T = T - module Lit = Lit + (module struct + module T = T + module Lit = Lit - type nonrec lit = lit - type nonrec term = term - type nonrec proof_trace = Proof_trace.t - type nonrec step_id = step_id + type nonrec lit = lit + type nonrec term = term + type nonrec proof_trace = Proof_trace.t + type nonrec step_id = step_id - let proof_trace () = pr - let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr + let proof_trace () = pr + let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr - let[@inline] raise_semantic_conflict lits semantic = - raise (Semantic_conflict { lits; semantic }) + let[@inline] raise_semantic_conflict lits semantic = + raise (Semantic_conflict { lits; semantic }) - let[@inline] propagate lit ~reason = - let reason = Sidekick_sat.Consequence reason in - A.propagate lit reason - end) + let[@inline] propagate lit ~reason = + let reason = Sidekick_sat.Consequence reason in + A.propagate lit reason + end) + *) (** Internal solver, given to theories and to Msat *) module Solver_internal = struct @@ -198,7 +200,7 @@ module Make (A : ARG) : module P_core_rules = A.Rule_core module Lit = Lit module CC = CC - module N = CC.Class + module N = CC.E_node type nonrec proof_trace = Proof_trace.t type nonrec step_id = step_id @@ -584,6 +586,11 @@ module Make (A : ARG) : let n2 = cc_add_term self t2 in N.equal (cc_find self n1) (cc_find self n2) + let cc_resolve_expl self e : lit list * _ = + let r = CC.explain_expl (cc self) e in + r.lits, r.pr self.proof + + (* let cc_merge self _acts n1 n2 e = CC.merge (cc self) n1 n2 e let cc_merge_t self acts t1 t2 e = @@ -593,6 +600,7 @@ module Make (A : ARG) : let cc_raise_conflict_expl self acts e = let cc_acts = mk_cc_acts_ self.proof acts in CC.raise_conflict_from_expl (cc self) cc_acts e + *) (** {2 Interface with the SAT solver} *) @@ -631,13 +639,16 @@ module Make (A : ARG) : in let model = M.create 128 in + (* populate with information from the CC *) - CC.get_model_for_each_class cc (fun (_, ts, v) -> - Iter.iter - (fun n -> - let t = N.term n in - M.replace model t v) - ts); + (* FIXME + CC.get_model_for_each_class cc (fun (_, ts, v) -> + Iter.iter + (fun n -> + let t = N.term n in + M.replace model t v) + ts); + *) (* complete model with theory specific values *) let complete_with f = @@ -702,30 +713,45 @@ module Make (A : ARG) : can merge classes, *) let check_th_combination_ (self : t) (acts : theory_actions) : (Model.t, th_combination_conflict) result = + (* FIXME + + (* enter model mode, disabling most of congruence closure *) + CC.with_model_mode cc @@ fun () -> + let set_val (t, v) : unit = + Log.debugf 50 (fun k -> + k "(@[solver.th-comb.cc-set-term-value@ %a@ :val %a@])" Term.pp t + Term.pp v); + CC.set_model_value cc t v + in + + (* obtain assignments from the hook, and communicate them to the CC *) + let add_th_values f : unit = + let vals = f self acts in + Iter.iter set_val vals + in + try + List.iter add_th_values self.on_th_combination; + CC.check cc; + let m = mk_model_ self in + Ok m + with Semantic_conflict c -> Error c + *) + let m = mk_model_ self in + Ok m + + (* call congruence closure, perform the actions it scheduled *) + let check_cc_with_acts_ (self : t) (acts : theory_actions) = + let (module A) = acts in let cc = cc self in - let cc_acts = mk_cc_acts_ self.proof acts in - - (* entier model mode, disabling most of congruence closure *) - CC.with_model_mode cc @@ fun () -> - let set_val (t, v) : unit = - Log.debugf 50 (fun k -> - k "(@[solver.th-comb.cc-set-term-value@ %a@ :val %a@])" Term.pp t - Term.pp v); - CC.set_model_value cc t v - in - - (* obtain assignments from the hook, and communicate them to the CC *) - let add_th_values f : unit = - let vals = f self acts in - Iter.iter set_val vals - in - - try - List.iter add_th_values self.on_th_combination; - CC.check cc cc_acts; - let m = mk_model_ self in - Ok m - with Semantic_conflict c -> Error c + match CC.check cc with + | Ok acts -> + List.iter + (function + | CC.Result_action.Act_propagate { lit; reason } -> + let reason = Sidekick_sat.Consequence reason in + A.propagate lit reason) + acts + | Error (CC.Result_action.Conflict (lits, pr)) -> A.raise_conflict lits pr (* handle a literal assumed by the SAT solver *) let assert_lits_ ~final (self : t) (acts : theory_actions) @@ -741,14 +767,13 @@ module Make (A : ARG) : lits); (* transmit to CC *) let cc = cc self in - let cc_acts = mk_cc_acts_ self.proof acts in if not final then CC.assert_lits cc lits; (* transmit to theories. *) - CC.check cc cc_acts; + check_cc_with_acts_ self acts; if final then ( List.iter (fun f -> f self acts lits) self.on_final_check; - CC.check cc cc_acts; + check_cc_with_acts_ self acts; (match check_th_combination_ self acts with | Ok m -> self.last_model <- Some m diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index 2aaa9b26..fb5035ac 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -23,7 +23,7 @@ module Make (A : ARG) : S with module A = A = struct module A = A module SI = A.S.Solver_internal module T = A.S.T.Term - module N = SI.CC.Class + module N = SI.CC.E_node module Fun = A.S.T.Fun module Expl = SI.CC.Expl @@ -46,7 +46,7 @@ module Make (A : ARG) : S with module A = A = struct Some { n; t; cstor; args }, [] | _ -> None, [] - let merge cc n1 v1 n2 v2 e_n1_n2 : _ result = + let merge _cc n1 v1 n2 v2 e_n1_n2 : _ result = Log.debugf 5 (fun k -> k "(@[%s.merge@ @[:c1 %a (t %a)@]@ @[:c2 %a (t %a)@]@])" name N.pp n1 T.pp v1.t N.pp n2 T.pp v2.t); @@ -60,11 +60,16 @@ module Make (A : ARG) : S with module A = A = struct if Fun.equal v1.cstor v2.cstor then ( (* same function: injectivity *) assert (CCArray.length v1.args = CCArray.length v2.args); - CCArray.iter2 (fun u1 u2 -> SI.CC.merge cc u1 u2 expl) v1.args v2.args; - Ok v1 + let acts = + CCArray.map2 + (fun u1 u2 -> SI.CC.Handler_action.Act_merge (u1, u2, expl)) + v1.args v2.args + |> Array.to_list + in + Ok (v1, acts) ) else (* different function: disjointness *) - Error expl + Error (SI.CC.Handler_action.Conflict expl) end module ST = Sidekick_cc_plugin.Make (Monoid) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index d85c96b4..e0cce7da 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -160,7 +160,7 @@ module Make (A : ARG) : S with module A = A = struct module A = A module SI = A.S.Solver_internal module T = A.S.T.Term - module N = SI.CC.Class + module N = SI.CC.E_node module Ty = A.S.T.Ty module Expl = SI.CC.Expl module Card = Compute_card (A) @@ -216,9 +216,11 @@ module Make (A : ARG) : S with module A = A = struct in assert (CCArray.length c1.c_args = CCArray.length c2.c_args); + let acts = ref [] in Util.array_iteri2 c1.c_args c2.c_args ~f:(fun i u1 u2 -> - SI.CC.merge cc u1 u2 (expl_merge i)); - Ok c1 + acts := + SI.CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts); + Ok (c1, !acts) ) else ( (* different function: disjointness *) let expl = @@ -226,7 +228,7 @@ module Make (A : ARG) : S with module A = A = struct mk_expl t1 t2 @@ Pr.add_step proof @@ A.P.lemma_cstor_distinct t1 t2 in - Error expl + Error (SI.CC.Handler_action.Conflict expl) ) end @@ -294,7 +296,7 @@ module Make (A : ARG) : S with module A = A = struct pp v1 N.pp n2 pp v2); let parent_is_a = v1.parent_is_a @ v2.parent_is_a in let parent_select = v1.parent_select @ v2.parent_select in - Ok { parent_is_a; parent_select } + Ok ({ parent_is_a; parent_select }, []) end module ST_cstors = Sidekick_cc_plugin.Make (Monoid_cstor) @@ -394,7 +396,7 @@ module Make (A : ARG) : S with module A = A = struct N_tbl.add self.to_decide_for_complete_model n () | _ -> () - let on_new_term (self : t) ((cc, n, t) : _ * N.t * T.t) : unit = + let on_new_term (self : t) ((cc, n, t) : _ * N.t * T.t) : _ list = on_new_term_look_at_ty self n t; (* might have to decide [t] *) match A.view_as_data t with @@ -402,8 +404,10 @@ module Make (A : ARG) : S with module A = A = struct let n_u = SI.CC.add_term cc u in let repr_u = SI.CC.find cc n_u in (match ST_cstors.get self.cstors repr_u with - | None -> N_tbl.add self.to_decide repr_u () - (* needs to be decided *) + | None -> + (* needs to be decided *) + N_tbl.add self.to_decide repr_u (); + [] | Some cstor -> let is_true = A.Cstor.equal cstor.c_cstor c_t in Log.debugf 5 (fun k -> @@ -416,11 +420,14 @@ module Make (A : ARG) : S with module A = A = struct @@ A.P.lemma_isa_cstor ~cstor_t:(N.term cstor.c_n) t in let n_bool = SI.CC.n_bool cc is_true in - SI.CC.merge cc n n_bool + let expl = Expl.( mk_theory (N.term n) (N.term n_bool) [ N.term n_u, N.term cstor.c_n, [ mk_merge n_u cstor.c_n ] ] - pr)) + pr) + in + let a = SI.CC.Handler_action.Act_merge (n, n_bool, expl) in + [ a ]) | T_select (c_t, i, u) -> let n_u = SI.CC.add_term cc u in let repr_u = SI.CC.find cc n_u in @@ -435,21 +442,28 @@ module Make (A : ARG) : S with module A = A = struct Pr.add_step self.proof @@ A.P.lemma_select_cstor ~cstor_t:(N.term cstor.c_n) t in - SI.CC.merge cc n u_i + let expl = Expl.( mk_theory (N.term n) (N.term u_i) [ N.term n_u, N.term cstor.c_n, [ mk_merge n_u cstor.c_n ] ] pr) - | Some _ -> () - | None -> N_tbl.add self.to_decide repr_u () (* needs to be decided *)) - | T_cstor _ | T_other _ -> () + in + [ SI.CC.Handler_action.Act_merge (n, u_i, expl) ] + | Some _ -> [] + | None -> + (* needs to be decided *) + N_tbl.add self.to_decide repr_u (); + []) + | T_cstor _ | T_other _ -> [] let cstors_of_ty (ty : Ty.t) : A.Cstor.t Iter.t = match A.as_datatype ty with | Ty_data { cstors } -> cstors | _ -> assert false - let on_pre_merge (self : t) (cc, acts, n1, n2, expl) : unit = + let on_pre_merge (self : t) (cc, n1, n2, expl) : _ result = + let exception E_confl of SI.CC.Expl.t in + let acts = ref [] in let merge_is_a n1 (c1 : Monoid_cstor.t) n2 (is_a2 : Monoid_parents.is_a) = let is_true = A.Cstor.equal c1.c_cstor is_a2.is_a_cstor in Log.debugf 50 (fun k -> @@ -463,18 +477,21 @@ module Make (A : ARG) : S with module A = A = struct @@ A.P.lemma_isa_cstor ~cstor_t:(N.term c1.c_n) (N.term is_a2.is_a_n) in let n_bool = SI.CC.n_bool cc is_true in - SI.CC.merge cc is_a2.is_a_n n_bool - (Expl.mk_theory (N.term is_a2.is_a_n) (N.term n_bool) - [ - ( N.term n1, - N.term n2, - [ - Expl.mk_merge n1 c1.c_n; - Expl.mk_merge n1 n2; - Expl.mk_merge n2 is_a2.is_a_arg; - ] ); - ] - pr) + let expl = + Expl.mk_theory (N.term is_a2.is_a_n) (N.term n_bool) + [ + ( N.term n1, + N.term n2, + [ + Expl.mk_merge n1 c1.c_n; + Expl.mk_merge n1 n2; + Expl.mk_merge n2 is_a2.is_a_arg; + ] ); + ] + pr + in + let act = SI.CC.Handler_action.Act_merge (is_a2.is_a_n, n_bool, expl) in + acts := act :: !acts in let merge_select n1 (c1 : Monoid_cstor.t) n2 (sel2 : Monoid_parents.select) = @@ -488,18 +505,21 @@ module Make (A : ARG) : S with module A = A = struct @@ A.P.lemma_select_cstor ~cstor_t:(N.term c1.c_n) (N.term sel2.sel_n) in let u_i = CCArray.get c1.c_args sel2.sel_idx in - SI.CC.merge cc sel2.sel_n u_i - (Expl.mk_theory (N.term sel2.sel_n) (N.term u_i) - [ - ( N.term n1, - N.term n2, - [ - Expl.mk_merge n1 c1.c_n; - Expl.mk_merge n1 n2; - Expl.mk_merge n2 sel2.sel_arg; - ] ); - ] - pr) + let expl = + Expl.mk_theory (N.term sel2.sel_n) (N.term u_i) + [ + ( N.term n1, + N.term n2, + [ + Expl.mk_merge n1 c1.c_n; + Expl.mk_merge n1 n2; + Expl.mk_merge n2 sel2.sel_arg; + ] ); + ] + pr + in + let act = SI.CC.Handler_action.Act_merge (sel2.sel_n, u_i, expl) in + acts := act :: !acts ) in let merge_c_p n1 n2 = @@ -514,9 +534,11 @@ module Make (A : ARG) : S with module A = A = struct List.iter (fun is_a2 -> merge_is_a n1 c1 n2 is_a2) p2.parent_is_a; List.iter (fun s2 -> merge_select n1 c1 n2 s2) p2.parent_select in - merge_c_p n1 n2; - merge_c_p n2 n1; - () + try + merge_c_p n1 n2; + merge_c_p n2 n1; + Ok !acts + with E_confl e -> Error (SI.CC.Handler_action.Conflict e) module Acyclicity_ = struct type repr = N.t @@ -611,7 +633,8 @@ module Make (A : ARG) : S with module A = A = struct Log.debugf 5 (fun k -> k "(@[%s.acyclicity.raise_confl@ %a@ @[:path %a@]@])" name Expl.pp expl pp_path path); - SI.cc_raise_conflict_expl solver acts expl + let lits, pr = SI.cc_resolve_expl solver expl in + SI.raise_conflict solver acts lits pr | { flag = New; _ } as node_r -> node_r.flag <- Open; let path = (n, node_r) :: path in @@ -642,7 +665,8 @@ module Make (A : ARG) : S with module A = A = struct k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name T.pp u T.pp rhs SI.Lit.pp lit); let pr = Pr.add_step self.proof @@ A.P.lemma_isa_sel t in - SI.cc_merge_t solver acts u rhs + (* merge [u] and [rhs] *) + SI.CC.merge_t (SI.cc solver) u rhs (Expl.mk_theory u rhs [ t, N.term (SI.CC.n_true @@ SI.cc solver), [ Expl.mk_lit lit ] ] pr) diff --git a/src/util/Event.ml b/src/util/Event.ml index e1561b3b..af72dcc8 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -6,15 +6,15 @@ let nop_handler_ _ = assert false module Emitter = struct type nonrec ('a, 'b) t = ('a, 'b) t - let emit (self : (_, unit) t) x = Vec.iter self.h ~f:(fun h -> h x) + let emit (self : (_, unit) t) x = Vec.rev_iter self.h ~f:(fun h -> h x) let emit_collect (self : _ t) x : _ list = let l = ref [] in - Vec.iter self.h ~f:(fun h -> l := h x :: !l); + Vec.rev_iter self.h ~f:(fun h -> l := h x :: !l); !l let emit_iter self x ~f = - Vec.iter self.h ~f:(fun h -> + Vec.rev_iter self.h ~f:(fun h -> let y = h x in f y) diff --git a/src/util/Sidekick_util.ml b/src/util/Sidekick_util.ml index 44a0af18..aa84faad 100644 --- a/src/util/Sidekick_util.ml +++ b/src/util/Sidekick_util.ml @@ -24,3 +24,5 @@ module Stat = Stat module Hash = Hash module Profile = Profile module Chunk_stack = Chunk_stack + +let[@inline] ( let@ ) f x = f x From 851dda696a7c295b8b867663dc91ae630f860d80 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 22 Jul 2022 21:31:42 -0400 Subject: [PATCH 017/174] feat(cc): have 2 phases of pre-merge events the first phase observes plugin data unchanged; the second one is used to update plugin data themselves. This fix a bug that manifests itself depending on implementation details of Event, where some theory's event handler fires too late and observes a state that has already changed. --- src/cc/Sidekick_cc.ml | 30 ++++++++++++++++++++------- src/cc/plugin/sidekick_cc_plugin.ml | 2 +- src/sigs/cc/sidekick_sigs_cc.ml | 6 ++++++ src/smt-solver/Sidekick_smt_solver.ml | 3 --- src/th-data/Sidekick_th_data.ml | 10 +++------ src/util/Event.ml | 6 +++--- 6 files changed, 35 insertions(+), 22 deletions(-) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 267703e8..ae1562ae 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -351,6 +351,10 @@ module Make (A : ARG) : ( t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict ) Event.Emitter.t; + on_pre_merge2: + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; on_post_merge: (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; on_new_term: (t * E_node.t * term, Handler_action.t list) Event.Emitter.t; @@ -900,14 +904,22 @@ module Make (A : ARG) : (* call [on_pre_merge] functions, and merge theory data items *) (* explanation is [a=ra & e_ab & b=rb] *) - let expl = - Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] - in - Event.emit_iter self.on_pre_merge (self, r_into, r_from, expl) - ~f:(function - | Ok l -> push_action_l self l - | Error (Handler_action.Conflict expl) -> - raise_conflict_from_expl self expl); + (let expl = + Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] + in + + let handle_act = function + | Ok l -> push_action_l self l + | Error (Handler_action.Conflict expl) -> + raise_conflict_from_expl self expl + in + + Event.emit_iter self.on_pre_merge + (self, r_into, r_from, expl) + ~f:handle_act; + Event.emit_iter self.on_pre_merge2 + (self, r_into, r_from, expl) + ~f:handle_act); (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, so they have a chance of observing pre-merge plugin data *) @@ -1095,6 +1107,7 @@ module Make (A : ARG) : Expl_state.to_resolved_expl expl_st let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge + let[@inline] on_pre_merge2 self = Event.of_emitter self.on_pre_merge2 let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge let[@inline] on_new_term self = Event.of_emitter self.on_new_term let[@inline] on_conflict self = Event.of_emitter self.on_conflict @@ -1118,6 +1131,7 @@ module Make (A : ARG) : signatures_tbl = Sig_tbl.create size; bitgen; on_pre_merge = Event.Emitter.create (); + on_pre_merge2 = Event.Emitter.create (); on_post_merge = Event.Emitter.create (); on_new_term = Event.Emitter.create (); on_conflict = Event.Emitter.create (); diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml index 65e936d2..6ee73414 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -147,7 +147,7 @@ module Make (M : MONOID_PLUGIN_ARG) : (* setup *) let () = Event.on (CC.on_new_term cc) ~f:(fun (_, r, t) -> on_new_term cc r t); - Event.on (CC.on_pre_merge cc) ~f:(fun (_, ra, rb, expl) -> + Event.on (CC.on_pre_merge2 cc) ~f:(fun (_, ra, rb, expl) -> on_pre_merge cc ra rb expl); () end diff --git a/src/sigs/cc/sidekick_sigs_cc.ml b/src/sigs/cc/sidekick_sigs_cc.ml index c8647ca0..3bb47ec7 100644 --- a/src/sigs/cc/sidekick_sigs_cc.ml +++ b/src/sigs/cc/sidekick_sigs_cc.ml @@ -301,6 +301,12 @@ module type S = sig (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] and [n2] are merged with explanation [expl]. *) + val on_pre_merge2 : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t + (** Second phase of "on pre merge". This runs after {!on_pre_merge} + and is used by Plugins. {b NOTE}: Plugin state might be observed as already + changed in these handlers. *) + val on_post_merge : t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml index 403a61d8..c8b439dd 100644 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ b/src/smt-solver/Sidekick_smt_solver.ml @@ -102,7 +102,6 @@ module Make (A : ARG) : type term = Term.t type ty = Ty.t type lit = Lit.t - type rule = Proof_trace.A.rule type step_id = Proof_trace.A.step_id type proof_trace = Proof_trace.t @@ -118,8 +117,6 @@ module Make (A : ARG) : merged because of the current model so it's not a "true" conflict and doesn't need to kill the current trail. *) - exception Semantic_conflict of th_combination_conflict - (* the full argument to the congruence closure *) module CC_arg = struct module T = T diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index e0cce7da..bcf2b0b6 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -1,6 +1,5 @@ (** Theory for datatypes. *) -open Sidekick_sigs_smt include Th_intf let name = "th-data" @@ -462,7 +461,6 @@ module Make (A : ARG) : S with module A = A = struct | _ -> assert false let on_pre_merge (self : t) (cc, n1, n2, expl) : _ result = - let exception E_confl of SI.CC.Expl.t in let acts = ref [] in let merge_is_a n1 (c1 : Monoid_cstor.t) n2 (is_a2 : Monoid_parents.is_a) = let is_true = A.Cstor.equal c1.c_cstor is_a2.is_a_cstor in @@ -534,11 +532,9 @@ module Make (A : ARG) : S with module A = A = struct List.iter (fun is_a2 -> merge_is_a n1 c1 n2 is_a2) p2.parent_is_a; List.iter (fun s2 -> merge_select n1 c1 n2 s2) p2.parent_select in - try - merge_c_p n1 n2; - merge_c_p n2 n1; - Ok !acts - with E_confl e -> Error (SI.CC.Handler_action.Conflict e) + merge_c_p n1 n2; + merge_c_p n2 n1; + Ok !acts module Acyclicity_ = struct type repr = N.t diff --git a/src/util/Event.ml b/src/util/Event.ml index af72dcc8..e1561b3b 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -6,15 +6,15 @@ let nop_handler_ _ = assert false module Emitter = struct type nonrec ('a, 'b) t = ('a, 'b) t - let emit (self : (_, unit) t) x = Vec.rev_iter self.h ~f:(fun h -> h x) + let emit (self : (_, unit) t) x = Vec.iter self.h ~f:(fun h -> h x) let emit_collect (self : _ t) x : _ list = let l = ref [] in - Vec.rev_iter self.h ~f:(fun h -> l := h x :: !l); + Vec.iter self.h ~f:(fun h -> l := h x :: !l); !l let emit_iter self x ~f = - Vec.rev_iter self.h ~f:(fun h -> + Vec.iter self.h ~f:(fun h -> let y = h x in f y) From c8800fe3e2342ec30f02a0ee255d3c5299e9e100 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 22 Jul 2022 21:45:56 -0400 Subject: [PATCH 018/174] promote test results --- doc/guide.md | 12 ++++++------ src/tests/regression/reg_model_lra1.out.expected | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/guide.md b/doc/guide.md index e9c7c225..7067c4d8 100644 --- a/doc/guide.md +++ b/doc/guide.md @@ -239,7 +239,7 @@ whether the assertions and hypotheses are satisfiable together. Solver.mk_lit_t solver q ~sign:false];; - : Solver.res = Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_proof_step = } + {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } ``` Here it's unsat, because we asserted "p = q", and then assumed "p" @@ -296,7 +296,7 @@ val q_imp_not_r : Term.t = (=> q (not r)) # Solver.solve ~assumptions:[] solver;; - : Solver.res = Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_proof_step = } + {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } ``` This time we got _unsat_ and there is no way of undoing it. @@ -359,10 +359,10 @@ val b_leq_half : Term.t = (<= b 1/2) Solver.mk_lit_t solver b_leq_half];; val res : Solver.res = Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_proof_step = } + {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } # match res with Solver.Unsat {unsat_core=us; _} -> us() |> Iter.to_list | _ -> assert false;; -- : Proof.lit list = [(>= a 1); (<= b 1/2)] +- : Lit.t list = [(>= a 1); (<= b 1/2)] ``` This just showed that `a=1, b=1/2, a>=b` is unsatisfiable. @@ -428,13 +428,13 @@ val appf1 : Term.t list -> Term.t = ~assumptions:[Solver.mk_lit_t solver ~sign:false (Term.eq tstore u1 (appf1[u1]))];; - : Solver.res = Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_proof_step = } + {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } # Solver.solve solver ~assumptions:[Solver.mk_lit_t solver ~sign:false (Term.eq tstore u2 u3)];; - : Solver.res = Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_proof_step = } + {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } ``` Assuming: `f1(u1)=u2, f1(u2)=u3, f1^2(u1)=u1, f1^3(u1)=u1`, diff --git a/src/tests/regression/reg_model_lra1.out.expected b/src/tests/regression/reg_model_lra1.out.expected index 1f30f689..7a2ad496 100644 --- a/src/tests/regression/reg_model_lra1.out.expected +++ b/src/tests/regression/reg_model_lra1.out.expected @@ -2,8 +2,8 @@ (true := true) (false := false) (a := 5/3) - ((* 3 a) := 0) - (5 := 0) + ((* 3 a) := 5) + (5 := 5) ((= (* 3 a) 5) := true) ((<= (* 3 a) 5) := true) ((>= (* 3 a) 5) := true)) From 2922cca78f8e3854c77f9fd828f8090c8d6a0647 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 22 Jul 2022 21:54:22 -0400 Subject: [PATCH 019/174] fix: proper negation when raising an acyclicity conflict --- src/th-data/Sidekick_th_data.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index bcf2b0b6..1c02d6be 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -630,7 +630,9 @@ module Make (A : ARG) : S with module A = A = struct k "(@[%s.acyclicity.raise_confl@ %a@ @[:path %a@]@])" name Expl.pp expl pp_path path); let lits, pr = SI.cc_resolve_expl solver expl in - SI.raise_conflict solver acts lits pr + (* negate lits *) + let c = List.rev_map SI.Lit.neg lits in + SI.raise_conflict solver acts c pr | { flag = New; _ } as node_r -> node_r.flag <- Open; let path = (n, node_r) :: path in From 4a6237191e3141938d191bf2df0ec9230c6e1e52 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 22 Jul 2022 22:16:04 -0400 Subject: [PATCH 020/174] wip: try to restore old model construction --- src/smt-solver/Sidekick_smt_solver.ml | 39 ++++++++++++++++++--------- 1 file changed, 27 insertions(+), 12 deletions(-) diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml index c8b439dd..d2b3ce84 100644 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ b/src/smt-solver/Sidekick_smt_solver.ml @@ -627,16 +627,28 @@ module Make (A : ARG) : (** {2 Model construction and theory combination} *) (* make model from the congruence closure *) - let mk_model_ (self : t) : Model.t = + let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = Log.debug 1 "(smt.solver.mk-model)"; Profile.with_ "smt-solver.mk-model" @@ fun () -> let module M = Term.Tbl in - let { cc = (lazy cc); model_ask = model_ask_hooks; model_complete; _ } = + let { + cc = (lazy cc); + tst; + model_ask = model_ask_hooks; + model_complete; + _; + } = self in let model = M.create 128 in + (* first, add all literals to the model using the given propositional model + [lits]. *) + lits (fun lit -> + let t, sign = Lit.signed_term lit in + M.replace model t (Term.bool tst sign)); + (* populate with information from the CC *) (* FIXME CC.get_model_for_each_class cc (fun (_, ts, v) -> @@ -681,13 +693,16 @@ module Make (A : ARG) : in let t_val = - match - (* look for a value in the model for any term in the class *) - N.iter_class repr - |> Iter.find_map (fun n -> M.get model (N.term n)) - with - | Some v -> v - | None -> try_hooks_ model_ask_hooks + try_hooks_ model_ask_hooks + (* FIXME: the more complete version? + match + (* look for a value in the model for any term in the class *) + N.iter_class repr + |> Iter.find_map (fun n -> M.get model (N.term n)) + with + | Some v -> v + | None -> try_hooks_ model_ask_hooks + *) in M.replace model (N.term repr) t_val; @@ -708,7 +723,7 @@ module Make (A : ARG) : (* do theory combination using the congruence closure. Each theory can merge classes, *) - let check_th_combination_ (self : t) (acts : theory_actions) : + let check_th_combination_ (self : t) (_acts : theory_actions) lits : (Model.t, th_combination_conflict) result = (* FIXME @@ -733,7 +748,7 @@ module Make (A : ARG) : Ok m with Semantic_conflict c -> Error c *) - let m = mk_model_ self in + let m = mk_model_ self lits in Ok m (* call congruence closure, perform the actions it scheduled *) @@ -772,7 +787,7 @@ module Make (A : ARG) : List.iter (fun f -> f self acts lits) self.on_final_check; check_cc_with_acts_ self acts; - (match check_th_combination_ self acts with + (match check_th_combination_ self acts lits with | Ok m -> self.last_model <- Some m | Error { lits; semantic } -> (* bad model, we add a clause to remove it *) From 0e5bde0f4081f8c4f29ce811e7dbb532ba583fe5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 23 Jul 2022 00:24:56 -0400 Subject: [PATCH 021/174] detail --- src/smt-solver/Sidekick_smt_solver.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml index d2b3ce84..c44b5f83 100644 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ b/src/smt-solver/Sidekick_smt_solver.ml @@ -3,7 +3,7 @@ Sidekick_sat (in src/sat/) is a modular SAT solver in pure OCaml. - This builds a {!Sidekick_core.SOLVER} on top of it. + This builds a SMT solver on top of it. *) (** Argument to pass to the functor {!Make} in order to create a From 410c5b1ee2c43df17963b952cdbc6dac521667bb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 21:41:00 -0400 Subject: [PATCH 022/174] feat: start core-ast library this will be the foundation of types and terms in sidekick. It shall implement barebone calculus-of-constructions. --- src/core-ast/Hashcons.ml | 34 ++ src/core-ast/ast.ml | 689 ++++++++++++++++++++++++++++++ src/core-ast/ast.mli | 139 ++++++ src/core-ast/const.ml | 26 ++ src/core-ast/const.mli | 19 + src/core-ast/dune | 6 + src/core-ast/sidekick_core_ast.ml | 2 + 7 files changed, 915 insertions(+) create mode 100644 src/core-ast/Hashcons.ml create mode 100644 src/core-ast/ast.ml create mode 100644 src/core-ast/ast.mli create mode 100644 src/core-ast/const.ml create mode 100644 src/core-ast/const.mli create mode 100644 src/core-ast/dune create mode 100644 src/core-ast/sidekick_core_ast.ml diff --git a/src/core-ast/Hashcons.ml b/src/core-ast/Hashcons.ml new file mode 100644 index 00000000..28ca6e21 --- /dev/null +++ b/src/core-ast/Hashcons.ml @@ -0,0 +1,34 @@ +module type ARG = sig + type t + + val equal : t -> t -> bool + val hash : t -> int + val set_id : t -> int -> unit +end + +module Make (A : ARG) : sig + type t + + val create : ?size:int -> unit -> t + val hashcons : t -> A.t -> A.t + val size : t -> int + val to_iter : t -> A.t Iter.t +end = struct + module W = Weak.Make (A) + + type t = { tbl: W.t; mutable n: int } + + let create ?(size = 1024) () : t = { tbl = W.create size; n = 0 } + + (* hashcons terms *) + let hashcons st t = + let t' = W.merge st.tbl t in + if t == t' then ( + st.n <- 1 + st.n; + A.set_id t' st.n + ); + t' + + let size st = W.count st.tbl + let to_iter st yield = W.iter yield st.tbl +end diff --git a/src/core-ast/ast.ml b/src/core-ast/ast.ml new file mode 100644 index 00000000..b8910661 --- /dev/null +++ b/src/core-ast/ast.ml @@ -0,0 +1,689 @@ +(** Core AST *) + +module Const = Const +module H = CCHash + +type view = + | E_type of int + | E_var of var + | E_bound_var of bvar + | E_const of Const.t * t (* ty *) + | E_app of t * t + | E_lam of string * t * t + | E_pi of string * t * t + +and var = { v_name: string; v_ty: t } +and bvar = { bv_idx: int; bv_ty: t } + +and t = { + view: view; + (* computed on demand *) + mutable ty: t option; + mutable id: int; + (* contains: [highest DB var | 1:has free vars | 5:ctx uid] *) + mutable flags: int; +} + +type term = t + +(* 5 bits in [t.id] are used to store which store it belongs to, so we have + a chance of detecting when the user passes a term to the wrong store *) +let store_id_bits = 5 + +(* mask to access the store id *) +let store_id_mask = (1 lsl store_id_bits) - 1 +let[@inline] view (e : t) : view = e.view +let[@inline] equal (e1 : t) e2 : bool = e1 == e2 +let[@inline] hash (e : t) = H.int e.id +let[@inline] compare (e1 : t) e2 : int = CCInt.compare e1.id e2.id +let[@inline] db_depth e = e.flags lsr (1 + store_id_bits) +let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 +let[@inline] store_uid e : int = e.flags land store_id_mask +let[@inline] is_closed e : bool = db_depth e == 0 + +let[@inline] ty_exn e : t = + match e.ty with + | Some x -> x + | None -> assert false + +let pp_debug_ = ref (fun _ _ -> assert false) + +module Var = struct + type t = var + + let compare a b : int = + if equal a.v_ty b.v_ty then + String.compare a.v_name b.v_name + else + compare a.v_ty b.v_ty + + let[@inline] name v = v.v_name + let[@inline] ty self = self.v_ty + let[@inline] equal v1 v2 = v1.v_name = v2.v_name && equal v1.v_ty v2.v_ty + let[@inline] hash v1 = H.combine3 5 (H.string v1.v_name) (hash v1.v_ty) + let[@inline] pp out v1 = Fmt.string out v1.v_name + let make v_name v_ty : t = { v_name; v_ty } + let makef fmt ty = Fmt.kasprintf (fun s -> make s ty) fmt + + let pp_with_ty out v = + Fmt.fprintf out "(@[%s :@ %a@])" v.v_name !pp_debug_ v.v_ty + + module AsKey = struct + type nonrec t = t + + let equal = equal + let compare = compare + let hash = hash + end + + module Map = CCMap.Make (AsKey) + module Set = CCSet.Make (AsKey) + module Tbl = CCHashtbl.Make (AsKey) +end + +module BVar = struct + type t = bvar + + let equal (v1 : t) v2 = v1.bv_idx = v2.bv_idx && equal v1.bv_ty v2.bv_ty + let hash v = H.combine2 (H.int v.bv_idx) (hash v.bv_ty) + let pp out v = Fmt.fprintf out "bv[%d]" v.bv_idx + let[@inline] ty self = self.bv_ty + let make i ty : t = { bv_idx = i; bv_ty = ty } +end + +(* open an application *) +let unfold_app (e : t) : t * t list = + let[@unroll 1] rec aux acc e = + match e.view with + | E_app (f, a) -> aux (a :: acc) f + | _ -> e, acc + in + aux [] e + +(* debug printer *) +let expr_pp_with_ ~pp_ids ~max_depth out (e : t) : unit = + let rec loop k ~depth names out e = + let pp' = loop' k ~depth:(depth + 1) names in + (match e.view with + | E_type 0 -> Fmt.string out "type" + | E_type i -> Fmt.fprintf out "type_%d" i + | E_var v -> Fmt.string out v.v_name + (* | E_var v -> Fmt.fprintf out "(@[%s : %a@])" v.v_name pp v.v_ty *) + | E_bound_var v -> + let idx = v.bv_idx in + (match CCList.nth_opt names idx with + | Some n when n <> "" -> Fmt.string out n + | _ -> + if idx < k then + Fmt.fprintf out "x_%d" (k - idx - 1) + else + Fmt.fprintf out "%%db_%d" (idx - k)) + | E_const (c, _) -> Const.pp out c + | (E_app _ | E_lam _) when depth > max_depth -> + Fmt.fprintf out "@<1>…/%d" e.id + | E_app _ -> + let f, args = unfold_app e in + Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args + | E_lam ("", _ty, bod) -> + Fmt.fprintf out "(@[\\x_%d:@[%a@].@ %a@])" k pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_lam (n, _ty, bod) -> + Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod + | E_pi ("", _ty, bod) -> + Fmt.fprintf out "(@[Pi x_%d:@[%a@].@ %a@])" k pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_pi (n, _ty, bod) -> + Fmt.fprintf out "(@[Pi %s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod); + if pp_ids then Fmt.fprintf out "/%d" e.id + and loop' k ~depth names out e = + match e.view with + | E_type _ | E_var _ | E_bound_var _ | E_const _ -> + loop k ~depth names out e (* atomic expr *) + | E_app _ | E_lam _ | E_pi _ -> + Fmt.fprintf out "(%a)" (loop k ~depth names) e + in + Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e + +let pp_debug = expr_pp_with_ ~pp_ids:false ~max_depth:max_int +let pp_debug_with_ids = expr_pp_with_ ~pp_ids:true ~max_depth:max_int +let () = pp_debug_ := pp_debug + +module AsKey = struct + type nonrec t = t + + let equal = equal + let compare = compare + let hash = hash +end + +module Map = CCMap.Make (AsKey) +module Set = CCSet.Make (AsKey) +module Tbl = CCHashtbl.Make (AsKey) + +module Hcons = Hashcons.Make (struct + type nonrec t = t + + let equal a b = + match a.view, b.view with + | E_type i, E_type j -> i = j + | E_const (c1, ty1), E_const (c2, ty2) -> Const.equal c1 c2 && equal ty1 ty2 + | E_var v1, E_var v2 -> Var.equal v1 v2 + | E_bound_var v1, E_bound_var v2 -> BVar.equal v1 v2 + | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 + | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> + equal ty1 ty2 && equal bod1 bod2 + | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ | E_lam _ + | E_pi _ ), + _ ) -> + false + + let hash e : int = + match e.view with + | E_type i -> H.combine2 10 (H.int i) + | E_const (c, ty) -> H.combine3 20 (Const.hash c) (hash ty) + | E_var v -> H.combine2 30 (Var.hash v) + | E_bound_var v -> H.combine2 40 (BVar.hash v) + | E_app (f, a) -> H.combine3 50 (hash f) (hash a) + | E_lam (_, ty, bod) -> H.combine3 60 (hash ty) (hash bod) + | E_pi (_, ty, bod) -> H.combine3 70 (hash ty) (hash bod) + + let set_id t id = + assert (t.id == -1); + t.id <- id +end) + +module Store = struct + type t = { (* unique ID for this store *) + s_uid: int; s_exprs: Hcons.t } + + (* TODO: use atomic? CCAtomic? *) + let n = ref 0 + + let create () : t = + let s_uid = !n in + incr n; + { s_uid; s_exprs = Hcons.create ~size:256 () } + + (* check that [e] belongs in this store *) + let[@inline] check_e_uid (self : t) (e : term) = + assert (self.s_uid == store_uid e) +end + +type store = Store.t + +let iter_shallow ~f (e : t) : unit = + match e.view with + | E_type _ -> () + | _ -> + (match e.ty with + | None -> (* should be computed at build time *) assert false + | Some ty -> f false ty); + (match e.view with + | E_const _ -> () + | E_type _ -> assert false + | E_var v -> f false v.v_ty + | E_bound_var v -> f false v.bv_ty + | E_app (hd, a) -> + f false hd; + f false a + | E_lam (_, tyv, bod) | E_pi (_, tyv, bod) -> + f false tyv; + f true bod) + +let map_shallow_ ~make ~f (e : t) : t = + match view e with + | E_type _ | E_const _ -> e + | E_var v -> + let v_ty = f false v.v_ty in + if v_ty == v.v_ty then + e + else + make (E_var { v with v_ty }) + | E_bound_var v -> + let ty' = f false v.bv_ty in + if v.bv_ty == ty' then + e + else + make (E_bound_var { v with bv_ty = ty' }) + | E_app (hd, a) -> + let hd' = f false hd in + let a' = f false a in + if a == a' && hd == hd' then + e + else + make (E_app (f false hd, f false a)) + | E_lam (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make (E_lam (n, tyv', bod')) + | E_pi (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make (E_pi (n, tyv', bod')) + +(* TODO + (* map immediate subterms *) + let map_shallow ctx ~f (e : t) : t = + match view e with + | E_kind | E_type | E_const (_, []) | E_box _ -> e + | _ -> + let ty' = + lazy + (match e.e_ty with + | (lazy None) -> None + | (lazy (Some ty)) -> Some (f false ty)) + in + (match view e with + | E_var v -> + let v_ty = f false v.v_ty in + if v_ty == v.v_ty then + e + else + make_ ctx (E_var { v with v_ty }) ty' + | E_const (c, args) -> + let args' = List.map (f false) args in + if List.for_all2 equal args args' then + e + else + make_ ctx (E_const (c, args')) ty' + | E_bound_var v -> + let ty' = f false v.bv_ty in + if v.bv_ty == ty' then + e + else + make_ ctx + (E_bound_var { v with bv_ty = ty' }) + (Lazy.from_val (Some ty')) + | E_app (hd, a) -> + let hd' = f false hd in + let a' = f false a in + if a == a' && hd == hd' then + e + else + make_ ctx (E_app (f false hd, f false a)) ty' + | E_lam (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make_ ctx (E_lam (n, tyv', bod')) ty' + | E_arrow (a, b) -> + let a' = f false a in + let b' = f false b in + if a == a' && b == b' then + e + else + make_ ctx (E_arrow (a', b')) ty' + | E_kind | E_type | E_box _ -> assert false) +*) + +exception IsSub + +let[@inline] is_type_ e = + match e.view with + | E_type _ -> true + | _ -> false + +let[@inline] is_a_type e = is_type_ e || is_type_ (ty_exn e) + +let iter_dag ?(seen = Tbl.create 8) ~iter_ty ~f e : unit = + let rec loop e = + if not (Tbl.mem seen e) then ( + Tbl.add seen e (); + if iter_ty && not (is_type_ e) then loop (ty_exn e); + f e; + iter_shallow e ~f:(fun _ u -> loop u) + ) + in + loop e + +exception E_exit + +let exists_shallow ~f e : bool = + try + iter_shallow e ~f:(fun b x -> if f b x then raise_notrace E_exit); + false + with E_exit -> true + +let for_all_shallow ~f e : bool = + try + iter_shallow e ~f:(fun b x -> if not (f b x) then raise_notrace E_exit); + true + with E_exit -> false + +let contains e ~sub : bool = + try + iter_dag ~iter_ty:true e ~f:(fun e' -> + if equal e' sub then raise_notrace IsSub); + false + with IsSub -> true + +let free_vars_iter e : var Iter.t = + fun yield -> + iter_dag ~iter_ty:true e ~f:(fun e' -> + match view e' with + | E_var v -> yield v + | _ -> ()) + +let free_vars ?(init = Var.Set.empty) e : Var.Set.t = + let set = ref init in + free_vars_iter e (fun v -> set := Var.Set.add v !set); + !set + +module Make_ = struct + let compute_db_depth_ e : int = + let d1 = + match e.ty with + | None -> 0 + | Some d -> db_depth d + in + let d2 = + match view e with + | E_type _ | E_const _ | E_var _ -> 0 + | E_bound_var v -> v.bv_idx + 1 + | E_app (a, b) -> max (db_depth a) (db_depth b) + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> + max (db_depth ty) (max 0 (db_depth bod - 1)) + in + max d1 d2 + + let compute_has_fvars_ e : bool = + (if is_type_ e then + false + else + has_fvars (ty_exn e)) + || + match view e with + | E_var _ -> true + | E_type _ | E_bound_var _ | E_const _ -> false + | E_app (a, b) -> has_fvars a || has_fvars b + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod + + let universe_ (e : t) : int = + match e.view with + | E_type i -> i + | _ -> assert false + + let[@inline] universe_of_ty_ (e : t) : int = + match e.view with + | E_type i -> i + 1 + | _ -> universe_ (ty_exn e) + + module T_int_tbl = CCHashtbl.Make (struct + type t = term * int + + let equal (t1, k1) (t2, k2) = equal t1 t2 && k1 == k2 + let hash (t, k) = H.combine3 27 (hash t) (H.int k) + end) + + let db_shift_ ~make (e : t) (n : int) = + let rec loop e k : t = + if is_closed e then + e + else if is_a_type e then + e + else ( + match view e with + | E_bound_var bv -> + if bv.bv_idx >= k then + make (E_bound_var (BVar.make (bv.bv_idx + n) bv.bv_ty)) + else + e + | _ -> + map_shallow_ e ~make ~f:(fun inbind u -> + loop u + (if inbind then + k + 1 + else + k)) + ) + in + assert (n >= 0); + if n = 0 || is_closed e then + e + else + loop e 0 + + (* replace DB0 in [e] with [u] *) + let db_0_replace_ ~make e ~by:u : t = + let cache_ = T_int_tbl.create 8 in + + let rec aux e k : t = + if is_a_type e then + e + else if db_depth e < k then + e + else ( + match view e with + | E_const _ -> e + | E_bound_var bv when bv.bv_idx = k -> + (* replace here *) + db_shift_ ~make u k + | _ -> + (* use the cache *) + (try T_int_tbl.find cache_ (e, k) + with Not_found -> + let r = + map_shallow_ e ~make ~f:(fun inb u -> + aux u + (if inb then + k + 1 + else + k)) + in + T_int_tbl.add cache_ (e, k) r; + r) + ) + in + if is_closed e then + e + else + aux e 0 + + type subst = { m: t Var.Map.t } [@@unboxed] + + let subst_ ~make ~recursive e0 (subst : subst) : t = + (* cache for types and some terms *) + let cache_ = T_int_tbl.create 16 in + + let rec loop k e = + try T_int_tbl.find cache_ (e, k) + with Not_found -> + let r = loop_uncached_ k e in + T_int_tbl.add cache_ (e, k) r; + r + and loop_uncached_ k (e : t) : t = + match view e with + | _ when not (has_fvars e) -> e (* nothing to subst in *) + | E_var v -> + (* first, subst in type *) + let v = { v with v_ty = loop k v.v_ty } in + (match Var.Map.find v subst.m with + | u -> + let u = db_shift_ ~make u k in + if recursive then + loop 0 u + else + u + | exception Not_found -> make (E_var v)) + | E_const _ -> e + | _ -> + map_shallow_ e ~make ~f:(fun inb u -> + loop + (if inb then + k + 1 + else + k) + u) + in + + if Var.Map.is_empty subst.m then + e0 + else + loop 0 e0 + + let compute_ty_ ~make (view : view) : t = + match view with + | E_var v -> Var.ty v + | E_bound_var v -> BVar.ty v + | E_type i -> make (E_type (i + 1)) + | E_const (_, ty) -> ty + | E_lam (name, ty, bod) -> + (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) + let ty_bod = ty_exn bod in + make (E_pi (name, ty, db_shift_ ~make ty_bod 1)) + | E_app (f, a) -> + (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], + is [ty_bod_f[x := a]] *) + let ty_f = ty_exn f in + let ty_a = ty_exn a in + (match ty_f.view with + | E_pi (_, ty_arg_f, ty_bod_f) -> + (* check that the expected type matches *) + if not (equal ty_arg_f ty_a) then + Error.errorf + "@[<2>cannot apply %a to %a,@ expected argument type: %a@ actual: \ + %a@]" + pp_debug f pp_debug a pp_debug ty_arg_f pp_debug ty_a; + db_0_replace_ ~make ty_bod_f ~by:a + | _ -> + Error.errorf + "@[<2>cannot apply %a,@ must have Pi type, but actual type is %a@]" + pp_debug f pp_debug ty_f) + | E_pi (_, ty, bod) -> + let u = max (universe_ ty) (universe_of_ty_ bod) + 1 in + make (E_type u) + + (* hashconsing + computing metadata + computing type (for new terms) *) + let rec make_ (store : store) view : t = + let e = { view; ty = None; id = -1; flags = 0 } in + let e2 = Hcons.hashcons store.s_exprs e in + if e == e2 then ( + (* new term, compute metadata *) + assert (store.s_uid land store_id_mask == store.s_uid); + let has_fvars = compute_has_fvars_ e in + e2.flags <- + (compute_db_depth_ e lsl (1 + store_id_bits)) + lor (if has_fvars then + 1 lsl store_id_bits + else + 0) + lor store.s_uid; + Store.check_e_uid store e2; + + if not (is_type_ e) then ( + let ty = compute_ty_ ~make:(make_ store) view in + e.ty <- Some ty + ) + ); + e2 + + let type_of_univ store i : t = make_ store (E_type i) + let type_ store : t = type_of_univ store 0 + let var store v : t = make_ store (E_var v) + let var_str store name ~ty : t = var store (Var.make name ty) + let bvar store v : t = make_ store (E_bound_var v) + let app store f a = make_ store (E_app (f, a)) + let app_l store f l = List.fold_left (app store) f l + + let abs_on_ (store : store) (v : var) (e : t) : t = + Store.check_e_uid store v.v_ty; + Store.check_e_uid store e; + if not (is_closed v.v_ty) then + Error.errorf "cannot abstract on variable@ with non closed type %a" + pp_debug v.v_ty; + let db0 = bvar store (BVar.make 0 v.v_ty) in + let body = db_shift_ ~make:(make_ store) e 1 in + subst_ ~make:(make_ store) ~recursive:false body + { m = Var.Map.singleton v db0 } + + let lam store v bod : t = + let bod' = abs_on_ store v bod in + make_ store (E_lam (Var.name v, Var.ty v, bod')) + + let pi store v bod : t = + let bod' = abs_on_ store v bod in + make_ store (E_pi (Var.name v, Var.ty v, bod')) + + let arrow store a b : t = + let b' = db_shift_ ~make:(make_ store) b 1 in + make_ store (E_pi ("", a, b')) + + let arrow_l store args ret = List.fold_right (arrow store) args ret + + (* find a name that doesn't capture a variable of [e] *) + let pick_name_ (name0 : string) (e : t) : string = + let rec loop i = + let name = + if i = 0 then + name0 + else + Printf.sprintf "%s%d" name0 i + in + if free_vars_iter e |> Iter.exists (fun v -> v.v_name = name) then + loop (i + 1) + else + name + in + loop 0 + + let open_lambda store e : _ option = + match view e with + | E_lam (name, ty, bod) -> + let name = pick_name_ name bod in + let v = Var.make name ty in + let bod' = db_0_replace_ bod ~make:(make_ store) ~by:(var store v) in + Some (v, bod') + | _ -> None + + let open_lambda_exn store e = + match open_lambda store e with + | Some tup -> tup + | None -> Error.errorf "open-lambda: term is not a lambda:@ %a" pp_debug e +end + +include Make_ + +let get_ty store e : t = + match e.view with + | E_type i -> type_of_univ store (i + 1) + | _ -> ty_exn e + +module Subst = struct + type t = subst + + let empty = { m = Var.Map.empty } + let is_empty self = Var.Map.is_empty self.m + let add v t self = { m = Var.Map.add v t self.m } + + let pp out (self : t) = + if is_empty self then + Fmt.string out "(subst)" + else ( + let pp_pair out (v, t) = + Fmt.fprintf out "(@[%a := %a@])" Var.pp v pp_debug t + in + Fmt.fprintf out "(@[subst@ %a@])" (Util.pp_iter pp_pair) + (Var.Map.to_iter self.m) + ) + + let of_list l = { m = Var.Map.of_list l } + let of_iter it = { m = Var.Map.of_iter it } + let to_iter self = Var.Map.to_iter self.m + + let apply (store : store) ~recursive (self : t) (e : term) : term = + subst_ ~make:(make_ store) ~recursive e self +end diff --git a/src/core-ast/ast.mli b/src/core-ast/ast.mli new file mode 100644 index 00000000..21647dc3 --- /dev/null +++ b/src/core-ast/ast.mli @@ -0,0 +1,139 @@ +(** Core AST. + + The core AST is composed of expressions in the calculus of constructions, + with no universe polymorphism nor cumulativity. It should be fast, with hashconsing; + and simple enough (no inductives, no universe trickery). + + It is intended to be the foundation for user-level terms and types and formulas. +*) + +module Const = Const + +(** {2 Main declarations} *) + +type t +(** An AST node, i.e. an expression in the calculus of constructions *) + +type term = t +type var = { v_name: string; v_ty: t } +type bvar = { bv_idx: int; bv_ty: t } + +type store +(** The store for these AST nodes. + + The store is responsible for allocating unique IDs to terms, and + enforcing their hashconsing (so that syntactic equality is just a pointer + comparison). *) + +(** View. + + A view is the shape of the root node of an AST. *) +type view = + | E_type of int + | E_var of var + | E_bound_var of bvar + | E_const of Const.t * t (* ty *) + | E_app of t * t + | E_lam of string * t * t + | E_pi of string * t * t + +include EQ_ORD_HASH with type t := t + +val pp_debug : t Fmt.printer +val pp_debug_with_ids : t Fmt.printer + +(** {2 Variables} *) + +(** Free variable *) +module Var : sig + type t = var + + include EQ_ORD_HASH_PRINT with type t := t + + val pp_with_ty : t Fmt.printer + val make : string -> term -> t + val makef : ('a, Format.formatter, unit, t) format4 -> term -> 'a + val name : t -> string + val ty : t -> term + + include WITH_SET_MAP_TBL with type t := t +end + +(** Bound variable *) +module BVar : sig + type t = bvar + + include EQ_HASH_PRINT with type t := t + + val make : int -> term -> t + val ty : t -> term +end + +(** {2 Containers} *) + +include WITH_SET_MAP_TBL with type t := t + +(** {2 Utils} *) + +val view : t -> view +val unfold_app : t -> t * t list +val iter_dag : ?seen:unit Tbl.t -> iter_ty:bool -> f:(t -> unit) -> t -> unit + +val iter_shallow : f:(bool -> t -> unit) -> t -> unit +(** [iter_shallow f e] iterates on immediate subterms of [e], + calling [f trdb e'] for each subterm [e'], with [trdb = true] iff + [e'] is directly under a binder. *) + +val exists_shallow : f:(bool -> t -> bool) -> t -> bool +val for_all_shallow : f:(bool -> t -> bool) -> t -> bool +val contains : t -> sub:t -> bool +val free_vars_iter : t -> var Iter.t +val free_vars : ?init:Var.Set.t -> t -> Var.Set.t + +val is_closed : t -> bool +(** Is the term closed (all bound variables are paired with a binder)? + time: O(1) *) + +val has_fvars : t -> bool +(** Does the term contain free variables? + time: O(1) *) + +(** {2 Creation} *) + +module Store : sig + type t = store + + val create : unit -> t +end + +val type_ : store -> t +val type_of_univ : store -> int -> t +val var : store -> var -> t +val var_str : store -> string -> ty:t -> t +val app : store -> t -> t -> t +val app_l : store -> t -> t list -> t +val lam : store -> var -> t -> t +val pi : store -> var -> t -> t +val arrow : store -> t -> t -> t +val arrow_l : store -> t list -> t -> t +val open_lambda : store -> t -> (var * t) option +val open_lambda_exn : store -> t -> var * t + +val get_ty : store -> t -> t +(** [get_ty store t] gets the type of [t], or computes it on demand + in case [t] is itself a type. *) + +(** Substitutions *) +module Subst : sig + type t + + include PRINT with type t := t + + val empty : t + val is_empty : t -> bool + val of_list : (var * term) list -> t + val of_iter : (var * term) Iter.t -> t + val to_iter : t -> (var * term) Iter.t + val add : var -> term -> t -> t + val apply : store -> recursive:bool -> t -> term -> term +end diff --git a/src/core-ast/const.ml b/src/core-ast/const.ml new file mode 100644 index 00000000..19f0ead6 --- /dev/null +++ b/src/core-ast/const.ml @@ -0,0 +1,26 @@ +type view = .. + +module type DYN_OPS = sig + val pp : view Fmt.printer + val equal : view -> view -> bool + val hash : view -> int +end + +type ops = (module DYN_OPS) +type t = { view: view; ops: ops } + +let view self = self.view + +let equal (a : t) b = + let (module O) = a.ops in + O.equal a.view b.view + +let hash (a : t) : int = + let (module O) = a.ops in + O.hash a.view + +let pp out (a : t) = + let (module O) = a.ops in + O.pp out a.view + +let make view ops : t = { view; ops } diff --git a/src/core-ast/const.mli b/src/core-ast/const.mli new file mode 100644 index 00000000..b74550d4 --- /dev/null +++ b/src/core-ast/const.mli @@ -0,0 +1,19 @@ +(** Constants. + + Constants are logical symbols, defined by the user thanks to an open type *) + +type t +type view = .. + +module type DYN_OPS = sig + val pp : view Fmt.printer + val equal : view -> view -> bool + val hash : view -> int +end + +type ops = (module DYN_OPS) + +val view : t -> view +val make : view -> ops -> t + +include EQ_HASH_PRINT with type t := t diff --git a/src/core-ast/dune b/src/core-ast/dune new file mode 100644 index 00000000..127c083b --- /dev/null +++ b/src/core-ast/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_core_ast) + (public_name sidekick.core-ast) + (synopsis "Core AST for logic terms and types") + (flags :standard -w +32 -open Sidekick_sigs -open Sidekick_util) + (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/core-ast/sidekick_core_ast.ml b/src/core-ast/sidekick_core_ast.ml new file mode 100644 index 00000000..7ec71480 --- /dev/null +++ b/src/core-ast/sidekick_core_ast.ml @@ -0,0 +1,2 @@ +module Ast = Ast +include Ast From e52a7ac0eae87735a5ce946040b7e6cc3e6d0fed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 21:41:59 -0400 Subject: [PATCH 023/174] test: add basic unit-test for core-ast --- unittest/core-ast/dune | 4 ++++ unittest/core-ast/t1.expected | 4 ++++ unittest/core-ast/t1.ml | 13 +++++++++++++ 3 files changed, 21 insertions(+) create mode 100644 unittest/core-ast/dune create mode 100644 unittest/core-ast/t1.expected create mode 100644 unittest/core-ast/t1.ml diff --git a/unittest/core-ast/dune b/unittest/core-ast/dune new file mode 100644 index 00000000..a32c666e --- /dev/null +++ b/unittest/core-ast/dune @@ -0,0 +1,4 @@ +(tests + (names t1) + (flags :standard -open Sidekick_util) + (libraries containers sidekick.util sidekick.core-ast)) diff --git a/unittest/core-ast/t1.expected b/unittest/core-ast/t1.expected new file mode 100644 index 00000000..41db5eae --- /dev/null +++ b/unittest/core-ast/t1.expected @@ -0,0 +1,4 @@ +type0 : type +typeof(type0) : type_1 +type tower: [type;type_1;type_2;type_3;type_4;type_5;type_6;type_7;type_8; + type_9] diff --git a/unittest/core-ast/t1.ml b/unittest/core-ast/t1.ml new file mode 100644 index 00000000..c599fcdf --- /dev/null +++ b/unittest/core-ast/t1.ml @@ -0,0 +1,13 @@ +open Sidekick_core_ast + +let store = Store.create () +let t0 = type_ store +let () = Fmt.printf "type0 : %a@." pp_debug t0 +let () = Fmt.printf "typeof(type0) : %a@." pp_debug (get_ty store t0) + +let l = + CCSeq.unfold (fun ty -> Some (ty, get_ty store ty)) t0 + |> CCSeq.take 10 |> CCSeq.to_list + +let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list pp_debug) l +let () = assert (equal (type_ store) (type_ store)) From 8950601fb2a4c8260914777af3a2681803e39a33 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 22:40:16 -0400 Subject: [PATCH 024/174] fix(core-ast): fix some issues in type computations; print arrows --- src/core-ast/ast.ml | 74 ++++++++++++++++++------------- src/core-ast/ast.mli | 12 +++-- src/core-ast/sidekick_core_ast.ml | 1 + 3 files changed, 51 insertions(+), 36 deletions(-) diff --git a/src/core-ast/ast.ml b/src/core-ast/ast.ml index b8910661..961b84aa 100644 --- a/src/core-ast/ast.ml +++ b/src/core-ast/ast.ml @@ -40,14 +40,13 @@ let[@inline] db_depth e = e.flags lsr (1 + store_id_bits) let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 let[@inline] store_uid e : int = e.flags land store_id_mask let[@inline] is_closed e : bool = db_depth e == 0 +let pp_debug_ = ref (fun _ _ -> assert false) let[@inline] ty_exn e : t = match e.ty with | Some x -> x | None -> assert false -let pp_debug_ = ref (fun _ _ -> assert false) - module Var = struct type t = var @@ -132,6 +131,13 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : t) : unit = Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty (loop (k + 1) ~depth:(depth + 1) (n :: names)) bod + | E_pi (_, ty, bod) when is_closed bod -> + (* actually just an arrow *) + Fmt.fprintf out "(@[%a@ -> %a@])" + (loop k ~depth:(depth + 1) names) + ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod | E_pi ("", _ty, bod) -> Fmt.fprintf out "(@[Pi x_%d:@[%a@].@ %a@])" k pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) @@ -385,32 +391,32 @@ let free_vars ?(init = Var.Set.empty) e : Var.Set.t = module Make_ = struct let compute_db_depth_ e : int = - let d1 = - match e.ty with - | None -> 0 - | Some d -> db_depth d - in - let d2 = - match view e with - | E_type _ | E_const _ | E_var _ -> 0 - | E_bound_var v -> v.bv_idx + 1 - | E_app (a, b) -> max (db_depth a) (db_depth b) - | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> - max (db_depth ty) (max 0 (db_depth bod - 1)) - in - max d1 d2 + if is_type_ e then + 0 + else ( + let d1 = db_depth @@ ty_exn e in + let d2 = + match view e with + | E_type _ | E_const _ | E_var _ -> 0 + | E_bound_var v -> v.bv_idx + 1 + | E_app (a, b) -> max (db_depth a) (db_depth b) + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> + max (db_depth ty) (max 0 (db_depth bod - 1)) + in + max d1 d2 + ) let compute_has_fvars_ e : bool = - (if is_type_ e then + if is_type_ e then false else - has_fvars (ty_exn e)) - || - match view e with - | E_var _ -> true - | E_type _ | E_bound_var _ | E_const _ -> false - | E_app (a, b) -> has_fvars a || has_fvars b - | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod + has_fvars (ty_exn e) + || + match view e with + | E_var _ -> true + | E_type _ | E_bound_var _ | E_const _ -> false + | E_app (a, b) -> has_fvars a || has_fvars b + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod let universe_ (e : t) : int = match e.view with @@ -544,7 +550,7 @@ module Make_ = struct | E_lam (name, ty, bod) -> (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) let ty_bod = ty_exn bod in - make (E_pi (name, ty, db_shift_ ~make ty_bod 1)) + make (E_pi (name, ty, ty_bod)) | E_app (f, a) -> (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], is [ty_bod_f[x := a]] *) @@ -564,7 +570,9 @@ module Make_ = struct "@[<2>cannot apply %a,@ must have Pi type, but actual type is %a@]" pp_debug f pp_debug ty_f) | E_pi (_, ty, bod) -> - let u = max (universe_ ty) (universe_of_ty_ bod) + 1 in + (* TODO: check the actual triplets for COC *) + Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod; + let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) + 1 in make (E_type u) (* hashconsing + computing metadata + computing type (for new terms) *) @@ -574,6 +582,12 @@ module Make_ = struct if e == e2 then ( (* new term, compute metadata *) assert (store.s_uid land store_id_mask == store.s_uid); + + (* first, compute type *) + if not (is_type_ e) then ( + let ty = compute_ty_ ~make:(make_ store) view in + e.ty <- Some ty + ); let has_fvars = compute_has_fvars_ e in e2.flags <- (compute_db_depth_ e lsl (1 + store_id_bits)) @@ -582,12 +596,7 @@ module Make_ = struct else 0) lor store.s_uid; - Store.check_e_uid store e2; - - if not (is_type_ e) then ( - let ty = compute_ty_ ~make:(make_ store) view in - e.ty <- Some ty - ) + Store.check_e_uid store e2 ); e2 @@ -596,6 +605,7 @@ module Make_ = struct let var store v : t = make_ store (E_var v) let var_str store name ~ty : t = var store (Var.make name ty) let bvar store v : t = make_ store (E_bound_var v) + let const store c ~ty : t = make_ store (E_const (c, ty)) let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l diff --git a/src/core-ast/ast.mli b/src/core-ast/ast.mli index 21647dc3..53121bb7 100644 --- a/src/core-ast/ast.mli +++ b/src/core-ast/ast.mli @@ -98,6 +98,13 @@ val has_fvars : t -> bool (** Does the term contain free variables? time: O(1) *) +val ty_exn : t -> t +(** Return the type of this term. Fails if the term is a type. *) + +val get_ty : store -> t -> t +(** [get_ty store t] gets the type of [t], or computes it on demand + in case [t] is itself a type. *) + (** {2 Creation} *) module Store : sig @@ -110,6 +117,7 @@ val type_ : store -> t val type_of_univ : store -> int -> t val var : store -> var -> t val var_str : store -> string -> ty:t -> t +val const : store -> Const.t -> ty:t -> t val app : store -> t -> t -> t val app_l : store -> t -> t list -> t val lam : store -> var -> t -> t @@ -119,10 +127,6 @@ val arrow_l : store -> t list -> t -> t val open_lambda : store -> t -> (var * t) option val open_lambda_exn : store -> t -> var * t -val get_ty : store -> t -> t -(** [get_ty store t] gets the type of [t], or computes it on demand - in case [t] is itself a type. *) - (** Substitutions *) module Subst : sig type t diff --git a/src/core-ast/sidekick_core_ast.ml b/src/core-ast/sidekick_core_ast.ml index 7ec71480..525f825c 100644 --- a/src/core-ast/sidekick_core_ast.ml +++ b/src/core-ast/sidekick_core_ast.ml @@ -1,2 +1,3 @@ module Ast = Ast include Ast +module Str_const = Str_const From 2db3343bcd8d1329422e4e922f5a58b50cc57877 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 22:40:36 -0400 Subject: [PATCH 025/174] improve unittest for core-ast --- unittest/core-ast/t1.expected | 8 ++++++++ unittest/core-ast/t1.ml | 26 ++++++++++++++++++++++++++ 2 files changed, 34 insertions(+) diff --git a/unittest/core-ast/t1.expected b/unittest/core-ast/t1.expected index 41db5eae..f64d188c 100644 --- a/unittest/core-ast/t1.expected +++ b/unittest/core-ast/t1.expected @@ -2,3 +2,11 @@ type0 : type typeof(type0) : type_1 type tower: [type;type_1;type_2;type_3;type_4;type_5;type_6;type_7;type_8; type_9] +a: a, b: b, typeof(a): Bool +pi Bool Bool +b2b: (Bool -> Bool) +p(a): p a +p(b): p b +q(a): q a +q(b): q b +typeof(p a): Bool diff --git a/unittest/core-ast/t1.ml b/unittest/core-ast/t1.ml index c599fcdf..04872627 100644 --- a/unittest/core-ast/t1.ml +++ b/unittest/core-ast/t1.ml @@ -11,3 +11,29 @@ let l = let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list pp_debug) l let () = assert (equal (type_ store) (type_ store)) +let bool = Str_const.const store "Bool" ~ty:(type_ store) +let a = Str_const.const store "a" ~ty:bool +let a' = Str_const.const store "a" ~ty:bool +let b = Str_const.const store "b" ~ty:bool + +let () = + Fmt.printf "a: %a, b: %a, typeof(a): %a@." pp_debug a pp_debug b pp_debug + (ty_exn a) + +let () = assert (equal a a) +let () = assert (not (equal a b)) +let ty_b2b = arrow store bool bool +let () = Fmt.printf "b2b: %a@." pp_debug ty_b2b +let p = Str_const.const store "p" ~ty:ty_b2b +let q = Str_const.const store "q" ~ty:ty_b2b +let pa = app store p a +let pb = app store p b +let qa = app store q a +let qb = app store q b +let () = Fmt.printf "p(a): %a@." pp_debug pa +let () = Fmt.printf "p(b): %a@." pp_debug pb +let () = Fmt.printf "q(a): %a@." pp_debug qa +let () = Fmt.printf "q(b): %a@." pp_debug qb +let () = assert (equal pa (app store p a)) +let ty_pa = ty_exn pa +let () = Fmt.printf "typeof(p a): %a@." pp_debug ty_pa From 88eb2575c30d5d80cbf43553ddf18eb573408b48 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 22:40:46 -0400 Subject: [PATCH 026/174] feat(sigs): add some basic sigs --- src/sigs/sidekick_sigs.ml | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/sigs/sidekick_sigs.ml b/src/sigs/sidekick_sigs.ml index 4cbcd6b6..92e24c7f 100644 --- a/src/sigs/sidekick_sigs.ml +++ b/src/sigs/sidekick_sigs.ml @@ -39,6 +39,12 @@ module type EQ_ORD_HASH_PRINT = sig include PRINT with type t := t end +module type EQ_ORD_HASH = sig + include EQ + include ORD with type t := t + include HASH with type t := t +end + module type DYN_BACKTRACKABLE = sig val n_levels : unit -> int (** Number of levels *) @@ -82,3 +88,11 @@ module type BACKTRACKABLE1_CB = sig val pop_levels : 'a t -> int -> f:('a -> unit) -> unit (** [pop_levels st n ~f] removes [n] levels, calling [f] on every removed item *) end + +module type WITH_SET_MAP_TBL = sig + type t + + module Set : CCSet.S with type elt = t + module Map : CCMap.S with type key = t + module Tbl : CCHashtbl.S with type key = t +end From 435845d1d408237dfd1943a7b74a8bc319d8b1ba Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 27 Jul 2022 22:45:10 -0400 Subject: [PATCH 027/174] update tests --- unittest/core-ast/t1.expected | 7 +++++++ unittest/core-ast/t1.ml | 19 +++++++++++++++++++ 2 files changed, 26 insertions(+) diff --git a/unittest/core-ast/t1.expected b/unittest/core-ast/t1.expected index f64d188c..292f26fc 100644 --- a/unittest/core-ast/t1.expected +++ b/unittest/core-ast/t1.expected @@ -10,3 +10,10 @@ p(b): p b q(a): q a q(b): q b typeof(p a): Bool +pi Bool Bool +pi Bool Bool +pi Bool (Bool -> Bool) +lxy_px: (\x:Bool. (\y:Bool. p x)) + type: (Bool -> (Bool -> Bool)) +lxy_px a b: ((\x:Bool. (\y:Bool. p x))) a b + type: Bool diff --git a/unittest/core-ast/t1.ml b/unittest/core-ast/t1.ml index 04872627..0afd0d19 100644 --- a/unittest/core-ast/t1.ml +++ b/unittest/core-ast/t1.ml @@ -35,5 +35,24 @@ let () = Fmt.printf "p(b): %a@." pp_debug pb let () = Fmt.printf "q(a): %a@." pp_debug qa let () = Fmt.printf "q(b): %a@." pp_debug qb let () = assert (equal pa (app store p a)) + +(* *) + let ty_pa = ty_exn pa let () = Fmt.printf "typeof(p a): %a@." pp_debug ty_pa + +(* *) + +let v_x = Var.make "x" bool +let v_y = Var.make "y" bool +let x = var store v_x +let y = var store v_y +let lxy_px = lam store v_x @@ lam store v_y @@ app store p x + +let () = + Fmt.printf "@[lxy_px: %a@ type: %a@]@." pp_debug lxy_px pp_debug + (ty_exn lxy_px) + +let () = + let t = app_l store lxy_px [ a; b ] in + Fmt.printf "@[lxy_px a b: %a@ type: %a@]@." pp_debug t pp_debug (ty_exn t) From 6f376cfaf27e765c8bbdd490e94ce8ede625f36f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 13:54:38 -0400 Subject: [PATCH 028/174] refactor: rename core-ast to core-logic; split into modules --- src/core-logic/Hashcons.ml | 34 ++ src/core-logic/bvar.ml | 9 + src/core-logic/bvar.mli | 10 + src/core-logic/const.ml | 29 ++ src/core-logic/const.mli | 22 + src/core-logic/dune | 6 + src/core-logic/sidekick_core_logic.ml | 10 + src/core-logic/str_const.ml | 21 + src/core-logic/str_const.mli | 10 + src/core-logic/subst.ml | 25 ++ src/core-logic/subst.mli | 15 + src/core-logic/term.ml | 618 ++++++++++++++++++++++++++ src/core-logic/term.mli | 103 +++++ src/core-logic/types_.ml | 67 +++ src/core-logic/var.ml | 14 + src/core-logic/var.mli | 15 + 16 files changed, 1008 insertions(+) create mode 100644 src/core-logic/Hashcons.ml create mode 100644 src/core-logic/bvar.ml create mode 100644 src/core-logic/bvar.mli create mode 100644 src/core-logic/const.ml create mode 100644 src/core-logic/const.mli create mode 100644 src/core-logic/dune create mode 100644 src/core-logic/sidekick_core_logic.ml create mode 100644 src/core-logic/str_const.ml create mode 100644 src/core-logic/str_const.mli create mode 100644 src/core-logic/subst.ml create mode 100644 src/core-logic/subst.mli create mode 100644 src/core-logic/term.ml create mode 100644 src/core-logic/term.mli create mode 100644 src/core-logic/types_.ml create mode 100644 src/core-logic/var.ml create mode 100644 src/core-logic/var.mli diff --git a/src/core-logic/Hashcons.ml b/src/core-logic/Hashcons.ml new file mode 100644 index 00000000..28ca6e21 --- /dev/null +++ b/src/core-logic/Hashcons.ml @@ -0,0 +1,34 @@ +module type ARG = sig + type t + + val equal : t -> t -> bool + val hash : t -> int + val set_id : t -> int -> unit +end + +module Make (A : ARG) : sig + type t + + val create : ?size:int -> unit -> t + val hashcons : t -> A.t -> A.t + val size : t -> int + val to_iter : t -> A.t Iter.t +end = struct + module W = Weak.Make (A) + + type t = { tbl: W.t; mutable n: int } + + let create ?(size = 1024) () : t = { tbl = W.create size; n = 0 } + + (* hashcons terms *) + let hashcons st t = + let t' = W.merge st.tbl t in + if t == t' then ( + st.n <- 1 + st.n; + A.set_id t' st.n + ); + t' + + let size st = W.count st.tbl + let to_iter st yield = W.iter yield st.tbl +end diff --git a/src/core-logic/bvar.ml b/src/core-logic/bvar.ml new file mode 100644 index 00000000..bddb63d7 --- /dev/null +++ b/src/core-logic/bvar.ml @@ -0,0 +1,9 @@ +open Types_ + +type t = bvar = { bv_idx: int; bv_ty: term } + +let equal (v1 : t) v2 = v1.bv_idx = v2.bv_idx && Term_.equal v1.bv_ty v2.bv_ty +let hash v = H.combine2 (H.int v.bv_idx) (Term_.hash v.bv_ty) +let pp out v = Fmt.fprintf out "bv[%d]" v.bv_idx +let[@inline] ty self = self.bv_ty +let make i ty : t = { bv_idx = i; bv_ty = ty } diff --git a/src/core-logic/bvar.mli b/src/core-logic/bvar.mli new file mode 100644 index 00000000..cd1330a5 --- /dev/null +++ b/src/core-logic/bvar.mli @@ -0,0 +1,10 @@ +(** Bound variable *) + +open Types_ + +type t = bvar = { bv_idx: int; bv_ty: term } + +include EQ_HASH_PRINT with type t := t + +val make : int -> term -> t +val ty : t -> term diff --git a/src/core-logic/const.ml b/src/core-logic/const.ml new file mode 100644 index 00000000..c7004f70 --- /dev/null +++ b/src/core-logic/const.ml @@ -0,0 +1,29 @@ +open Types_ + +type view = const_view = .. + +module type DYN_OPS = sig + val pp : view Fmt.printer + val equal : view -> view -> bool + val hash : view -> int +end + +type ops = (module DYN_OPS) +type t = const = { c_view: view; c_ops: ops; c_ty: term } + +let[@inline] view self = self.c_view +let[@inline] ty self = self.c_ty + +let equal (a : t) b = + let (module O) = a.c_ops in + O.equal a.c_view b.c_view && Term_.equal a.c_ty b.c_ty + +let hash (a : t) : int = + let (module O) = a.c_ops in + H.combine2 (O.hash a.c_view) (Term_.hash a.c_ty) + +let pp out (a : t) = + let (module O) = a.c_ops in + O.pp out a.c_view + +let make c_view c_ops ~ty:c_ty : t = { c_view; c_ops; c_ty } diff --git a/src/core-logic/const.mli b/src/core-logic/const.mli new file mode 100644 index 00000000..bf22cd28 --- /dev/null +++ b/src/core-logic/const.mli @@ -0,0 +1,22 @@ +(** Constants. + + Constants are logical symbols, defined by the user thanks to an open type *) + +open Types_ + +type t = const +type view = const_view = .. + +module type DYN_OPS = sig + val pp : view Fmt.printer + val equal : view -> view -> bool + val hash : view -> int +end + +type ops = (module DYN_OPS) + +val view : t -> view +val make : view -> ops -> ty:term -> t +val ty : t -> term + +include EQ_HASH_PRINT with type t := t diff --git a/src/core-logic/dune b/src/core-logic/dune new file mode 100644 index 00000000..5b7b4f4b --- /dev/null +++ b/src/core-logic/dune @@ -0,0 +1,6 @@ +(library + (name sidekick_core_logic) + (public_name sidekick.core-logic) + (synopsis "Core AST for logic terms and types") + (flags :standard -w +32 -open Sidekick_sigs -open Sidekick_util) + (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/core-logic/sidekick_core_logic.ml b/src/core-logic/sidekick_core_logic.ml new file mode 100644 index 00000000..5673f0c8 --- /dev/null +++ b/src/core-logic/sidekick_core_logic.ml @@ -0,0 +1,10 @@ +module Term = Term +module Var = Var +module Bvar = Bvar +module Const = Const +module Subst = Subst + +(* *) + +module Store = Term.Store +module Str_const = Str_const diff --git a/src/core-logic/str_const.ml b/src/core-logic/str_const.ml new file mode 100644 index 00000000..ea92d85d --- /dev/null +++ b/src/core-logic/str_const.ml @@ -0,0 +1,21 @@ +open Types_ + +type const_view += Str of string + +let ops : Const.ops = + (module struct + let pp out = function + | Str s -> Fmt.string out s + | _ -> assert false + + let equal a b = + match a, b with + | Str s1, Str s2 -> s1 = s2 + | _ -> false + + let hash = function + | Str s -> CCHash.string s + | _ -> assert false + end) + +let make name ~ty : Const.t = Const.make (Str name) ops ~ty diff --git a/src/core-logic/str_const.mli b/src/core-logic/str_const.mli new file mode 100644 index 00000000..e7cd4922 --- /dev/null +++ b/src/core-logic/str_const.mli @@ -0,0 +1,10 @@ +(** Basic string constants. + + These constants are a string name, coupled with a type. +*) + +open Types_ + +type const_view += private Str of string + +val make : string -> ty:term -> const diff --git a/src/core-logic/subst.ml b/src/core-logic/subst.ml new file mode 100644 index 00000000..b960915a --- /dev/null +++ b/src/core-logic/subst.ml @@ -0,0 +1,25 @@ +open Types_ +module M = Var_.Map + +type t = subst + +let empty = { m = M.empty } +let is_empty self = M.is_empty self.m +let add v t self = { m = M.add v t self.m } + +let pp out (self : t) = + if is_empty self then + Fmt.string out "(subst)" + else ( + let pp_pair out (v, t) = + Fmt.fprintf out "(@[%a := %a@])" Var.pp v !Term_.pp_debug_ t + in + Fmt.fprintf out "(@[subst@ %a@])" (Util.pp_iter pp_pair) (M.to_iter self.m) + ) + +let of_list l = { m = M.of_list l } +let of_iter it = { m = M.of_iter it } +let to_iter self = M.to_iter self.m + +let apply (store : Term.store) ~recursive (self : t) (e : term) : term = + Term.Internal_.subst_ store ~recursive e self diff --git a/src/core-logic/subst.mli b/src/core-logic/subst.mli new file mode 100644 index 00000000..9f88065a --- /dev/null +++ b/src/core-logic/subst.mli @@ -0,0 +1,15 @@ +(** Substitutions *) + +open Types_ + +type t = subst + +include PRINT with type t := t + +val empty : t +val is_empty : t -> bool +val of_list : (var * term) list -> t +val of_iter : (var * term) Iter.t -> t +val to_iter : t -> (var * term) Iter.t +val add : var -> term -> t -> t +val apply : Term.store -> recursive:bool -> t -> term -> term diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml new file mode 100644 index 00000000..fe4bd9ca --- /dev/null +++ b/src/core-logic/term.ml @@ -0,0 +1,618 @@ +open Types_ + +type view = term_view = + | E_type of int + | E_var of var + | E_bound_var of bvar + | E_const of const + | E_app of term * term + | E_lam of string * term * term + | E_pi of string * term * term + +type t = term + +(* 5 bits in [t.id] are used to store which store it belongs to, so we have + a chance of detecting when the user passes a term to the wrong store *) +let store_id_bits = 5 + +(* mask to access the store id *) +let store_id_mask = (1 lsl store_id_bits) - 1 + +include Term_ + +let[@inline] view (e : term) : view = e.view +let[@inline] db_depth e = e.flags lsr (1 + store_id_bits) +let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 +let[@inline] store_uid e : int = e.flags land store_id_mask +let[@inline] is_closed e : bool = db_depth e == 0 + +let[@inline] ty_exn e : term = + match e.ty with + | Some x -> x + | None -> assert false + +(* open an application *) +let unfold_app (e : term) : term * term list = + let[@unroll 1] rec aux acc e = + match e.view with + | E_app (f, a) -> aux (a :: acc) f + | _ -> e, acc + in + aux [] e + +(* debug printer *) +let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = + let rec loop k ~depth names out e = + let pp' = loop' k ~depth:(depth + 1) names in + (match e.view with + | E_type 0 -> Fmt.string out "type" + | E_type i -> Fmt.fprintf out "type_%d" i + | E_var v -> Fmt.string out v.v_name + (* | E_var v -> Fmt.fprintf out "(@[%s : %a@])" v.v_name pp v.v_ty *) + | E_bound_var v -> + let idx = v.bv_idx in + (match CCList.nth_opt names idx with + | Some n when n <> "" -> Fmt.string out n + | _ -> + if idx < k then + Fmt.fprintf out "x_%d" (k - idx - 1) + else + Fmt.fprintf out "%%db_%d" (idx - k)) + | E_const c -> Const.pp out c + | (E_app _ | E_lam _) when depth > max_depth -> + Fmt.fprintf out "@<1>…/%d" e.id + | E_app _ -> + let f, args = unfold_app e in + Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args + | E_lam ("", _ty, bod) -> + Fmt.fprintf out "(@[\\x_%d:@[%a@].@ %a@])" k pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_lam (n, _ty, bod) -> + Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod + | E_pi (_, ty, bod) when is_closed bod -> + (* actually just an arrow *) + Fmt.fprintf out "(@[%a@ -> %a@])" + (loop k ~depth:(depth + 1) names) + ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_pi ("", _ty, bod) -> + Fmt.fprintf out "(@[Pi x_%d:@[%a@].@ %a@])" k pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_pi (n, _ty, bod) -> + Fmt.fprintf out "(@[Pi %s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod); + if pp_ids then Fmt.fprintf out "/%d" e.id + and loop' k ~depth names out e = + match e.view with + | E_type _ | E_var _ | E_bound_var _ | E_const _ -> + loop k ~depth names out e (* atomic expr *) + | E_app _ | E_lam _ | E_pi _ -> + Fmt.fprintf out "(%a)" (loop k ~depth names) e + in + Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e + +let pp_debug = expr_pp_with_ ~pp_ids:false ~max_depth:max_int +let pp_debug_with_ids = expr_pp_with_ ~pp_ids:true ~max_depth:max_int +let () = pp_debug_ := pp_debug + +module AsKey = struct + type nonrec t = term + + let equal = equal + let compare = compare + let hash = hash +end + +module Map = CCMap.Make (AsKey) +module Set = CCSet.Make (AsKey) +module Tbl = CCHashtbl.Make (AsKey) + +module Hcons = Hashcons.Make (struct + type nonrec t = term + + let equal a b = + match a.view, b.view with + | E_type i, E_type j -> i = j + | E_const c1, E_const c2 -> Const.equal c1 c2 + | E_var v1, E_var v2 -> Var.equal v1 v2 + | E_bound_var v1, E_bound_var v2 -> Bvar.equal v1 v2 + | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 + | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> + equal ty1 ty2 && equal bod1 bod2 + | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ | E_lam _ + | E_pi _ ), + _ ) -> + false + + let hash e : int = + match e.view with + | E_type i -> H.combine2 10 (H.int i) + | E_const c -> H.combine2 20 (Const.hash c) + | E_var v -> H.combine2 30 (Var.hash v) + | E_bound_var v -> H.combine2 40 (Bvar.hash v) + | E_app (f, a) -> H.combine3 50 (hash f) (hash a) + | E_lam (_, ty, bod) -> H.combine3 60 (hash ty) (hash bod) + | E_pi (_, ty, bod) -> H.combine3 70 (hash ty) (hash bod) + + let set_id t id = + assert (t.id == -1); + t.id <- id +end) + +module Store = struct + type t = { (* unique ID for this store *) + s_uid: int; s_exprs: Hcons.t } + + (* TODO: use atomic? CCAtomic? *) + let n = ref 0 + + let create () : t = + let s_uid = !n in + incr n; + { s_uid; s_exprs = Hcons.create ~size:256 () } + + (* check that [e] belongs in this store *) + let[@inline] check_e_uid (self : t) (e : term) = + assert (self.s_uid == store_uid e) +end + +type store = Store.t + +let iter_shallow ~f (e : term) : unit = + match e.view with + | E_type _ -> () + | _ -> + (match e.ty with + | None -> (* should be computed at build time *) assert false + | Some ty -> f false ty); + (match e.view with + | E_const _ -> () + | E_type _ -> assert false + | E_var v -> f false v.v_ty + | E_bound_var v -> f false v.bv_ty + | E_app (hd, a) -> + f false hd; + f false a + | E_lam (_, tyv, bod) | E_pi (_, tyv, bod) -> + f false tyv; + f true bod) + +let map_shallow_ ~make ~f (e : term) : term = + match view e with + | E_type _ | E_const _ -> e + | E_var v -> + let v_ty = f false v.v_ty in + if v_ty == v.v_ty then + e + else + make (E_var { v with v_ty }) + | E_bound_var v -> + let ty' = f false v.bv_ty in + if v.bv_ty == ty' then + e + else + make (E_bound_var { v with bv_ty = ty' }) + | E_app (hd, a) -> + let hd' = f false hd in + let a' = f false a in + if a == a' && hd == hd' then + e + else + make (E_app (f false hd, f false a)) + | E_lam (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make (E_lam (n, tyv', bod')) + | E_pi (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make (E_pi (n, tyv', bod')) + +(* TODO + (* map immediate subterms *) + let map_shallow ctx ~f (e : t) : t = + match view e with + | E_kind | E_type | E_const (_, []) | E_box _ -> e + | _ -> + let ty' = + lazy + (match e.e_ty with + | (lazy None) -> None + | (lazy (Some ty)) -> Some (f false ty)) + in + (match view e with + | E_var v -> + let v_ty = f false v.v_ty in + if v_ty == v.v_ty then + e + else + make_ ctx (E_var { v with v_ty }) ty' + | E_const (c, args) -> + let args' = List.map (f false) args in + if List.for_all2 equal args args' then + e + else + make_ ctx (E_const (c, args')) ty' + | E_bound_var v -> + let ty' = f false v.bv_ty in + if v.bv_ty == ty' then + e + else + make_ ctx + (E_bound_var { v with bv_ty = ty' }) + (Lazy.from_val (Some ty')) + | E_app (hd, a) -> + let hd' = f false hd in + let a' = f false a in + if a == a' && hd == hd' then + e + else + make_ ctx (E_app (f false hd, f false a)) ty' + | E_lam (n, tyv, bod) -> + let tyv' = f false tyv in + let bod' = f true bod in + if tyv == tyv' && bod == bod' then + e + else + make_ ctx (E_lam (n, tyv', bod')) ty' + | E_arrow (a, b) -> + let a' = f false a in + let b' = f false b in + if a == a' && b == b' then + e + else + make_ ctx (E_arrow (a', b')) ty' + | E_kind | E_type | E_box _ -> assert false) +*) + +exception IsSub + +let[@inline] is_type_ e = + match e.view with + | E_type _ -> true + | _ -> false + +let[@inline] is_a_type e = is_type_ e || is_type_ (ty_exn e) + +let iter_dag ?(seen = Tbl.create 8) ~iter_ty ~f e : unit = + let rec loop e = + if not (Tbl.mem seen e) then ( + Tbl.add seen e (); + if iter_ty && not (is_type_ e) then loop (ty_exn e); + f e; + iter_shallow e ~f:(fun _ u -> loop u) + ) + in + loop e + +exception E_exit + +let exists_shallow ~f e : bool = + try + iter_shallow e ~f:(fun b x -> if f b x then raise_notrace E_exit); + false + with E_exit -> true + +let for_all_shallow ~f e : bool = + try + iter_shallow e ~f:(fun b x -> if not (f b x) then raise_notrace E_exit); + true + with E_exit -> false + +let contains e ~sub : bool = + try + iter_dag ~iter_ty:true e ~f:(fun e' -> + if equal e' sub then raise_notrace IsSub); + false + with IsSub -> true + +let free_vars_iter e : var Iter.t = + fun yield -> + iter_dag ~iter_ty:true e ~f:(fun e' -> + match view e' with + | E_var v -> yield v + | _ -> ()) + +let free_vars ?(init = Var.Set.empty) e : Var.Set.t = + let set = ref init in + free_vars_iter e (fun v -> set := Var.Set.add v !set); + !set + +module Make_ = struct + let compute_db_depth_ e : int = + if is_type_ e then + 0 + else ( + let d1 = db_depth @@ ty_exn e in + let d2 = + match view e with + | E_type _ | E_const _ | E_var _ -> 0 + | E_bound_var v -> v.bv_idx + 1 + | E_app (a, b) -> max (db_depth a) (db_depth b) + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> + max (db_depth ty) (max 0 (db_depth bod - 1)) + in + max d1 d2 + ) + + let compute_has_fvars_ e : bool = + if is_type_ e then + false + else + has_fvars (ty_exn e) + || + match view e with + | E_var _ -> true + | E_type _ | E_bound_var _ | E_const _ -> false + | E_app (a, b) -> has_fvars a || has_fvars b + | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod + + let universe_ (e : term) : int = + match e.view with + | E_type i -> i + | _ -> assert false + + let[@inline] universe_of_ty_ (e : term) : int = + match e.view with + | E_type i -> i + 1 + | _ -> universe_ (ty_exn e) + + module T_int_tbl = CCHashtbl.Make (struct + type t = term * int + + let equal (t1, k1) (t2, k2) = equal t1 t2 && k1 == k2 + let hash (t, k) = H.combine3 27 (hash t) (H.int k) + end) + + let db_shift_ ~make (e : term) (n : int) = + let rec loop e k : term = + if is_closed e then + e + else if is_a_type e then + e + else ( + match view e with + | E_bound_var bv -> + if bv.bv_idx >= k then + make (E_bound_var (Bvar.make (bv.bv_idx + n) bv.bv_ty)) + else + e + | _ -> + map_shallow_ e ~make ~f:(fun inbind u -> + loop u + (if inbind then + k + 1 + else + k)) + ) + in + assert (n >= 0); + if n = 0 || is_closed e then + e + else + loop e 0 + + (* replace DB0 in [e] with [u] *) + let db_0_replace_ ~make e ~by:u : term = + let cache_ = T_int_tbl.create 8 in + + let rec aux e k : term = + if is_a_type e then + e + else if db_depth e < k then + e + else ( + match view e with + | E_const _ -> e + | E_bound_var bv when bv.bv_idx = k -> + (* replace here *) + db_shift_ ~make u k + | _ -> + (* use the cache *) + (try T_int_tbl.find cache_ (e, k) + with Not_found -> + let r = + map_shallow_ e ~make ~f:(fun inb u -> + aux u + (if inb then + k + 1 + else + k)) + in + T_int_tbl.add cache_ (e, k) r; + r) + ) + in + if is_closed e then + e + else + aux e 0 + + let subst_ ~make ~recursive e0 (subst : subst) : t = + (* cache for types and some terms *) + let cache_ = T_int_tbl.create 16 in + + let rec loop k e = + try T_int_tbl.find cache_ (e, k) + with Not_found -> + let r = loop_uncached_ k e in + T_int_tbl.add cache_ (e, k) r; + r + and loop_uncached_ k (e : t) : t = + match view e with + | _ when not (has_fvars e) -> e (* nothing to subst in *) + | E_var v -> + (* first, subst in type *) + let v = { v with v_ty = loop k v.v_ty } in + (match Var_.Map.find v subst.m with + | u -> + let u = db_shift_ ~make u k in + if recursive then + loop 0 u + else + u + | exception Not_found -> make (E_var v)) + | E_const _ -> e + | _ -> + map_shallow_ e ~make ~f:(fun inb u -> + loop + (if inb then + k + 1 + else + k) + u) + in + + if Var_.Map.is_empty subst.m then + e0 + else + loop 0 e0 + + let compute_ty_ ~make (view : view) : term = + match view with + | E_var v -> Var.ty v + | E_bound_var v -> Bvar.ty v + | E_type i -> make (E_type (i + 1)) + | E_const c -> Const.ty c + | E_lam (name, ty, bod) -> + (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) + let ty_bod = ty_exn bod in + make (E_pi (name, ty, ty_bod)) + | E_app (f, a) -> + (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], + is [ty_bod_f[x := a]] *) + let ty_f = ty_exn f in + let ty_a = ty_exn a in + (match ty_f.view with + | E_pi (_, ty_arg_f, ty_bod_f) -> + (* check that the expected type matches *) + if not (equal ty_arg_f ty_a) then + Error.errorf + "@[<2>cannot apply %a to %a,@ expected argument type: %a@ actual: \ + %a@]" + pp_debug f pp_debug a pp_debug ty_arg_f pp_debug ty_a; + db_0_replace_ ~make ty_bod_f ~by:a + | _ -> + Error.errorf + "@[<2>cannot apply %a,@ must have Pi type, but actual type is %a@]" + pp_debug f pp_debug ty_f) + | E_pi (_, ty, bod) -> + (* TODO: check the actual triplets for COC *) + Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod; + let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) + 1 in + make (E_type u) + + (* hashconsing + computing metadata + computing type (for new terms) *) + let rec make_ (store : store) view : term = + let e = { view; ty = None; id = -1; flags = 0 } in + let e2 = Hcons.hashcons store.s_exprs e in + if e == e2 then ( + (* new term, compute metadata *) + assert (store.s_uid land store_id_mask == store.s_uid); + + (* first, compute type *) + if not (is_type_ e) then ( + let ty = compute_ty_ ~make:(make_ store) view in + e.ty <- Some ty + ); + let has_fvars = compute_has_fvars_ e in + e2.flags <- + (compute_db_depth_ e lsl (1 + store_id_bits)) + lor (if has_fvars then + 1 lsl store_id_bits + else + 0) + lor store.s_uid; + Store.check_e_uid store e2 + ); + e2 + + let type_of_univ store i : term = make_ store (E_type i) + let type_ store : term = type_of_univ store 0 + let var store v : term = make_ store (E_var v) + let var_str store name ~ty : term = var store (Var.make name ty) + let bvar store v : term = make_ store (E_bound_var v) + let const store c : term = make_ store (E_const c) + let app store f a = make_ store (E_app (f, a)) + let app_l store f l = List.fold_left (app store) f l + + let abs_on_ (store : store) (v : var) (e : term) : term = + Store.check_e_uid store v.v_ty; + Store.check_e_uid store e; + if not (is_closed v.v_ty) then + Error.errorf "cannot abstract on variable@ with non closed type %a" + pp_debug v.v_ty; + let db0 = bvar store (Bvar.make 0 v.v_ty) in + let body = db_shift_ ~make:(make_ store) e 1 in + subst_ ~make:(make_ store) ~recursive:false body + { m = Var_.Map.singleton v db0 } + + let lam store v bod : term = + let bod' = abs_on_ store v bod in + make_ store (E_lam (Var.name v, Var.ty v, bod')) + + let pi store v bod : term = + let bod' = abs_on_ store v bod in + make_ store (E_pi (Var.name v, Var.ty v, bod')) + + let arrow store a b : term = + let b' = db_shift_ ~make:(make_ store) b 1 in + make_ store (E_pi ("", a, b')) + + let arrow_l store args ret = List.fold_right (arrow store) args ret + + (* find a name that doesn't capture a variable of [e] *) + let pick_name_ (name0 : string) (e : term) : string = + let rec loop i = + let name = + if i = 0 then + name0 + else + Printf.sprintf "%s%d" name0 i + in + if free_vars_iter e |> Iter.exists (fun v -> v.v_name = name) then + loop (i + 1) + else + name + in + loop 0 + + let open_lambda store e : _ option = + match view e with + | E_lam (name, ty, bod) -> + let name = pick_name_ name bod in + let v = Var.make name ty in + let bod' = db_0_replace_ bod ~make:(make_ store) ~by:(var store v) in + Some (v, bod') + | _ -> None + + let open_lambda_exn store e = + match open_lambda store e with + | Some tup -> tup + | None -> Error.errorf "open-lambda: term is not a lambda:@ %a" pp_debug e +end + +include Make_ + +let get_ty store e : term = + match e.view with + | E_type i -> type_of_univ store (i + 1) + | _ -> ty_exn e + +(* re-export some internal things *) +module Internal_ = struct + let subst_ store ~recursive t subst = + subst_ ~make:(make_ store) ~recursive t subst +end diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli new file mode 100644 index 00000000..24d4382d --- /dev/null +++ b/src/core-logic/term.mli @@ -0,0 +1,103 @@ +(** Core logic terms. + + The core terms are expressions in the calculus of constructions, + with no universe polymorphism nor cumulativity. It should be fast, with hashconsing; + and simple enough (no inductives, no universe trickery). + + It is intended to be the foundation for user-level terms and types and formulas. +*) + +open Types_ + +type t = term +(** A term, in the calculus of constructions *) + +type store +(** The store for terms. + + The store is responsible for allocating unique IDs to terms, and + enforcing their hashconsing (so that syntactic equality is just a pointer + comparison). *) + +(** View. + + A view is the shape of the root node of a term. *) +type view = term_view = + | E_type of int + | E_var of var + | E_bound_var of bvar + | E_const of const + | E_app of t * t + | E_lam of string * t * t + | E_pi of string * t * t + +include EQ_ORD_HASH with type t := t + +val pp_debug : t Fmt.printer +val pp_debug_with_ids : t Fmt.printer + +(** {2 Containers} *) + +include WITH_SET_MAP_TBL with type t := t + +(** {2 Utils} *) + +val view : t -> view +val unfold_app : t -> t * t list +val iter_dag : ?seen:unit Tbl.t -> iter_ty:bool -> f:(t -> unit) -> t -> unit + +val iter_shallow : f:(bool -> t -> unit) -> t -> unit +(** [iter_shallow f e] iterates on immediate subterms of [e], + calling [f trdb e'] for each subterm [e'], with [trdb = true] iff + [e'] is directly under a binder. *) + +val exists_shallow : f:(bool -> t -> bool) -> t -> bool +val for_all_shallow : f:(bool -> t -> bool) -> t -> bool +val contains : t -> sub:t -> bool +val free_vars_iter : t -> var Iter.t +val free_vars : ?init:Var.Set.t -> t -> Var.Set.t + +val is_closed : t -> bool +(** Is the term closed (all bound variables are paired with a binder)? + time: O(1) *) + +val has_fvars : t -> bool +(** Does the term contain free variables? + time: O(1) *) + +val ty_exn : t -> t +(** Return the type of this term. Fails if the term is a type. *) + +val get_ty : store -> t -> t +(** [get_ty store t] gets the type of [t], or computes it on demand + in case [t] is itself a type. *) + +(** {2 Creation} *) + +module Store : sig + type t = store + + val create : unit -> t +end + +val type_ : store -> t +val type_of_univ : store -> int -> t +val var : store -> var -> t +val var_str : store -> string -> ty:t -> t +val const : store -> Const.t -> t +val app : store -> t -> t -> t +val app_l : store -> t -> t list -> t +val lam : store -> var -> t -> t +val pi : store -> var -> t -> t +val arrow : store -> t -> t -> t +val arrow_l : store -> t list -> t -> t +val open_lambda : store -> t -> (var * t) option +val open_lambda_exn : store -> t -> var * t + +(**/**) + +module Internal_ : sig + val subst_ : store -> recursive:bool -> t -> subst -> t +end + +(**/**) diff --git a/src/core-logic/types_.ml b/src/core-logic/types_.ml new file mode 100644 index 00000000..f62a5922 --- /dev/null +++ b/src/core-logic/types_.ml @@ -0,0 +1,67 @@ +module H = CCHash + +type const_view = .. + +module type DYN_CONST_OPS = sig + val pp : const_view Fmt.printer + val equal : const_view -> const_view -> bool + val hash : const_view -> int +end + +type const_ops = (module DYN_CONST_OPS) + +type term_view = + | E_type of int + | E_var of var + | E_bound_var of bvar + | E_const of const + | E_app of term * term + | E_lam of string * term * term + | E_pi of string * term * term + +and var = { v_name: string; v_ty: term } +and bvar = { bv_idx: int; bv_ty: term } +and const = { c_view: const_view; c_ops: const_ops; c_ty: term } + +and term = { + view: term_view; + (* computed on demand *) + mutable ty: term option; + mutable id: int; + (* contains: [highest DB var | 1:has free vars | 5:ctx uid] *) + mutable flags: int; +} + +module Term_ = struct + let[@inline] equal (e1 : term) e2 : bool = e1 == e2 + let[@inline] hash (e : term) = H.int e.id + let[@inline] compare (e1 : term) e2 : int = CCInt.compare e1.id e2.id + let pp_debug_ : term Fmt.printer ref = ref (fun _ _ -> assert false) +end + +module Var_ = struct + let[@inline] equal v1 v2 = + v1.v_name = v2.v_name && Term_.equal v1.v_ty v2.v_ty + + let[@inline] hash v1 = H.combine3 5 (H.string v1.v_name) (Term_.hash v1.v_ty) + + let compare a b : int = + if Term_.equal a.v_ty b.v_ty then + String.compare a.v_name b.v_name + else + compare a.v_ty b.v_ty + + module AsKey = struct + type nonrec t = var + + let equal = equal + let compare = compare + let hash = hash + end + + module Map = CCMap.Make (AsKey) + module Set = CCSet.Make (AsKey) + module Tbl = CCHashtbl.Make (AsKey) +end + +type subst = { m: term Var_.Map.t } [@@unboxed] diff --git a/src/core-logic/var.ml b/src/core-logic/var.ml new file mode 100644 index 00000000..492962a1 --- /dev/null +++ b/src/core-logic/var.ml @@ -0,0 +1,14 @@ +open Types_ + +type t = var = { v_name: string; v_ty: term } + +include Var_ + +let[@inline] name v = v.v_name +let[@inline] ty self = self.v_ty +let[@inline] pp out v1 = Fmt.string out v1.v_name +let make v_name v_ty : t = { v_name; v_ty } +let makef fmt ty = Fmt.kasprintf (fun s -> make s ty) fmt + +let pp_with_ty out v = + Fmt.fprintf out "(@[%s :@ %a@])" v.v_name !Term_.pp_debug_ v.v_ty diff --git a/src/core-logic/var.mli b/src/core-logic/var.mli new file mode 100644 index 00000000..3b3bdee8 --- /dev/null +++ b/src/core-logic/var.mli @@ -0,0 +1,15 @@ +(** Free variable *) + +open Types_ + +type t = var = { v_name: string; v_ty: term } + +include EQ_ORD_HASH_PRINT with type t := t + +val pp_with_ty : t Fmt.printer +val make : string -> term -> t +val makef : ('a, Format.formatter, unit, t) format4 -> term -> 'a +val name : t -> string +val ty : t -> term + +include WITH_SET_MAP_TBL with type t := t From dbd20c999b76b340fe544633617f3fe0d3623c99 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 13:55:09 -0400 Subject: [PATCH 029/174] refactor test --- unittest/core-ast/dune | 4 -- unittest/core-ast/t1.ml | 58 ------------------ unittest/core-logic/dune | 4 ++ unittest/{core-ast => core-logic}/t1.expected | 0 unittest/core-logic/t1.ml | 59 +++++++++++++++++++ 5 files changed, 63 insertions(+), 62 deletions(-) delete mode 100644 unittest/core-ast/dune delete mode 100644 unittest/core-ast/t1.ml create mode 100644 unittest/core-logic/dune rename unittest/{core-ast => core-logic}/t1.expected (100%) create mode 100644 unittest/core-logic/t1.ml diff --git a/unittest/core-ast/dune b/unittest/core-ast/dune deleted file mode 100644 index a32c666e..00000000 --- a/unittest/core-ast/dune +++ /dev/null @@ -1,4 +0,0 @@ -(tests - (names t1) - (flags :standard -open Sidekick_util) - (libraries containers sidekick.util sidekick.core-ast)) diff --git a/unittest/core-ast/t1.ml b/unittest/core-ast/t1.ml deleted file mode 100644 index 0afd0d19..00000000 --- a/unittest/core-ast/t1.ml +++ /dev/null @@ -1,58 +0,0 @@ -open Sidekick_core_ast - -let store = Store.create () -let t0 = type_ store -let () = Fmt.printf "type0 : %a@." pp_debug t0 -let () = Fmt.printf "typeof(type0) : %a@." pp_debug (get_ty store t0) - -let l = - CCSeq.unfold (fun ty -> Some (ty, get_ty store ty)) t0 - |> CCSeq.take 10 |> CCSeq.to_list - -let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list pp_debug) l -let () = assert (equal (type_ store) (type_ store)) -let bool = Str_const.const store "Bool" ~ty:(type_ store) -let a = Str_const.const store "a" ~ty:bool -let a' = Str_const.const store "a" ~ty:bool -let b = Str_const.const store "b" ~ty:bool - -let () = - Fmt.printf "a: %a, b: %a, typeof(a): %a@." pp_debug a pp_debug b pp_debug - (ty_exn a) - -let () = assert (equal a a) -let () = assert (not (equal a b)) -let ty_b2b = arrow store bool bool -let () = Fmt.printf "b2b: %a@." pp_debug ty_b2b -let p = Str_const.const store "p" ~ty:ty_b2b -let q = Str_const.const store "q" ~ty:ty_b2b -let pa = app store p a -let pb = app store p b -let qa = app store q a -let qb = app store q b -let () = Fmt.printf "p(a): %a@." pp_debug pa -let () = Fmt.printf "p(b): %a@." pp_debug pb -let () = Fmt.printf "q(a): %a@." pp_debug qa -let () = Fmt.printf "q(b): %a@." pp_debug qb -let () = assert (equal pa (app store p a)) - -(* *) - -let ty_pa = ty_exn pa -let () = Fmt.printf "typeof(p a): %a@." pp_debug ty_pa - -(* *) - -let v_x = Var.make "x" bool -let v_y = Var.make "y" bool -let x = var store v_x -let y = var store v_y -let lxy_px = lam store v_x @@ lam store v_y @@ app store p x - -let () = - Fmt.printf "@[lxy_px: %a@ type: %a@]@." pp_debug lxy_px pp_debug - (ty_exn lxy_px) - -let () = - let t = app_l store lxy_px [ a; b ] in - Fmt.printf "@[lxy_px a b: %a@ type: %a@]@." pp_debug t pp_debug (ty_exn t) diff --git a/unittest/core-logic/dune b/unittest/core-logic/dune new file mode 100644 index 00000000..1969c8d2 --- /dev/null +++ b/unittest/core-logic/dune @@ -0,0 +1,4 @@ +(tests + (names t1) + (flags :standard -open Sidekick_util) + (libraries containers sidekick.util sidekick.core-logic)) diff --git a/unittest/core-ast/t1.expected b/unittest/core-logic/t1.expected similarity index 100% rename from unittest/core-ast/t1.expected rename to unittest/core-logic/t1.expected diff --git a/unittest/core-logic/t1.ml b/unittest/core-logic/t1.ml new file mode 100644 index 00000000..30f09da3 --- /dev/null +++ b/unittest/core-logic/t1.ml @@ -0,0 +1,59 @@ +open Sidekick_core_logic + +let store = Store.create () +let t0 = Term.type_ store +let () = Fmt.printf "type0 : %a@." Term.pp_debug t0 +let () = Fmt.printf "typeof(type0) : %a@." Term.pp_debug (Term.get_ty store t0) + +let l = + CCSeq.unfold (fun ty -> Some (ty, Term.get_ty store ty)) t0 + |> CCSeq.take 10 |> CCSeq.to_list + +let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list Term.pp_debug) l +let () = assert (Term.(equal (type_ store) (type_ store))) +let bool = Term.const store @@ Str_const.make "Bool" ~ty:(Term.type_ store) +let a = Term.const store @@ Str_const.make "a" ~ty:bool +let a' = Term.const store @@ Str_const.make "a" ~ty:bool +let b = Term.const store @@ Str_const.make "b" ~ty:bool + +let () = + Fmt.printf "a: %a, b: %a, typeof(a): %a@." Term.pp_debug a Term.pp_debug b + Term.pp_debug (Term.ty_exn a) + +let () = assert (Term.(equal a a)) +let () = assert (not Term.(equal a b)) +let ty_b2b = Term.arrow store bool bool +let () = Fmt.printf "b2b: %a@." Term.pp_debug ty_b2b +let p = Term.const store @@ Str_const.make "p" ~ty:ty_b2b +let q = Term.const store @@ Str_const.make "q" ~ty:ty_b2b +let pa = Term.app store p a +let pb = Term.app store p b +let qa = Term.app store q a +let qb = Term.app store q b +let () = Fmt.printf "p(a): %a@." Term.pp_debug pa +let () = Fmt.printf "p(b): %a@." Term.pp_debug pb +let () = Fmt.printf "q(a): %a@." Term.pp_debug qa +let () = Fmt.printf "q(b): %a@." Term.pp_debug qb +let () = assert (Term.(equal pa (app store p a))) + +(* *) + +let ty_pa = Term.ty_exn pa +let () = Fmt.printf "typeof(p a): %a@." Term.pp_debug ty_pa + +(* *) + +let v_x = Var.make "x" bool +let v_y = Var.make "y" bool +let x = Term.var store v_x +let y = Term.var store v_y +let lxy_px = Term.lam store v_x @@ Term.lam store v_y @@ Term.app store p x + +let () = + Fmt.printf "@[lxy_px: %a@ type: %a@]@." Term.pp_debug lxy_px Term.pp_debug + (Term.ty_exn lxy_px) + +let () = + let t = Term.app_l store lxy_px [ a; b ] in + Fmt.printf "@[lxy_px a b: %a@ type: %a@]@." Term.pp_debug t Term.pp_debug + (Term.ty_exn t) From bfa434562ece649ec3b1b119d1556c4129d67f2b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 14:51:24 -0400 Subject: [PATCH 030/174] fix(core-logic/term): make `ty` unfailing; fix DB bugs --- src/core-logic/term.ml | 99 ++++++++++++++++++++++------------------ src/core-logic/term.mli | 8 +--- src/core-logic/types_.ml | 4 +- 3 files changed, 59 insertions(+), 52 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index fe4bd9ca..18e542e7 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -26,10 +26,13 @@ let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 let[@inline] store_uid e : int = e.flags land store_id_mask let[@inline] is_closed e : bool = db_depth e == 0 -let[@inline] ty_exn e : term = +let[@inline] ty e : term = match e.ty with - | Some x -> x - | None -> assert false + | T_ty t -> t + | T_ty_delayed f -> + let ty = f () in + e.ty <- T_ty ty; + ty (* open an application *) let unfold_app (e : term) : term * term list = @@ -45,19 +48,15 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = let rec loop k ~depth names out e = let pp' = loop' k ~depth:(depth + 1) names in (match e.view with - | E_type 0 -> Fmt.string out "type" - | E_type i -> Fmt.fprintf out "type_%d" i + | E_type 0 -> Fmt.string out "Type" + | E_type i -> Fmt.fprintf out "Type(%d)" i | E_var v -> Fmt.string out v.v_name (* | E_var v -> Fmt.fprintf out "(@[%s : %a@])" v.v_name pp v.v_ty *) | E_bound_var v -> let idx = v.bv_idx in (match CCList.nth_opt names idx with - | Some n when n <> "" -> Fmt.string out n - | _ -> - if idx < k then - Fmt.fprintf out "x_%d" (k - idx - 1) - else - Fmt.fprintf out "%%db_%d" (idx - k)) + | Some n when n <> "" -> Fmt.fprintf out "%s[%d]" n idx + | _ -> Fmt.fprintf out "_[%d]" idx) | E_const c -> Const.pp out c | (E_app _ | E_lam _) when depth > max_depth -> Fmt.fprintf out "@<1>…/%d" e.id @@ -65,7 +64,7 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = let f, args = unfold_app e in Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args | E_lam ("", _ty, bod) -> - Fmt.fprintf out "(@[\\x_%d:@[%a@].@ %a@])" k pp' _ty + Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) bod | E_lam (n, _ty, bod) -> @@ -80,7 +79,7 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = (loop (k + 1) ~depth:(depth + 1) ("" :: names)) bod | E_pi ("", _ty, bod) -> - Fmt.fprintf out "(@[Pi x_%d:@[%a@].@ %a@])" k pp' _ty + Fmt.fprintf out "(@[Pi _:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) bod | E_pi (n, _ty, bod) -> @@ -125,6 +124,8 @@ module Hcons = Hashcons.Make (struct | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 + | E_pi (_, ty1, bod1), E_pi (_, ty2, bod2) -> + equal ty1 ty2 && equal bod1 bod2 | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ | E_lam _ | E_pi _ ), _ ) -> @@ -168,9 +169,7 @@ let iter_shallow ~f (e : term) : unit = match e.view with | E_type _ -> () | _ -> - (match e.ty with - | None -> (* should be computed at build time *) assert false - | Some ty -> f false ty); + f false (ty e); (match e.view with | E_const _ -> () | E_type _ -> assert false @@ -284,13 +283,11 @@ let[@inline] is_type_ e = | E_type _ -> true | _ -> false -let[@inline] is_a_type e = is_type_ e || is_type_ (ty_exn e) - let iter_dag ?(seen = Tbl.create 8) ~iter_ty ~f e : unit = let rec loop e = if not (Tbl.mem seen e) then ( Tbl.add seen e (); - if iter_ty && not (is_type_ e) then loop (ty_exn e); + if iter_ty && not (is_type_ e) then loop (ty e); f e; iter_shallow e ~f:(fun _ u -> loop u) ) @@ -335,7 +332,7 @@ module Make_ = struct if is_type_ e then 0 else ( - let d1 = db_depth @@ ty_exn e in + let d1 = db_depth @@ ty e in let d2 = match view e with | E_type _ | E_const _ | E_var _ -> 0 @@ -351,7 +348,7 @@ module Make_ = struct if is_type_ e then false else - has_fvars (ty_exn e) + has_fvars (ty e) || match view e with | E_var _ -> true @@ -367,7 +364,7 @@ module Make_ = struct let[@inline] universe_of_ty_ (e : term) : int = match e.view with | E_type i -> i + 1 - | _ -> universe_ (ty_exn e) + | _ -> universe_ (ty e) module T_int_tbl = CCHashtbl.Make (struct type t = term * int @@ -376,11 +373,12 @@ module Make_ = struct let hash (t, k) = H.combine3 27 (hash t) (H.int k) end) + (* shift open bound variables of [e] by [n] *) let db_shift_ ~make (e : term) (n : int) = let rec loop e k : term = if is_closed e then e - else if is_a_type e then + else if is_type_ e then e else ( match view e with @@ -408,8 +406,10 @@ module Make_ = struct let db_0_replace_ ~make e ~by:u : term = let cache_ = T_int_tbl.create 8 in + (* recurse in subterm [e], under [k] intermediate binders (so any + bound variable under k is bound by them) *) let rec aux e k : term = - if is_a_type e then + if is_type_ e then e else if db_depth e < k then e @@ -417,7 +417,8 @@ module Make_ = struct match view e with | E_const _ -> e | E_bound_var bv when bv.bv_idx = k -> - (* replace here *) + (* replace [bv] with [u], and shift [u] to account for the + [k] intermediate binders we traversed to get to [bv] *) db_shift_ ~make u k | _ -> (* use the cache *) @@ -485,24 +486,30 @@ module Make_ = struct | E_var v -> Var.ty v | E_bound_var v -> Bvar.ty v | E_type i -> make (E_type (i + 1)) - | E_const c -> Const.ty c - | E_lam (name, ty, bod) -> + | E_const c -> + let ty = Const.ty c in + if not (is_closed ty) then + Error.errorf "const %a@ cannot have a non-closed type like %a" Const.pp + c pp_debug ty; + ty + | E_lam (name, ty_v, bod) -> (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) - let ty_bod = ty_exn bod in - make (E_pi (name, ty, ty_bod)) + let ty_bod = ty bod in + make (E_pi (name, ty_v, ty_bod)) | E_app (f, a) -> (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], is [ty_bod_f[x := a]] *) - let ty_f = ty_exn f in - let ty_a = ty_exn a in + let ty_f = ty f in + let ty_a = ty a in (match ty_f.view with | E_pi (_, ty_arg_f, ty_bod_f) -> (* check that the expected type matches *) if not (equal ty_arg_f ty_a) then Error.errorf - "@[<2>cannot apply %a to %a,@ expected argument type: %a@ actual: \ - %a@]" - pp_debug f pp_debug a pp_debug ty_arg_f pp_debug ty_a; + "@[<2>cannot @[apply `%a`@]@ @[to `%a`@],@ expected argument type: \ + `%a`@ @[actual: `%a`@]@]" + pp_debug f pp_debug a pp_debug_with_ids ty_arg_f pp_debug_with_ids + ty_a; db_0_replace_ ~make ty_bod_f ~by:a | _ -> Error.errorf @@ -510,23 +517,30 @@ module Make_ = struct pp_debug f pp_debug ty_f) | E_pi (_, ty, bod) -> (* TODO: check the actual triplets for COC *) - Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod; - let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) + 1 in + (*Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod;*) + let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) in make (E_type u) + let ty_assert_false_ () = assert false + (* hashconsing + computing metadata + computing type (for new terms) *) let rec make_ (store : store) view : term = - let e = { view; ty = None; id = -1; flags = 0 } in + let e = { view; ty = T_ty_delayed ty_assert_false_; id = -1; flags = 0 } in let e2 = Hcons.hashcons store.s_exprs e in if e == e2 then ( (* new term, compute metadata *) assert (store.s_uid land store_id_mask == store.s_uid); (* first, compute type *) - if not (is_type_ e) then ( + (match e.view with + | E_type i -> + (* cannot force type now, as it's an infinite tower of types. + Instead we will produce the type on demand. *) + let get_ty () = make_ store (E_type (i + 1)) in + e.ty <- T_ty_delayed get_ty + | _ -> let ty = compute_ty_ ~make:(make_ store) view in - e.ty <- Some ty - ); + e.ty <- T_ty ty); let has_fvars = compute_has_fvars_ e in e2.flags <- (compute_db_depth_ e lsl (1 + store_id_bits)) @@ -606,11 +620,6 @@ end include Make_ -let get_ty store e : term = - match e.view with - | E_type i -> type_of_univ store (i + 1) - | _ -> ty_exn e - (* re-export some internal things *) module Internal_ = struct let subst_ store ~recursive t subst = diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index 24d4382d..1040262a 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -65,12 +65,8 @@ val has_fvars : t -> bool (** Does the term contain free variables? time: O(1) *) -val ty_exn : t -> t -(** Return the type of this term. Fails if the term is a type. *) - -val get_ty : store -> t -> t -(** [get_ty store t] gets the type of [t], or computes it on demand - in case [t] is itself a type. *) +val ty : t -> t +(** Return the type of this term. *) (** {2 Creation} *) diff --git a/src/core-logic/types_.ml b/src/core-logic/types_.ml index f62a5922..69d6e95d 100644 --- a/src/core-logic/types_.ml +++ b/src/core-logic/types_.ml @@ -26,12 +26,14 @@ and const = { c_view: const_view; c_ops: const_ops; c_ty: term } and term = { view: term_view; (* computed on demand *) - mutable ty: term option; + mutable ty: term_ty_; mutable id: int; (* contains: [highest DB var | 1:has free vars | 5:ctx uid] *) mutable flags: int; } +and term_ty_ = T_ty of term | T_ty_delayed of (unit -> term) + module Term_ = struct let[@inline] equal (e1 : term) e2 : bool = e1 == e2 let[@inline] hash (e : term) = H.int e.id From e235a6556756d005214ab55a6d40541c39308030 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 14:51:43 -0400 Subject: [PATCH 031/174] test: add more to unittest/core-logic --- unittest/core-logic/t1.expected | 22 ++++++------ unittest/core-logic/t1.ml | 60 +++++++++++++++++++++++++++------ 2 files changed, 62 insertions(+), 20 deletions(-) diff --git a/unittest/core-logic/t1.expected b/unittest/core-logic/t1.expected index 292f26fc..cee32dd0 100644 --- a/unittest/core-logic/t1.expected +++ b/unittest/core-logic/t1.expected @@ -1,19 +1,21 @@ -type0 : type -typeof(type0) : type_1 -type tower: [type;type_1;type_2;type_3;type_4;type_5;type_6;type_7;type_8; - type_9] +type0 : Type +typeof(type0) : Type(1) +type tower: [Type;Type(1);Type(2);Type(3);Type(4)] a: a, b: b, typeof(a): Bool -pi Bool Bool b2b: (Bool -> Bool) p(a): p a p(b): p b q(a): q a q(b): q b typeof(p a): Bool -pi Bool Bool -pi Bool Bool -pi Bool (Bool -> Bool) -lxy_px: (\x:Bool. (\y:Bool. p x)) +lxy_px: (\x:Bool. (\y:Bool. p x[1])) type: (Bool -> (Bool -> Bool)) -lxy_px a b: ((\x:Bool. (\y:Bool. p x))) a b + type of type: Type +lxy_px a b: ((\x:Bool. (\y:Bool. p x[1]))) a b + type: Bool +(=): = + type: (Pi Alpha:Type. (Pi _:Alpha[0]. (Alpha[1] -> Bool))) +p2: p2 + type: (tau -> (tau -> Bool)) +t2: = ((tau -> (tau -> Bool))) ((\x:tau. (\y:tau. p2 x[1] y[0]))) (= tau) type: Bool diff --git a/unittest/core-logic/t1.ml b/unittest/core-logic/t1.ml index 30f09da3..4d6cec06 100644 --- a/unittest/core-logic/t1.ml +++ b/unittest/core-logic/t1.ml @@ -1,13 +1,13 @@ open Sidekick_core_logic let store = Store.create () -let t0 = Term.type_ store -let () = Fmt.printf "type0 : %a@." Term.pp_debug t0 -let () = Fmt.printf "typeof(type0) : %a@." Term.pp_debug (Term.get_ty store t0) +let type_ = Term.type_ store +let () = Fmt.printf "type0 : %a@." Term.pp_debug type_ +let () = Fmt.printf "typeof(type0) : %a@." Term.pp_debug (Term.ty type_) let l = - CCSeq.unfold (fun ty -> Some (ty, Term.get_ty store ty)) t0 - |> CCSeq.take 10 |> CCSeq.to_list + CCSeq.unfold (fun ty -> Some (ty, Term.ty ty)) type_ + |> CCSeq.take 5 |> CCSeq.to_list let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list Term.pp_debug) l let () = assert (Term.(equal (type_ store) (type_ store))) @@ -18,7 +18,7 @@ let b = Term.const store @@ Str_const.make "b" ~ty:bool let () = Fmt.printf "a: %a, b: %a, typeof(a): %a@." Term.pp_debug a Term.pp_debug b - Term.pp_debug (Term.ty_exn a) + Term.pp_debug (Term.ty a) let () = assert (Term.(equal a a)) let () = assert (not Term.(equal a b)) @@ -38,7 +38,7 @@ let () = assert (Term.(equal pa (app store p a))) (* *) -let ty_pa = Term.ty_exn pa +let ty_pa = Term.ty pa let () = Fmt.printf "typeof(p a): %a@." Term.pp_debug ty_pa (* *) @@ -50,10 +50,50 @@ let y = Term.var store v_y let lxy_px = Term.lam store v_x @@ Term.lam store v_y @@ Term.app store p x let () = - Fmt.printf "@[lxy_px: %a@ type: %a@]@." Term.pp_debug lxy_px Term.pp_debug - (Term.ty_exn lxy_px) + Fmt.printf "@[lxy_px: %a@ type: %a@ type of type: %a@]@." Term.pp_debug + lxy_px Term.pp_debug (Term.ty lxy_px) Term.pp_debug + (Term.ty @@ Term.ty lxy_px) let () = let t = Term.app_l store lxy_px [ a; b ] in Fmt.printf "@[lxy_px a b: %a@ type: %a@]@." Term.pp_debug t Term.pp_debug - (Term.ty_exn t) + (Term.ty t) + +(* *) + +let tau = Term.const store @@ Str_const.make "tau" ~ty:type_ + +let f_eq = + let vAlpha = Var.make "Alpha" type_ in + let tAlpha = Term.var store vAlpha in + Term.const store + @@ Str_const.make "=" + ~ty:Term.(pi store vAlpha @@ arrow_l store [ tAlpha; tAlpha ] bool) + +let () = + Fmt.printf "@[(=): %a@ type: %a@]@." Term.pp_debug f_eq Term.pp_debug + (Term.ty f_eq) + +let app_eq store x y = Term.app_l store f_eq [ Term.ty x; x; y ] + +let p2 = + Term.const store + @@ Str_const.make "p2" ~ty:Term.(arrow_l store [ tau; tau ] bool) + +let () = + Fmt.printf "@[p2: %a@ type: %a@]@." Term.pp_debug p2 Term.pp_debug + (Term.ty p2) + +let t2 = + let vx = Var.make "x" tau in + let vy = Var.make "y" tau in + let tX = Term.var store vx in + let tY = Term.var store vy in + Term.( + let t1 = lam store vx @@ lam store vy @@ app_l store p2 [ tX; tY ] + and t2 = app store f_eq tau in + app_eq store t1 t2) + +let () = + Fmt.printf "@[t2: %a@ type: %a@]@." Term.pp_debug t2 Term.pp_debug + (Term.ty t2) From e70daf4531ea90064f329f8388966ad58ff14c3e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 14:52:11 -0400 Subject: [PATCH 032/174] remove dead code --- src/core-ast/Hashcons.ml | 34 -- src/core-ast/ast.ml | 699 ------------------------------ src/core-ast/ast.mli | 143 ------ src/core-ast/const.ml | 26 -- src/core-ast/const.mli | 19 - src/core-ast/dune | 6 - src/core-ast/sidekick_core_ast.ml | 3 - 7 files changed, 930 deletions(-) delete mode 100644 src/core-ast/Hashcons.ml delete mode 100644 src/core-ast/ast.ml delete mode 100644 src/core-ast/ast.mli delete mode 100644 src/core-ast/const.ml delete mode 100644 src/core-ast/const.mli delete mode 100644 src/core-ast/dune delete mode 100644 src/core-ast/sidekick_core_ast.ml diff --git a/src/core-ast/Hashcons.ml b/src/core-ast/Hashcons.ml deleted file mode 100644 index 28ca6e21..00000000 --- a/src/core-ast/Hashcons.ml +++ /dev/null @@ -1,34 +0,0 @@ -module type ARG = sig - type t - - val equal : t -> t -> bool - val hash : t -> int - val set_id : t -> int -> unit -end - -module Make (A : ARG) : sig - type t - - val create : ?size:int -> unit -> t - val hashcons : t -> A.t -> A.t - val size : t -> int - val to_iter : t -> A.t Iter.t -end = struct - module W = Weak.Make (A) - - type t = { tbl: W.t; mutable n: int } - - let create ?(size = 1024) () : t = { tbl = W.create size; n = 0 } - - (* hashcons terms *) - let hashcons st t = - let t' = W.merge st.tbl t in - if t == t' then ( - st.n <- 1 + st.n; - A.set_id t' st.n - ); - t' - - let size st = W.count st.tbl - let to_iter st yield = W.iter yield st.tbl -end diff --git a/src/core-ast/ast.ml b/src/core-ast/ast.ml deleted file mode 100644 index 961b84aa..00000000 --- a/src/core-ast/ast.ml +++ /dev/null @@ -1,699 +0,0 @@ -(** Core AST *) - -module Const = Const -module H = CCHash - -type view = - | E_type of int - | E_var of var - | E_bound_var of bvar - | E_const of Const.t * t (* ty *) - | E_app of t * t - | E_lam of string * t * t - | E_pi of string * t * t - -and var = { v_name: string; v_ty: t } -and bvar = { bv_idx: int; bv_ty: t } - -and t = { - view: view; - (* computed on demand *) - mutable ty: t option; - mutable id: int; - (* contains: [highest DB var | 1:has free vars | 5:ctx uid] *) - mutable flags: int; -} - -type term = t - -(* 5 bits in [t.id] are used to store which store it belongs to, so we have - a chance of detecting when the user passes a term to the wrong store *) -let store_id_bits = 5 - -(* mask to access the store id *) -let store_id_mask = (1 lsl store_id_bits) - 1 -let[@inline] view (e : t) : view = e.view -let[@inline] equal (e1 : t) e2 : bool = e1 == e2 -let[@inline] hash (e : t) = H.int e.id -let[@inline] compare (e1 : t) e2 : int = CCInt.compare e1.id e2.id -let[@inline] db_depth e = e.flags lsr (1 + store_id_bits) -let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 -let[@inline] store_uid e : int = e.flags land store_id_mask -let[@inline] is_closed e : bool = db_depth e == 0 -let pp_debug_ = ref (fun _ _ -> assert false) - -let[@inline] ty_exn e : t = - match e.ty with - | Some x -> x - | None -> assert false - -module Var = struct - type t = var - - let compare a b : int = - if equal a.v_ty b.v_ty then - String.compare a.v_name b.v_name - else - compare a.v_ty b.v_ty - - let[@inline] name v = v.v_name - let[@inline] ty self = self.v_ty - let[@inline] equal v1 v2 = v1.v_name = v2.v_name && equal v1.v_ty v2.v_ty - let[@inline] hash v1 = H.combine3 5 (H.string v1.v_name) (hash v1.v_ty) - let[@inline] pp out v1 = Fmt.string out v1.v_name - let make v_name v_ty : t = { v_name; v_ty } - let makef fmt ty = Fmt.kasprintf (fun s -> make s ty) fmt - - let pp_with_ty out v = - Fmt.fprintf out "(@[%s :@ %a@])" v.v_name !pp_debug_ v.v_ty - - module AsKey = struct - type nonrec t = t - - let equal = equal - let compare = compare - let hash = hash - end - - module Map = CCMap.Make (AsKey) - module Set = CCSet.Make (AsKey) - module Tbl = CCHashtbl.Make (AsKey) -end - -module BVar = struct - type t = bvar - - let equal (v1 : t) v2 = v1.bv_idx = v2.bv_idx && equal v1.bv_ty v2.bv_ty - let hash v = H.combine2 (H.int v.bv_idx) (hash v.bv_ty) - let pp out v = Fmt.fprintf out "bv[%d]" v.bv_idx - let[@inline] ty self = self.bv_ty - let make i ty : t = { bv_idx = i; bv_ty = ty } -end - -(* open an application *) -let unfold_app (e : t) : t * t list = - let[@unroll 1] rec aux acc e = - match e.view with - | E_app (f, a) -> aux (a :: acc) f - | _ -> e, acc - in - aux [] e - -(* debug printer *) -let expr_pp_with_ ~pp_ids ~max_depth out (e : t) : unit = - let rec loop k ~depth names out e = - let pp' = loop' k ~depth:(depth + 1) names in - (match e.view with - | E_type 0 -> Fmt.string out "type" - | E_type i -> Fmt.fprintf out "type_%d" i - | E_var v -> Fmt.string out v.v_name - (* | E_var v -> Fmt.fprintf out "(@[%s : %a@])" v.v_name pp v.v_ty *) - | E_bound_var v -> - let idx = v.bv_idx in - (match CCList.nth_opt names idx with - | Some n when n <> "" -> Fmt.string out n - | _ -> - if idx < k then - Fmt.fprintf out "x_%d" (k - idx - 1) - else - Fmt.fprintf out "%%db_%d" (idx - k)) - | E_const (c, _) -> Const.pp out c - | (E_app _ | E_lam _) when depth > max_depth -> - Fmt.fprintf out "@<1>…/%d" e.id - | E_app _ -> - let f, args = unfold_app e in - Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args - | E_lam ("", _ty, bod) -> - Fmt.fprintf out "(@[\\x_%d:@[%a@].@ %a@])" k pp' _ty - (loop (k + 1) ~depth:(depth + 1) ("" :: names)) - bod - | E_lam (n, _ty, bod) -> - Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty - (loop (k + 1) ~depth:(depth + 1) (n :: names)) - bod - | E_pi (_, ty, bod) when is_closed bod -> - (* actually just an arrow *) - Fmt.fprintf out "(@[%a@ -> %a@])" - (loop k ~depth:(depth + 1) names) - ty - (loop (k + 1) ~depth:(depth + 1) ("" :: names)) - bod - | E_pi ("", _ty, bod) -> - Fmt.fprintf out "(@[Pi x_%d:@[%a@].@ %a@])" k pp' _ty - (loop (k + 1) ~depth:(depth + 1) ("" :: names)) - bod - | E_pi (n, _ty, bod) -> - Fmt.fprintf out "(@[Pi %s:@[%a@].@ %a@])" n pp' _ty - (loop (k + 1) ~depth:(depth + 1) (n :: names)) - bod); - if pp_ids then Fmt.fprintf out "/%d" e.id - and loop' k ~depth names out e = - match e.view with - | E_type _ | E_var _ | E_bound_var _ | E_const _ -> - loop k ~depth names out e (* atomic expr *) - | E_app _ | E_lam _ | E_pi _ -> - Fmt.fprintf out "(%a)" (loop k ~depth names) e - in - Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e - -let pp_debug = expr_pp_with_ ~pp_ids:false ~max_depth:max_int -let pp_debug_with_ids = expr_pp_with_ ~pp_ids:true ~max_depth:max_int -let () = pp_debug_ := pp_debug - -module AsKey = struct - type nonrec t = t - - let equal = equal - let compare = compare - let hash = hash -end - -module Map = CCMap.Make (AsKey) -module Set = CCSet.Make (AsKey) -module Tbl = CCHashtbl.Make (AsKey) - -module Hcons = Hashcons.Make (struct - type nonrec t = t - - let equal a b = - match a.view, b.view with - | E_type i, E_type j -> i = j - | E_const (c1, ty1), E_const (c2, ty2) -> Const.equal c1 c2 && equal ty1 ty2 - | E_var v1, E_var v2 -> Var.equal v1 v2 - | E_bound_var v1, E_bound_var v2 -> BVar.equal v1 v2 - | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 - | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> - equal ty1 ty2 && equal bod1 bod2 - | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ | E_lam _ - | E_pi _ ), - _ ) -> - false - - let hash e : int = - match e.view with - | E_type i -> H.combine2 10 (H.int i) - | E_const (c, ty) -> H.combine3 20 (Const.hash c) (hash ty) - | E_var v -> H.combine2 30 (Var.hash v) - | E_bound_var v -> H.combine2 40 (BVar.hash v) - | E_app (f, a) -> H.combine3 50 (hash f) (hash a) - | E_lam (_, ty, bod) -> H.combine3 60 (hash ty) (hash bod) - | E_pi (_, ty, bod) -> H.combine3 70 (hash ty) (hash bod) - - let set_id t id = - assert (t.id == -1); - t.id <- id -end) - -module Store = struct - type t = { (* unique ID for this store *) - s_uid: int; s_exprs: Hcons.t } - - (* TODO: use atomic? CCAtomic? *) - let n = ref 0 - - let create () : t = - let s_uid = !n in - incr n; - { s_uid; s_exprs = Hcons.create ~size:256 () } - - (* check that [e] belongs in this store *) - let[@inline] check_e_uid (self : t) (e : term) = - assert (self.s_uid == store_uid e) -end - -type store = Store.t - -let iter_shallow ~f (e : t) : unit = - match e.view with - | E_type _ -> () - | _ -> - (match e.ty with - | None -> (* should be computed at build time *) assert false - | Some ty -> f false ty); - (match e.view with - | E_const _ -> () - | E_type _ -> assert false - | E_var v -> f false v.v_ty - | E_bound_var v -> f false v.bv_ty - | E_app (hd, a) -> - f false hd; - f false a - | E_lam (_, tyv, bod) | E_pi (_, tyv, bod) -> - f false tyv; - f true bod) - -let map_shallow_ ~make ~f (e : t) : t = - match view e with - | E_type _ | E_const _ -> e - | E_var v -> - let v_ty = f false v.v_ty in - if v_ty == v.v_ty then - e - else - make (E_var { v with v_ty }) - | E_bound_var v -> - let ty' = f false v.bv_ty in - if v.bv_ty == ty' then - e - else - make (E_bound_var { v with bv_ty = ty' }) - | E_app (hd, a) -> - let hd' = f false hd in - let a' = f false a in - if a == a' && hd == hd' then - e - else - make (E_app (f false hd, f false a)) - | E_lam (n, tyv, bod) -> - let tyv' = f false tyv in - let bod' = f true bod in - if tyv == tyv' && bod == bod' then - e - else - make (E_lam (n, tyv', bod')) - | E_pi (n, tyv, bod) -> - let tyv' = f false tyv in - let bod' = f true bod in - if tyv == tyv' && bod == bod' then - e - else - make (E_pi (n, tyv', bod')) - -(* TODO - (* map immediate subterms *) - let map_shallow ctx ~f (e : t) : t = - match view e with - | E_kind | E_type | E_const (_, []) | E_box _ -> e - | _ -> - let ty' = - lazy - (match e.e_ty with - | (lazy None) -> None - | (lazy (Some ty)) -> Some (f false ty)) - in - (match view e with - | E_var v -> - let v_ty = f false v.v_ty in - if v_ty == v.v_ty then - e - else - make_ ctx (E_var { v with v_ty }) ty' - | E_const (c, args) -> - let args' = List.map (f false) args in - if List.for_all2 equal args args' then - e - else - make_ ctx (E_const (c, args')) ty' - | E_bound_var v -> - let ty' = f false v.bv_ty in - if v.bv_ty == ty' then - e - else - make_ ctx - (E_bound_var { v with bv_ty = ty' }) - (Lazy.from_val (Some ty')) - | E_app (hd, a) -> - let hd' = f false hd in - let a' = f false a in - if a == a' && hd == hd' then - e - else - make_ ctx (E_app (f false hd, f false a)) ty' - | E_lam (n, tyv, bod) -> - let tyv' = f false tyv in - let bod' = f true bod in - if tyv == tyv' && bod == bod' then - e - else - make_ ctx (E_lam (n, tyv', bod')) ty' - | E_arrow (a, b) -> - let a' = f false a in - let b' = f false b in - if a == a' && b == b' then - e - else - make_ ctx (E_arrow (a', b')) ty' - | E_kind | E_type | E_box _ -> assert false) -*) - -exception IsSub - -let[@inline] is_type_ e = - match e.view with - | E_type _ -> true - | _ -> false - -let[@inline] is_a_type e = is_type_ e || is_type_ (ty_exn e) - -let iter_dag ?(seen = Tbl.create 8) ~iter_ty ~f e : unit = - let rec loop e = - if not (Tbl.mem seen e) then ( - Tbl.add seen e (); - if iter_ty && not (is_type_ e) then loop (ty_exn e); - f e; - iter_shallow e ~f:(fun _ u -> loop u) - ) - in - loop e - -exception E_exit - -let exists_shallow ~f e : bool = - try - iter_shallow e ~f:(fun b x -> if f b x then raise_notrace E_exit); - false - with E_exit -> true - -let for_all_shallow ~f e : bool = - try - iter_shallow e ~f:(fun b x -> if not (f b x) then raise_notrace E_exit); - true - with E_exit -> false - -let contains e ~sub : bool = - try - iter_dag ~iter_ty:true e ~f:(fun e' -> - if equal e' sub then raise_notrace IsSub); - false - with IsSub -> true - -let free_vars_iter e : var Iter.t = - fun yield -> - iter_dag ~iter_ty:true e ~f:(fun e' -> - match view e' with - | E_var v -> yield v - | _ -> ()) - -let free_vars ?(init = Var.Set.empty) e : Var.Set.t = - let set = ref init in - free_vars_iter e (fun v -> set := Var.Set.add v !set); - !set - -module Make_ = struct - let compute_db_depth_ e : int = - if is_type_ e then - 0 - else ( - let d1 = db_depth @@ ty_exn e in - let d2 = - match view e with - | E_type _ | E_const _ | E_var _ -> 0 - | E_bound_var v -> v.bv_idx + 1 - | E_app (a, b) -> max (db_depth a) (db_depth b) - | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> - max (db_depth ty) (max 0 (db_depth bod - 1)) - in - max d1 d2 - ) - - let compute_has_fvars_ e : bool = - if is_type_ e then - false - else - has_fvars (ty_exn e) - || - match view e with - | E_var _ -> true - | E_type _ | E_bound_var _ | E_const _ -> false - | E_app (a, b) -> has_fvars a || has_fvars b - | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod - - let universe_ (e : t) : int = - match e.view with - | E_type i -> i - | _ -> assert false - - let[@inline] universe_of_ty_ (e : t) : int = - match e.view with - | E_type i -> i + 1 - | _ -> universe_ (ty_exn e) - - module T_int_tbl = CCHashtbl.Make (struct - type t = term * int - - let equal (t1, k1) (t2, k2) = equal t1 t2 && k1 == k2 - let hash (t, k) = H.combine3 27 (hash t) (H.int k) - end) - - let db_shift_ ~make (e : t) (n : int) = - let rec loop e k : t = - if is_closed e then - e - else if is_a_type e then - e - else ( - match view e with - | E_bound_var bv -> - if bv.bv_idx >= k then - make (E_bound_var (BVar.make (bv.bv_idx + n) bv.bv_ty)) - else - e - | _ -> - map_shallow_ e ~make ~f:(fun inbind u -> - loop u - (if inbind then - k + 1 - else - k)) - ) - in - assert (n >= 0); - if n = 0 || is_closed e then - e - else - loop e 0 - - (* replace DB0 in [e] with [u] *) - let db_0_replace_ ~make e ~by:u : t = - let cache_ = T_int_tbl.create 8 in - - let rec aux e k : t = - if is_a_type e then - e - else if db_depth e < k then - e - else ( - match view e with - | E_const _ -> e - | E_bound_var bv when bv.bv_idx = k -> - (* replace here *) - db_shift_ ~make u k - | _ -> - (* use the cache *) - (try T_int_tbl.find cache_ (e, k) - with Not_found -> - let r = - map_shallow_ e ~make ~f:(fun inb u -> - aux u - (if inb then - k + 1 - else - k)) - in - T_int_tbl.add cache_ (e, k) r; - r) - ) - in - if is_closed e then - e - else - aux e 0 - - type subst = { m: t Var.Map.t } [@@unboxed] - - let subst_ ~make ~recursive e0 (subst : subst) : t = - (* cache for types and some terms *) - let cache_ = T_int_tbl.create 16 in - - let rec loop k e = - try T_int_tbl.find cache_ (e, k) - with Not_found -> - let r = loop_uncached_ k e in - T_int_tbl.add cache_ (e, k) r; - r - and loop_uncached_ k (e : t) : t = - match view e with - | _ when not (has_fvars e) -> e (* nothing to subst in *) - | E_var v -> - (* first, subst in type *) - let v = { v with v_ty = loop k v.v_ty } in - (match Var.Map.find v subst.m with - | u -> - let u = db_shift_ ~make u k in - if recursive then - loop 0 u - else - u - | exception Not_found -> make (E_var v)) - | E_const _ -> e - | _ -> - map_shallow_ e ~make ~f:(fun inb u -> - loop - (if inb then - k + 1 - else - k) - u) - in - - if Var.Map.is_empty subst.m then - e0 - else - loop 0 e0 - - let compute_ty_ ~make (view : view) : t = - match view with - | E_var v -> Var.ty v - | E_bound_var v -> BVar.ty v - | E_type i -> make (E_type (i + 1)) - | E_const (_, ty) -> ty - | E_lam (name, ty, bod) -> - (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) - let ty_bod = ty_exn bod in - make (E_pi (name, ty, ty_bod)) - | E_app (f, a) -> - (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], - is [ty_bod_f[x := a]] *) - let ty_f = ty_exn f in - let ty_a = ty_exn a in - (match ty_f.view with - | E_pi (_, ty_arg_f, ty_bod_f) -> - (* check that the expected type matches *) - if not (equal ty_arg_f ty_a) then - Error.errorf - "@[<2>cannot apply %a to %a,@ expected argument type: %a@ actual: \ - %a@]" - pp_debug f pp_debug a pp_debug ty_arg_f pp_debug ty_a; - db_0_replace_ ~make ty_bod_f ~by:a - | _ -> - Error.errorf - "@[<2>cannot apply %a,@ must have Pi type, but actual type is %a@]" - pp_debug f pp_debug ty_f) - | E_pi (_, ty, bod) -> - (* TODO: check the actual triplets for COC *) - Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod; - let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) + 1 in - make (E_type u) - - (* hashconsing + computing metadata + computing type (for new terms) *) - let rec make_ (store : store) view : t = - let e = { view; ty = None; id = -1; flags = 0 } in - let e2 = Hcons.hashcons store.s_exprs e in - if e == e2 then ( - (* new term, compute metadata *) - assert (store.s_uid land store_id_mask == store.s_uid); - - (* first, compute type *) - if not (is_type_ e) then ( - let ty = compute_ty_ ~make:(make_ store) view in - e.ty <- Some ty - ); - let has_fvars = compute_has_fvars_ e in - e2.flags <- - (compute_db_depth_ e lsl (1 + store_id_bits)) - lor (if has_fvars then - 1 lsl store_id_bits - else - 0) - lor store.s_uid; - Store.check_e_uid store e2 - ); - e2 - - let type_of_univ store i : t = make_ store (E_type i) - let type_ store : t = type_of_univ store 0 - let var store v : t = make_ store (E_var v) - let var_str store name ~ty : t = var store (Var.make name ty) - let bvar store v : t = make_ store (E_bound_var v) - let const store c ~ty : t = make_ store (E_const (c, ty)) - let app store f a = make_ store (E_app (f, a)) - let app_l store f l = List.fold_left (app store) f l - - let abs_on_ (store : store) (v : var) (e : t) : t = - Store.check_e_uid store v.v_ty; - Store.check_e_uid store e; - if not (is_closed v.v_ty) then - Error.errorf "cannot abstract on variable@ with non closed type %a" - pp_debug v.v_ty; - let db0 = bvar store (BVar.make 0 v.v_ty) in - let body = db_shift_ ~make:(make_ store) e 1 in - subst_ ~make:(make_ store) ~recursive:false body - { m = Var.Map.singleton v db0 } - - let lam store v bod : t = - let bod' = abs_on_ store v bod in - make_ store (E_lam (Var.name v, Var.ty v, bod')) - - let pi store v bod : t = - let bod' = abs_on_ store v bod in - make_ store (E_pi (Var.name v, Var.ty v, bod')) - - let arrow store a b : t = - let b' = db_shift_ ~make:(make_ store) b 1 in - make_ store (E_pi ("", a, b')) - - let arrow_l store args ret = List.fold_right (arrow store) args ret - - (* find a name that doesn't capture a variable of [e] *) - let pick_name_ (name0 : string) (e : t) : string = - let rec loop i = - let name = - if i = 0 then - name0 - else - Printf.sprintf "%s%d" name0 i - in - if free_vars_iter e |> Iter.exists (fun v -> v.v_name = name) then - loop (i + 1) - else - name - in - loop 0 - - let open_lambda store e : _ option = - match view e with - | E_lam (name, ty, bod) -> - let name = pick_name_ name bod in - let v = Var.make name ty in - let bod' = db_0_replace_ bod ~make:(make_ store) ~by:(var store v) in - Some (v, bod') - | _ -> None - - let open_lambda_exn store e = - match open_lambda store e with - | Some tup -> tup - | None -> Error.errorf "open-lambda: term is not a lambda:@ %a" pp_debug e -end - -include Make_ - -let get_ty store e : t = - match e.view with - | E_type i -> type_of_univ store (i + 1) - | _ -> ty_exn e - -module Subst = struct - type t = subst - - let empty = { m = Var.Map.empty } - let is_empty self = Var.Map.is_empty self.m - let add v t self = { m = Var.Map.add v t self.m } - - let pp out (self : t) = - if is_empty self then - Fmt.string out "(subst)" - else ( - let pp_pair out (v, t) = - Fmt.fprintf out "(@[%a := %a@])" Var.pp v pp_debug t - in - Fmt.fprintf out "(@[subst@ %a@])" (Util.pp_iter pp_pair) - (Var.Map.to_iter self.m) - ) - - let of_list l = { m = Var.Map.of_list l } - let of_iter it = { m = Var.Map.of_iter it } - let to_iter self = Var.Map.to_iter self.m - - let apply (store : store) ~recursive (self : t) (e : term) : term = - subst_ ~make:(make_ store) ~recursive e self -end diff --git a/src/core-ast/ast.mli b/src/core-ast/ast.mli deleted file mode 100644 index 53121bb7..00000000 --- a/src/core-ast/ast.mli +++ /dev/null @@ -1,143 +0,0 @@ -(** Core AST. - - The core AST is composed of expressions in the calculus of constructions, - with no universe polymorphism nor cumulativity. It should be fast, with hashconsing; - and simple enough (no inductives, no universe trickery). - - It is intended to be the foundation for user-level terms and types and formulas. -*) - -module Const = Const - -(** {2 Main declarations} *) - -type t -(** An AST node, i.e. an expression in the calculus of constructions *) - -type term = t -type var = { v_name: string; v_ty: t } -type bvar = { bv_idx: int; bv_ty: t } - -type store -(** The store for these AST nodes. - - The store is responsible for allocating unique IDs to terms, and - enforcing their hashconsing (so that syntactic equality is just a pointer - comparison). *) - -(** View. - - A view is the shape of the root node of an AST. *) -type view = - | E_type of int - | E_var of var - | E_bound_var of bvar - | E_const of Const.t * t (* ty *) - | E_app of t * t - | E_lam of string * t * t - | E_pi of string * t * t - -include EQ_ORD_HASH with type t := t - -val pp_debug : t Fmt.printer -val pp_debug_with_ids : t Fmt.printer - -(** {2 Variables} *) - -(** Free variable *) -module Var : sig - type t = var - - include EQ_ORD_HASH_PRINT with type t := t - - val pp_with_ty : t Fmt.printer - val make : string -> term -> t - val makef : ('a, Format.formatter, unit, t) format4 -> term -> 'a - val name : t -> string - val ty : t -> term - - include WITH_SET_MAP_TBL with type t := t -end - -(** Bound variable *) -module BVar : sig - type t = bvar - - include EQ_HASH_PRINT with type t := t - - val make : int -> term -> t - val ty : t -> term -end - -(** {2 Containers} *) - -include WITH_SET_MAP_TBL with type t := t - -(** {2 Utils} *) - -val view : t -> view -val unfold_app : t -> t * t list -val iter_dag : ?seen:unit Tbl.t -> iter_ty:bool -> f:(t -> unit) -> t -> unit - -val iter_shallow : f:(bool -> t -> unit) -> t -> unit -(** [iter_shallow f e] iterates on immediate subterms of [e], - calling [f trdb e'] for each subterm [e'], with [trdb = true] iff - [e'] is directly under a binder. *) - -val exists_shallow : f:(bool -> t -> bool) -> t -> bool -val for_all_shallow : f:(bool -> t -> bool) -> t -> bool -val contains : t -> sub:t -> bool -val free_vars_iter : t -> var Iter.t -val free_vars : ?init:Var.Set.t -> t -> Var.Set.t - -val is_closed : t -> bool -(** Is the term closed (all bound variables are paired with a binder)? - time: O(1) *) - -val has_fvars : t -> bool -(** Does the term contain free variables? - time: O(1) *) - -val ty_exn : t -> t -(** Return the type of this term. Fails if the term is a type. *) - -val get_ty : store -> t -> t -(** [get_ty store t] gets the type of [t], or computes it on demand - in case [t] is itself a type. *) - -(** {2 Creation} *) - -module Store : sig - type t = store - - val create : unit -> t -end - -val type_ : store -> t -val type_of_univ : store -> int -> t -val var : store -> var -> t -val var_str : store -> string -> ty:t -> t -val const : store -> Const.t -> ty:t -> t -val app : store -> t -> t -> t -val app_l : store -> t -> t list -> t -val lam : store -> var -> t -> t -val pi : store -> var -> t -> t -val arrow : store -> t -> t -> t -val arrow_l : store -> t list -> t -> t -val open_lambda : store -> t -> (var * t) option -val open_lambda_exn : store -> t -> var * t - -(** Substitutions *) -module Subst : sig - type t - - include PRINT with type t := t - - val empty : t - val is_empty : t -> bool - val of_list : (var * term) list -> t - val of_iter : (var * term) Iter.t -> t - val to_iter : t -> (var * term) Iter.t - val add : var -> term -> t -> t - val apply : store -> recursive:bool -> t -> term -> term -end diff --git a/src/core-ast/const.ml b/src/core-ast/const.ml deleted file mode 100644 index 19f0ead6..00000000 --- a/src/core-ast/const.ml +++ /dev/null @@ -1,26 +0,0 @@ -type view = .. - -module type DYN_OPS = sig - val pp : view Fmt.printer - val equal : view -> view -> bool - val hash : view -> int -end - -type ops = (module DYN_OPS) -type t = { view: view; ops: ops } - -let view self = self.view - -let equal (a : t) b = - let (module O) = a.ops in - O.equal a.view b.view - -let hash (a : t) : int = - let (module O) = a.ops in - O.hash a.view - -let pp out (a : t) = - let (module O) = a.ops in - O.pp out a.view - -let make view ops : t = { view; ops } diff --git a/src/core-ast/const.mli b/src/core-ast/const.mli deleted file mode 100644 index b74550d4..00000000 --- a/src/core-ast/const.mli +++ /dev/null @@ -1,19 +0,0 @@ -(** Constants. - - Constants are logical symbols, defined by the user thanks to an open type *) - -type t -type view = .. - -module type DYN_OPS = sig - val pp : view Fmt.printer - val equal : view -> view -> bool - val hash : view -> int -end - -type ops = (module DYN_OPS) - -val view : t -> view -val make : view -> ops -> t - -include EQ_HASH_PRINT with type t := t diff --git a/src/core-ast/dune b/src/core-ast/dune deleted file mode 100644 index 127c083b..00000000 --- a/src/core-ast/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_core_ast) - (public_name sidekick.core-ast) - (synopsis "Core AST for logic terms and types") - (flags :standard -w +32 -open Sidekick_sigs -open Sidekick_util) - (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/core-ast/sidekick_core_ast.ml b/src/core-ast/sidekick_core_ast.ml deleted file mode 100644 index 525f825c..00000000 --- a/src/core-ast/sidekick_core_ast.ml +++ /dev/null @@ -1,3 +0,0 @@ -module Ast = Ast -include Ast -module Str_const = Str_const From c6407bfec1888afe27154af20f23ca75c5b85661 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 14:54:23 -0400 Subject: [PATCH 033/174] refactor a bit --- src/core-logic/term.ml | 89 +++++++++++++++++++++++------------------- 1 file changed, 49 insertions(+), 40 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 18e542e7..c0451f68 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -441,46 +441,6 @@ module Make_ = struct else aux e 0 - let subst_ ~make ~recursive e0 (subst : subst) : t = - (* cache for types and some terms *) - let cache_ = T_int_tbl.create 16 in - - let rec loop k e = - try T_int_tbl.find cache_ (e, k) - with Not_found -> - let r = loop_uncached_ k e in - T_int_tbl.add cache_ (e, k) r; - r - and loop_uncached_ k (e : t) : t = - match view e with - | _ when not (has_fvars e) -> e (* nothing to subst in *) - | E_var v -> - (* first, subst in type *) - let v = { v with v_ty = loop k v.v_ty } in - (match Var_.Map.find v subst.m with - | u -> - let u = db_shift_ ~make u k in - if recursive then - loop 0 u - else - u - | exception Not_found -> make (E_var v)) - | E_const _ -> e - | _ -> - map_shallow_ e ~make ~f:(fun inb u -> - loop - (if inb then - k + 1 - else - k) - u) - in - - if Var_.Map.is_empty subst.m then - e0 - else - loop 0 e0 - let compute_ty_ ~make (view : view) : term = match view with | E_var v -> Var.ty v @@ -562,6 +522,55 @@ module Make_ = struct let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l + (* general substitution, compatible with DB indices. We use this + also to abstract on a free variable, because it subsumes it and + it's better to minimize the number of DB indices manipulations *) + let subst_ ~make ~recursive e0 (subst : subst) : t = + (* cache for types and some terms *) + let cache_ = T_int_tbl.create 16 in + + let rec loop k e = + if is_type_ e then + e + else if not (has_fvars e) then + (* no free variables, cannot change *) + e + else ( + try T_int_tbl.find cache_ (e, k) + with Not_found -> + let r = loop_uncached_ k e in + T_int_tbl.add cache_ (e, k) r; + r + ) + and loop_uncached_ k (e : t) : t = + match view e with + | E_var v -> + (* first, subst in type *) + let v = { v with v_ty = loop k v.v_ty } in + (match Var_.Map.find v subst.m with + | u -> + let u = db_shift_ ~make u k in + if recursive then + loop 0 u + else + u + | exception Not_found -> make (E_var v)) + | E_const _ -> e + | _ -> + map_shallow_ e ~make ~f:(fun inb u -> + loop + (if inb then + k + 1 + else + k) + u) + in + + if Var_.Map.is_empty subst.m then + e0 + else + loop 0 e0 + let abs_on_ (store : store) (v : var) (e : term) : term = Store.check_e_uid store v.v_ty; Store.check_e_uid store e; From a4db8b6e946bb9f26433506fee7ddcfb4ddc03f8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 15:27:14 -0400 Subject: [PATCH 034/174] small improvement --- src/core-logic/term.ml | 59 ++++++++++++++++++++++----------- src/core-logic/term.mli | 35 ++++++++++++++++++- unittest/core-logic/t1.expected | 3 ++ unittest/core-logic/t1.ml | 15 +++++++++ 4 files changed, 92 insertions(+), 20 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index c0451f68..5053b3ef 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -441,24 +441,29 @@ module Make_ = struct else aux e 0 - let compute_ty_ ~make (view : view) : term = + let compute_ty_ store ~make (view : view) : term = match view with | E_var v -> Var.ty v | E_bound_var v -> Bvar.ty v | E_type i -> make (E_type (i + 1)) | E_const c -> let ty = Const.ty c in + Store.check_e_uid store ty; if not (is_closed ty) then Error.errorf "const %a@ cannot have a non-closed type like %a" Const.pp c pp_debug ty; ty | E_lam (name, ty_v, bod) -> + Store.check_e_uid store ty_v; + Store.check_e_uid store bod; (* type of [\x:tau. bod] is [pi x:tau. typeof(bod)] *) let ty_bod = ty bod in make (E_pi (name, ty_v, ty_bod)) | E_app (f, a) -> (* type of [f a], where [a:tau] and [f: Pi x:tau. ty_bod_f], is [ty_bod_f[x := a]] *) + Store.check_e_uid store f; + Store.check_e_uid store a; let ty_f = ty f in let ty_a = ty a in (match ty_f.view with @@ -478,6 +483,8 @@ module Make_ = struct | E_pi (_, ty, bod) -> (* TODO: check the actual triplets for COC *) (*Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod;*) + Store.check_e_uid store ty; + Store.check_e_uid store bod; let u = max (universe_of_ty_ ty) (universe_of_ty_ bod) in make (E_type u) @@ -499,7 +506,7 @@ module Make_ = struct let get_ty () = make_ store (E_type (i + 1)) in e.ty <- T_ty_delayed get_ty | _ -> - let ty = compute_ty_ ~make:(make_ store) view in + let ty = compute_ty_ store ~make:(make_ store) view in e.ty <- T_ty ty); let has_fvars = compute_has_fvars_ e in e2.flags <- @@ -571,28 +578,42 @@ module Make_ = struct else loop 0 e0 - let abs_on_ (store : store) (v : var) (e : term) : term = - Store.check_e_uid store v.v_ty; - Store.check_e_uid store e; - if not (is_closed v.v_ty) then - Error.errorf "cannot abstract on variable@ with non closed type %a" - pp_debug v.v_ty; - let db0 = bvar store (Bvar.make 0 v.v_ty) in - let body = db_shift_ ~make:(make_ store) e 1 in - subst_ ~make:(make_ store) ~recursive:false body - { m = Var_.Map.singleton v db0 } + module DB = struct + let subst_db0 store e ~by : t = db_0_replace_ ~make:(make_ store) e ~by + + let shift store t ~by : t = + assert (by >= 0); + db_shift_ ~make:(make_ store) t by + + let lam_db ?(var_name = "") store ~var_ty bod : term = + make_ store (E_lam (var_name, var_ty, bod)) + + let pi_db ?(var_name = "") store ~var_ty bod : term = + make_ store (E_pi (var_name, var_ty, bod)) + + let abs_on (store : store) (v : var) (e : term) : term = + Store.check_e_uid store v.v_ty; + Store.check_e_uid store e; + if not (is_closed v.v_ty) then + Error.errorf "cannot abstract on variable@ with non closed type %a" + pp_debug v.v_ty; + let db0 = bvar store (Bvar.make 0 v.v_ty) in + let body = db_shift_ ~make:(make_ store) e 1 in + subst_ ~make:(make_ store) ~recursive:false body + { m = Var_.Map.singleton v db0 } + end let lam store v bod : term = - let bod' = abs_on_ store v bod in - make_ store (E_lam (Var.name v, Var.ty v, bod')) + let bod' = DB.abs_on store v bod in + DB.lam_db ~var_name:(Var.name v) store ~var_ty:(Var.ty v) bod' let pi store v bod : term = - let bod' = abs_on_ store v bod in - make_ store (E_pi (Var.name v, Var.ty v, bod')) + let bod' = DB.abs_on store v bod in + DB.pi_db ~var_name:(Var.name v) store ~var_ty:(Var.ty v) bod' let arrow store a b : term = - let b' = db_shift_ ~make:(make_ store) b 1 in - make_ store (E_pi ("", a, b')) + let b' = DB.shift store b ~by:1 in + DB.pi_db store ~var_ty:a b' let arrow_l store args ret = List.fold_right (arrow store) args ret @@ -617,7 +638,7 @@ module Make_ = struct | E_lam (name, ty, bod) -> let name = pick_name_ name bod in let v = Var.make name ty in - let bod' = db_0_replace_ bod ~make:(make_ store) ~by:(var store v) in + let bod' = DB.subst_db0 store bod ~by:(var store v) in Some (v, bod') | _ -> None diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index 1040262a..44230ee5 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -80,7 +80,8 @@ val type_ : store -> t val type_of_univ : store -> int -> t val var : store -> var -> t val var_str : store -> string -> ty:t -> t -val const : store -> Const.t -> t +val bvar : store -> bvar -> t +val const : store -> const -> t val app : store -> t -> t -> t val app_l : store -> t -> t list -> t val lam : store -> var -> t -> t @@ -90,6 +91,38 @@ val arrow_l : store -> t list -> t -> t val open_lambda : store -> t -> (var * t) option val open_lambda_exn : store -> t -> var * t +(** De bruijn indices *) +module DB : sig + val lam_db : ?var_name:string -> store -> var_ty:t -> t -> t + (** [lam_db store ~var_ty bod] is [\ _:var_ty. bod]. Not DB shifting is done. *) + + val pi_db : ?var_name:string -> store -> var_ty:t -> t -> t + (** [pi_db store ~var_ty bod] is [pi _:var_ty. bod]. Not DB shifting is done. *) + + val subst_db0 : store -> t -> by:t -> t + (** [subst_db0 store t ~by] replaces bound variable 0 in [t] with + the term [by]. This is useful, for example, to implement beta-reduction. + + For example, with [t] being [_[0] = (\x. _[2] _[1] x[0])], + [subst_db0 store t ~by:"hello"] is ["hello" = (\x. _[2] "hello" x[0])]. + *) + + val shift : store -> t -> by:int -> t + (** [shift store t ~by] shifts all bound variables in [t] that are not + closed on, by amount [by] (which must be >= 0). + + For example, with term [t] being [\x. _[1] _[2] x[0]], + [shift store t ~by:5] is [\x. _[6] _[7] x[0]]. *) + + val abs_on : store -> var -> t -> t + (** [abs_on store v t] is the term [t[v := _[0]]]. It replaces [v] with + the bound variable with the same type as [v], and the DB index 0, + and takes care of shifting if [v] occurs under binders. + + For example, [abs_on store x (\y. x+y)] is [\y. _[1] y]. + *) +end + (**/**) module Internal_ : sig diff --git a/unittest/core-logic/t1.expected b/unittest/core-logic/t1.expected index cee32dd0..7f20f21c 100644 --- a/unittest/core-logic/t1.expected +++ b/unittest/core-logic/t1.expected @@ -19,3 +19,6 @@ p2: p2 type: (tau -> (tau -> Bool)) t2: = ((tau -> (tau -> Bool))) ((\x:tau. (\y:tau. p2 x[1] y[0]))) (= tau) type: Bool +f_vec: vec + type: (Type -> (nat -> Type)) + type of type: Type(1) diff --git a/unittest/core-logic/t1.ml b/unittest/core-logic/t1.ml index 4d6cec06..76fca53b 100644 --- a/unittest/core-logic/t1.ml +++ b/unittest/core-logic/t1.ml @@ -97,3 +97,18 @@ let t2 = let () = Fmt.printf "@[t2: %a@ type: %a@]@." Term.pp_debug t2 Term.pp_debug (Term.ty t2) + +(* a bit of dependent types *) + +let nat = Term.const store @@ Str_const.make "nat" ~ty:type_ + +let f_vec = + let v_A = Var.make "A" type_ in + let v_n = Var.make "n" nat in + Term.const store + @@ Str_const.make "vec" ~ty:Term.(pi store v_A @@ pi store v_n @@ type_ store) + +let () = + Fmt.printf "@[f_vec: %a@ type: %a@ type of type: %a@]@." Term.pp_debug + f_vec Term.pp_debug (Term.ty f_vec) Term.pp_debug + (Term.ty @@ Term.ty f_vec) From 68c03a39b3949fc702d1835c4484b48e9c6c4776 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 20:25:17 -0400 Subject: [PATCH 035/174] feat(core-logic): add a few builtins (=, bool, ite, not, true, false) --- src/core-logic/dune | 2 +- src/core-logic/sidekick_core_logic.ml | 1 + src/core-logic/t_builtins.ml | 84 +++++++++++++++++++++++++++ src/core-logic/t_builtins.mli | 32 ++++++++++ src/core-logic/term.ml | 66 +++------------------ src/core-logic/term.mli | 28 +++++++++ unittest/core-logic/t1.expected | 3 +- unittest/core-logic/t1.ml | 20 +++---- 8 files changed, 166 insertions(+), 70 deletions(-) create mode 100644 src/core-logic/t_builtins.ml create mode 100644 src/core-logic/t_builtins.mli diff --git a/src/core-logic/dune b/src/core-logic/dune index 5b7b4f4b..6786b301 100644 --- a/src/core-logic/dune +++ b/src/core-logic/dune @@ -1,6 +1,6 @@ (library (name sidekick_core_logic) (public_name sidekick.core-logic) - (synopsis "Core AST for logic terms and types") + (synopsis "Core AST for logic terms in the calculus of constructions") (flags :standard -w +32 -open Sidekick_sigs -open Sidekick_util) (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/core-logic/sidekick_core_logic.ml b/src/core-logic/sidekick_core_logic.ml index 5673f0c8..827a23a0 100644 --- a/src/core-logic/sidekick_core_logic.ml +++ b/src/core-logic/sidekick_core_logic.ml @@ -3,6 +3,7 @@ module Var = Var module Bvar = Bvar module Const = Const module Subst = Subst +module T_builtins = T_builtins (* *) diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml new file mode 100644 index 00000000..3b83a4f7 --- /dev/null +++ b/src/core-logic/t_builtins.ml @@ -0,0 +1,84 @@ +open Types_ +open Term + +type const_view += C_bool | C_eq | C_ite | C_not | C_true | C_false + +let ops : const_ops = + (module struct + let equal a b = + match a, b with + | C_bool, C_bool + | C_eq, C_eq + | C_ite, C_ite + | C_not, C_not + | C_true, C_true + | C_false, C_false -> + true + | _ -> false + + let hash = function + | C_bool -> CCHash.int 167 + | C_eq -> CCHash.int 168 + | C_ite -> CCHash.int 169 + | C_not -> CCHash.int 170 + | C_true -> CCHash.int 171 + | C_false -> CCHash.int 172 + | _ -> assert false + + let pp out = function + | C_bool -> Fmt.string out "Bool" + | C_eq -> Fmt.string out "=" + | C_ite -> Fmt.string out "ite" + | C_not -> Fmt.string out "not" + | C_true -> Fmt.string out "true" + | C_false -> Fmt.string out "false" + | _ -> assert false + end) + +let bool store = const store @@ Const.make C_bool ops ~ty:(type_ store) +let true_ store = const store @@ Const.make C_true ops ~ty:(bool store) +let false_ store = const store @@ Const.make C_false ops ~ty:(bool store) + +let c_eq store = + let type_ = type_ store in + let v = bvar_i store 0 ~ty:type_ in + let ty = + DB.pi_db ~var_name:"A" store ~var_ty:type_ + @@ arrow_l store [ v; v ] (bool store) + in + const store @@ Const.make C_eq ops ~ty + +let c_ite store = + let type_ = type_ store in + let v = bvar_i store 0 ~ty:type_ in + let ty = + DB.pi_db ~var_name:"A" store ~var_ty:type_ + @@ arrow_l store [ bool store; v; v ] v + in + const store @@ Const.make C_eq ops ~ty + +let c_not store = + let b = bool store in + let ty = arrow store b b in + const store @@ Const.make C_not ops ~ty + +let eq store a b = app_l store (c_eq store) [ ty a; a; b ] +let ite store a b c = app_l store (c_ite store) [ ty b; a; b; c ] +let not store a = app store (c_not store) a + +let is_bool t = + match view t with + | E_const { c_view = C_bool; _ } -> true + | _ -> false + +let is_eq t = + match view t with + | E_const { c_view = C_eq; _ } -> true + | _ -> false + +let rec abs t = + match view t with + | E_app ({ view = E_const { c_view = C_not; _ }; _ }, u) -> + let sign, v = abs u in + Stdlib.not sign, v + | _ -> true, t diff --git a/src/core-logic/t_builtins.mli b/src/core-logic/t_builtins.mli new file mode 100644 index 00000000..9f090b58 --- /dev/null +++ b/src/core-logic/t_builtins.mli @@ -0,0 +1,32 @@ +(** Core builtins *) + +open Types_ +open Term + +type const_view += C_bool | C_eq | C_ite | C_not | C_true | C_false + +val bool : store -> t +val c_not : store -> t +val c_eq : store -> t +val c_ite : store -> t +val true_ : store -> t +val false_ : store -> t + +val eq : store -> t -> t -> t +(** [eq a b] is [a = b] *) + +val not : store -> t -> t + +val ite : store -> t -> t -> t -> t +(** [ite a b c] is [if a then b else c] *) + +val is_eq : t -> bool +val is_bool : t -> bool + +val abs : t -> bool * t +(** [abs t] returns an "absolute value" for the term, along with the + sign of [t]. + + The idea is that we want to turn [not a] into [(false, a)], + or [(a != b)] into [(false, a=b)]. For terms without a negation this + should return [(true, t)]. *) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 5053b3ef..2c0330eb 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -1,5 +1,9 @@ open Types_ +type nonrec var = var +type nonrec bvar = bvar +type nonrec term = term + type view = term_view = | E_type of int | E_var of var @@ -219,63 +223,6 @@ let map_shallow_ ~make ~f (e : term) : term = else make (E_pi (n, tyv', bod')) -(* TODO - (* map immediate subterms *) - let map_shallow ctx ~f (e : t) : t = - match view e with - | E_kind | E_type | E_const (_, []) | E_box _ -> e - | _ -> - let ty' = - lazy - (match e.e_ty with - | (lazy None) -> None - | (lazy (Some ty)) -> Some (f false ty)) - in - (match view e with - | E_var v -> - let v_ty = f false v.v_ty in - if v_ty == v.v_ty then - e - else - make_ ctx (E_var { v with v_ty }) ty' - | E_const (c, args) -> - let args' = List.map (f false) args in - if List.for_all2 equal args args' then - e - else - make_ ctx (E_const (c, args')) ty' - | E_bound_var v -> - let ty' = f false v.bv_ty in - if v.bv_ty == ty' then - e - else - make_ ctx - (E_bound_var { v with bv_ty = ty' }) - (Lazy.from_val (Some ty')) - | E_app (hd, a) -> - let hd' = f false hd in - let a' = f false a in - if a == a' && hd == hd' then - e - else - make_ ctx (E_app (f false hd, f false a)) ty' - | E_lam (n, tyv, bod) -> - let tyv' = f false tyv in - let bod' = f true bod in - if tyv == tyv' && bod == bod' then - e - else - make_ ctx (E_lam (n, tyv', bod')) ty' - | E_arrow (a, b) -> - let a' = f false a in - let b' = f false b in - if a == a' && b == b' then - e - else - make_ ctx (E_arrow (a', b')) ty' - | E_kind | E_type | E_box _ -> assert false) -*) - exception IsSub let[@inline] is_type_ e = @@ -525,6 +472,7 @@ module Make_ = struct let var store v : term = make_ store (E_var v) let var_str store name ~ty : term = var store (Var.make name ty) let bvar store v : term = make_ store (E_bound_var v) + let bvar_i store i ~ty : term = make_ store (E_bound_var (Bvar.make i ty)) let const store c : term = make_ store (E_const c) let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l @@ -650,8 +598,12 @@ end include Make_ +let map_shallow store ~f e : t = map_shallow_ ~make:(make_ store) ~f e + (* re-export some internal things *) module Internal_ = struct + let is_type_ = is_type_ + let subst_ store ~recursive t subst = subst_ ~make:(make_ store) ~recursive t subst end diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index 44230ee5..dfb2a65f 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -9,6 +9,10 @@ open Types_ +type nonrec var = var +type nonrec bvar = bvar +type nonrec term = term + type t = term (** A term, in the calculus of constructions *) @@ -44,13 +48,35 @@ include WITH_SET_MAP_TBL with type t := t val view : t -> view val unfold_app : t -> t * t list + val iter_dag : ?seen:unit Tbl.t -> iter_ty:bool -> f:(t -> unit) -> t -> unit +(** [iter_dag t ~f] calls [f] once on each subterm of [t], [t] included. + It must {b not} traverse [t] as a tree, but rather as a + perfectly shared DAG. + + For example, in: + {[ + let x = 2 in + let y = f x x in + let z = g y x in + z = z + ]} + + the DAG has the following nodes: + + {[ n1: 2 + n2: f n1 n1 + n3: g n2 n1 + n4: = n3 n3 + ]} + *) val iter_shallow : f:(bool -> t -> unit) -> t -> unit (** [iter_shallow f e] iterates on immediate subterms of [e], calling [f trdb e'] for each subterm [e'], with [trdb = true] iff [e'] is directly under a binder. *) +val map_shallow : store -> f:(bool -> t -> t) -> t -> t val exists_shallow : f:(bool -> t -> bool) -> t -> bool val for_all_shallow : f:(bool -> t -> bool) -> t -> bool val contains : t -> sub:t -> bool @@ -81,6 +107,7 @@ val type_of_univ : store -> int -> t val var : store -> var -> t val var_str : store -> string -> ty:t -> t val bvar : store -> bvar -> t +val bvar_i : store -> int -> ty:t -> t val const : store -> const -> t val app : store -> t -> t -> t val app_l : store -> t -> t list -> t @@ -126,6 +153,7 @@ end (**/**) module Internal_ : sig + val is_type_ : t -> bool val subst_ : store -> recursive:bool -> t -> subst -> t end diff --git a/unittest/core-logic/t1.expected b/unittest/core-logic/t1.expected index 7f20f21c..42a1949f 100644 --- a/unittest/core-logic/t1.expected +++ b/unittest/core-logic/t1.expected @@ -1,6 +1,7 @@ type0 : Type typeof(type0) : Type(1) type tower: [Type;Type(1);Type(2);Type(3);Type(4)] +Bool: [true, false] a: a, b: b, typeof(a): Bool b2b: (Bool -> Bool) p(a): p a @@ -14,7 +15,7 @@ lxy_px: (\x:Bool. (\y:Bool. p x[1])) lxy_px a b: ((\x:Bool. (\y:Bool. p x[1]))) a b type: Bool (=): = - type: (Pi Alpha:Type. (Pi _:Alpha[0]. (Alpha[1] -> Bool))) + type: (Pi A:Type. (Pi _:A[0]. (A[1] -> Bool))) p2: p2 type: (tau -> (tau -> Bool)) t2: = ((tau -> (tau -> Bool))) ((\x:tau. (\y:tau. p2 x[1] y[0]))) (= tau) diff --git a/unittest/core-logic/t1.ml b/unittest/core-logic/t1.ml index 76fca53b..0619a06a 100644 --- a/unittest/core-logic/t1.ml +++ b/unittest/core-logic/t1.ml @@ -11,7 +11,13 @@ let l = let () = Fmt.printf "type tower: %a@." (Fmt.Dump.list Term.pp_debug) l let () = assert (Term.(equal (type_ store) (type_ store))) -let bool = Term.const store @@ Str_const.make "Bool" ~ty:(Term.type_ store) +let bool = T_builtins.bool store + +let () = + Fmt.printf "%a: [%a, %a]@." Term.pp_debug (T_builtins.bool store) + Term.pp_debug (T_builtins.true_ store) Term.pp_debug + (T_builtins.false_ store) + let a = Term.const store @@ Str_const.make "a" ~ty:bool let a' = Term.const store @@ Str_const.make "a" ~ty:bool let b = Term.const store @@ Str_const.make "b" ~ty:bool @@ -62,20 +68,12 @@ let () = (* *) let tau = Term.const store @@ Str_const.make "tau" ~ty:type_ - -let f_eq = - let vAlpha = Var.make "Alpha" type_ in - let tAlpha = Term.var store vAlpha in - Term.const store - @@ Str_const.make "=" - ~ty:Term.(pi store vAlpha @@ arrow_l store [ tAlpha; tAlpha ] bool) +let f_eq = T_builtins.c_eq store let () = Fmt.printf "@[(=): %a@ type: %a@]@." Term.pp_debug f_eq Term.pp_debug (Term.ty f_eq) -let app_eq store x y = Term.app_l store f_eq [ Term.ty x; x; y ] - let p2 = Term.const store @@ Str_const.make "p2" ~ty:Term.(arrow_l store [ tau; tau ] bool) @@ -92,7 +90,7 @@ let t2 = Term.( let t1 = lam store vx @@ lam store vy @@ app_l store p2 [ tX; tY ] and t2 = app store f_eq tau in - app_eq store t1 t2) + T_builtins.eq store t1 t2) let () = Fmt.printf "@[t2: %a@ type: %a@]@." Term.pp_debug t2 Term.pp_debug From c1af4374bd33446eb8a4d75bc3f461ed8e7c284c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 23:12:18 -0400 Subject: [PATCH 036/174] core-logic: make Types_ private --- src/core-logic/dune | 1 + src/core-logic/sidekick_core_logic.ml | 2 ++ 2 files changed, 3 insertions(+) diff --git a/src/core-logic/dune b/src/core-logic/dune index 6786b301..3fed959c 100644 --- a/src/core-logic/dune +++ b/src/core-logic/dune @@ -2,5 +2,6 @@ (name sidekick_core_logic) (public_name sidekick.core-logic) (synopsis "Core AST for logic terms in the calculus of constructions") + (private_modules types_) (flags :standard -w +32 -open Sidekick_sigs -open Sidekick_util) (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/core-logic/sidekick_core_logic.ml b/src/core-logic/sidekick_core_logic.ml index 827a23a0..faef37b1 100644 --- a/src/core-logic/sidekick_core_logic.ml +++ b/src/core-logic/sidekick_core_logic.ml @@ -8,4 +8,6 @@ module T_builtins = T_builtins (* *) module Store = Term.Store + +(* TODO: move to separate library? *) module Str_const = Str_const From 65c687285341fcc591fa186444ae361eb011c41d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 23:30:42 -0400 Subject: [PATCH 037/174] details: synopsis in dune files --- src/memtrace/dune | 1 + src/zarith/dune | 1 + 2 files changed, 2 insertions(+) diff --git a/src/memtrace/dune b/src/memtrace/dune index 7f941802..14f504c4 100644 --- a/src/memtrace/dune +++ b/src/memtrace/dune @@ -1,6 +1,7 @@ (library (name sidekick_memtrace) (public_name sidekick.memtrace) + (synopsis "optional interface to memtrace") (libraries (select sidekick_memtrace.ml diff --git a/src/zarith/dune b/src/zarith/dune index e5147828..dc584fce 100644 --- a/src/zarith/dune +++ b/src/zarith/dune @@ -1,6 +1,7 @@ (library (name sidekick_zarith) (public_name sidekick.zarith) + (synopsis "Interface to zarith (optional) for arithmetic") (optional) ; dep on zarith (flags :standard -warn-error -a+8) (libraries sidekick.core sidekick.arith zarith)) From 9df981d650cfdfb14e11a7b3a383f99dd15ece22 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 28 Jul 2022 23:30:56 -0400 Subject: [PATCH 038/174] feat(core): concrete lit, proof traces, proof terms --- src/core/Sidekick_core.ml | 22 ++++++++----- src/core/dune | 4 +-- src/core/lit.ml | 40 ++++++++++++++++++++++++ src/core/lit.mli | 42 +++++++++++++++++++++++++ src/core/proof_core.ml | 38 +++++++++++++++++++++++ src/core/proof_core.mli | 59 +++++++++++++++++++++++++++++++++++ src/core/proof_sat.ml | 8 +++++ src/core/proof_sat.mli | 15 +++++++++ src/core/proof_term.ml | 24 +++++++++++++++ src/core/proof_term.mli | 26 ++++++++++++++++ src/core/proof_trace.ml | 49 +++++++++++++++++++++++++++++ src/core/proof_trace.mli | 65 +++++++++++++++++++++++++++++++++++++++ 12 files changed, 381 insertions(+), 11 deletions(-) create mode 100644 src/core/lit.ml create mode 100644 src/core/lit.mli create mode 100644 src/core/proof_core.ml create mode 100644 src/core/proof_core.mli create mode 100644 src/core/proof_sat.ml create mode 100644 src/core/proof_sat.mli create mode 100644 src/core/proof_term.ml create mode 100644 src/core/proof_term.mli create mode 100644 src/core/proof_trace.ml create mode 100644 src/core/proof_trace.mli diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index 5fc40415..e4e4ede8 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -3,7 +3,7 @@ Theories and concrete solvers rely on an environment that defines several important types: - - sorts + - types - terms (to represent logic expressions and formulas) - a congruence closure instance - a bridge to some SAT solver @@ -14,12 +14,18 @@ module Fmt = CCFormat -module type TERM = Sidekick_sigs_term.S -module type LIT = Sidekick_sigs_lit.S -module type PROOF_TRACE = Sidekick_sigs_proof_trace.S +(* re-export *) -module type SAT_PROOF_RULES = Sidekick_sigs_proof_sat.S -(** Signature for SAT-solver proof emission. *) +module Const = Sidekick_core_logic.Const -module type PROOF_CORE = Sidekick_sigs_proof_core.S -(** Proofs of unsatisfiability. *) +module Term = struct + include Sidekick_core_logic.Term + include Sidekick_core_logic.T_builtins +end + +module Var = Sidekick_core_logic.Var +module Bvar = Sidekick_core_logic.Bvar +module Subst = Sidekick_core_logic.Subst +module Proof_trace = Proof_trace +module Proof_sat = Proof_sat +module Proof_core = Proof_core diff --git a/src/core/dune b/src/core/dune index b95bfa59..77bcd53e 100644 --- a/src/core/dune +++ b/src/core/dune @@ -2,6 +2,4 @@ (name Sidekick_core) (public_name sidekick.core) (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.util sidekick.sigs.proof-trace - sidekick.sigs.term sidekick.sigs.lit sidekick.sigs.proof.sat - sidekick.sigs.proof.core sidekick.sigs.cc)) + (libraries containers iter sidekick.util sidekick.sigs sidekick.core-logic)) diff --git a/src/core/lit.ml b/src/core/lit.ml new file mode 100644 index 00000000..eb91d2da --- /dev/null +++ b/src/core/lit.ml @@ -0,0 +1,40 @@ +open Sidekick_core_logic +module T = Term + +type term = T.t +type t = { lit_term: term; lit_sign: bool } + +let[@inline] neg l = { l with lit_sign = not l.lit_sign } +let[@inline] sign t = t.lit_sign +let[@inline] abs t = { t with lit_sign = true } +let[@inline] term (t : t) : term = t.lit_term +let[@inline] signed_term t = term t, sign t +let make ~sign t = { lit_sign = sign; lit_term = t } + +let atom ?(sign = true) (t : term) : t = + let sign', t = T_builtins.abs t in + let sign = + if not sign' then + not sign + else + sign + in + make ~sign t + +let equal a b = a.lit_sign = b.lit_sign && T.equal a.lit_term b.lit_term + +let hash a = + let sign = a.lit_sign in + CCHash.combine3 2 (CCHash.bool sign) (T.hash a.lit_term) + +let pp out l = + if l.lit_sign then + T.pp_debug out l.lit_term + else + Format.fprintf out "(@[@<1>¬@ %a@])" T.pp_debug l.lit_term + +let norm_sign l = + if l.lit_sign then + l, true + else + neg l, false diff --git a/src/core/lit.mli b/src/core/lit.mli new file mode 100644 index 00000000..25fe65e7 --- /dev/null +++ b/src/core/lit.mli @@ -0,0 +1,42 @@ +(** Literals + + Literals are a pair of a boolean-sorted term, and a sign. + Positive literals are the same as their term, and negative literals + are the negation of their term. + + The SAT solver deals only in literals and clauses (sets of literals). + Everything else belongs in the SMT solver. *) + +open Sidekick_core_logic + +type term = Term.t + +type t +(** A literal *) + +include Sidekick_sigs.EQ_HASH_PRINT with type t := t + +val term : t -> term +(** Get the (positive) term *) + +val sign : t -> bool +(** Get the sign. A negated literal has sign [false]. *) + +val neg : t -> t +(** Take negation of literal. [sign (neg lit) = not (sign lit)]. *) + +val abs : t -> t +(** [abs lit] is like [lit] but always positive, i.e. [sign (abs lit) = true] *) + +val signed_term : t -> term * bool +(** Return the atom and the sign *) + +val atom : ?sign:bool -> term -> t +(** [atom store t] makes a literal out of a term, possibly normalizing + its sign in the process. + @param sign if provided, and [sign=false], negate the resulting lit. *) + +val norm_sign : t -> t * bool +(** [norm_sign (+t)] is [+t, true], + and [norm_sign (-t)] is [+t, false]. + In both cases the term is positive, and the boolean reflects the initial sign. *) diff --git a/src/core/proof_core.ml b/src/core/proof_core.ml new file mode 100644 index 00000000..c6b65106 --- /dev/null +++ b/src/core/proof_core.ml @@ -0,0 +1,38 @@ +(* FIXME + open Proof_trace + + type lit = Lit.t +*) + +type lit = Lit.t + +let lemma_cc lits : Proof_term.t = Proof_term.make ~lits "core.lemma-cc" + +let define_term t1 t2 = + Proof_term.make ~terms:(Iter.of_list [ t1; t2 ]) "core.define-term" + +let proof_r1 p1 p2 = + Proof_term.make ~premises:(Iter.of_list [ p1; p2 ]) "core.r1" + +let proof_p1 p1 p2 = + Proof_term.make ~premises:(Iter.of_list [ p1; p2 ]) "core.p1" + +let proof_res ~pivot p1 p2 = + Proof_term.make ~terms:(Iter.return pivot) + ~premises:(Iter.of_list [ p1; p2 ]) + "core.res" + +let with_defs pr defs = + Proof_term.make ~premises:(Iter.append (Iter.return pr) defs) "core.with-defs" + +let lemma_true t = Proof_term.make ~terms:(Iter.return t) "core.true" + +let lemma_preprocess t1 t2 ~using = + Proof_term.make + ~terms:(Iter.of_list [ t1; t2 ]) + ~premises:using "core.preprocess" + +let lemma_rw_clause pr ~res ~using = + Proof_term.make + ~premises:(Iter.append (Iter.return pr) using) + ~lits:res "core.rw-clause" diff --git a/src/core/proof_core.mli b/src/core/proof_core.mli new file mode 100644 index 00000000..3641c14d --- /dev/null +++ b/src/core/proof_core.mli @@ -0,0 +1,59 @@ +(** Core proofs for SMT and congruence closure. *) + +open Sidekick_core_logic + +type lit = Lit.t + +val lemma_cc : lit Iter.t -> Proof_term.t +(** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory + of uninterpreted functions. *) + +val define_term : Term.t -> Term.t -> Proof_term.t +(** [define_term cst u proof] defines the new constant [cst] as being equal + to [u]. + The result is a proof of the clause [cst = u] *) + +val proof_p1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t +(** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) + and [p2] proves [C \/ t], is the Proof_term.t that produces [C \/ u], + i.e unit paramodulation. *) + +val proof_r1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t +(** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) + and [p2] proves [C \/ ¬t], is the Proof_term.t that produces [C \/ u], + i.e unit resolution. *) + +val proof_res : + pivot:Term.t -> Proof_term.step_id -> Proof_term.step_id -> Proof_term.t +(** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] + and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], + is the Proof_term.t that produces [C \/ D], i.e boolean resolution. *) + +val with_defs : Proof_term.step_id -> Proof_term.step_id Iter.t -> Proof_term.t +(** [with_defs pr defs] specifies that [pr] is valid only in + a context where the definitions [defs] are present. *) + +val lemma_true : Term.t -> Proof_term.t +(** [lemma_true (true) p] asserts the clause [(true)] *) + +val lemma_preprocess : + Term.t -> Term.t -> using:Proof_term.step_id Iter.t -> Proof_term.t +(** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology + and that [t] has been preprocessed into [u]. + + The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence + closure, and then resolved against the clauses [using] to obtain + a unit equality. + + From now on, [t] and [u] will be used interchangeably. + @return a Proof_term.t ID for the clause [(t=u)]. *) + +val lemma_rw_clause : + Proof_term.step_id -> + res:lit Iter.t -> + using:Proof_term.step_id Iter.t -> + Proof_term.t +(** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], + uses the equations [|- p_i = q_i] from [using] + to rewrite some literals of [c] into [res]. This is used to preprocess + literals of a clause (using {!lemma_preprocess} individually). *) diff --git a/src/core/proof_sat.ml b/src/core/proof_sat.ml new file mode 100644 index 00000000..15cb809b --- /dev/null +++ b/src/core/proof_sat.ml @@ -0,0 +1,8 @@ +type lit = Lit.t + +let sat_input_clause lits : Proof_term.t = Proof_term.make "sat.input" ~lits + +let sat_redundant_clause lits ~hyps : Proof_term.t = + Proof_term.make "sat.rup" ~lits ~premises:hyps + +let sat_unsat_core lits : Proof_term.t = Proof_term.make ~lits "sat.unsat-core" diff --git a/src/core/proof_sat.mli b/src/core/proof_sat.mli new file mode 100644 index 00000000..c9d89a54 --- /dev/null +++ b/src/core/proof_sat.mli @@ -0,0 +1,15 @@ +(** SAT-solver proof emission. *) + +open Proof_term + +type lit = Lit.t + +val sat_input_clause : lit Iter.t -> Proof_term.t +(** Emit an input clause. *) + +val sat_redundant_clause : lit Iter.t -> hyps:step_id Iter.t -> Proof_term.t +(** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. + The clause must be RUP wrt [hyps]. *) + +val sat_unsat_core : lit Iter.t -> Proof_term.t +(** TODO: is this relevant here? *) diff --git a/src/core/proof_term.ml b/src/core/proof_term.ml new file mode 100644 index 00000000..d8ec7882 --- /dev/null +++ b/src/core/proof_term.ml @@ -0,0 +1,24 @@ +open Sidekick_core_logic + +type step_id = int32 +type lit = Lit.t + +type t = { + rule_name: string; + lit_args: lit Iter.t; + term_args: Term.t Iter.t; + subst_args: Subst.t Iter.t; + premises: step_id Iter.t; +} + +let pp out _ = Fmt.string out "" (* TODO *) + +let make ?(lits = Iter.empty) ?(terms = Iter.empty) ?(substs = Iter.empty) + ?(premises = Iter.empty) rule_name : t = + { + rule_name; + lit_args = lits; + subst_args = substs; + term_args = terms; + premises; + } diff --git a/src/core/proof_term.mli b/src/core/proof_term.mli new file mode 100644 index 00000000..9b56cb97 --- /dev/null +++ b/src/core/proof_term.mli @@ -0,0 +1,26 @@ +(** Proof terms. + + A proof term is the description of a reasoning step, that yields a clause. *) + +open Sidekick_core_logic + +type step_id = int32 +type lit = Lit.t + +type t = { + rule_name: string; + lit_args: lit Iter.t; + term_args: Term.t Iter.t; + subst_args: Subst.t Iter.t; + premises: step_id Iter.t; +} + +include Sidekick_sigs.PRINT with type t := t + +val make : + ?lits:lit Iter.t -> + ?terms:Term.t Iter.t -> + ?substs:Subst.t Iter.t -> + ?premises:step_id Iter.t -> + string -> + t diff --git a/src/core/proof_trace.ml b/src/core/proof_trace.ml new file mode 100644 index 00000000..50aac799 --- /dev/null +++ b/src/core/proof_trace.ml @@ -0,0 +1,49 @@ +type lit = Lit.t +type step_id = int32 +type proof_term = Proof_term.t + +module Step_vec = struct + type elt = step_id + type t = elt Vec.t + + let get = Vec.get + let size = Vec.size + let iter = Vec.iter + let iteri = Vec.iteri + let create ?cap:_ () = Vec.create () + let clear = Vec.clear + let copy = Vec.copy + let is_empty = Vec.is_empty + let push = Vec.push + let fast_remove = Vec.fast_remove + let filter_in_place = Vec.filter_in_place + let ensure_size v len = Vec.ensure_size v ~elt:0l len + let pop = Vec.pop_exn + let set = Vec.set + let shrink = Vec.shrink + let to_iter = Vec.to_iter +end + +module type DYN = sig + val enabled : unit -> bool + val add_step : proof_term -> step_id + val add_unsat : step_id -> unit + val delete : step_id -> unit +end + +type t = (module DYN) + +let[@inline] enabled ((module Tr) : t) : bool = Tr.enabled () +let[@inline] add_step ((module Tr) : t) rule : step_id = Tr.add_step rule +let[@inline] add_unsat ((module Tr) : t) s : unit = Tr.add_unsat s +let[@inline] delete ((module Tr) : t) s : unit = Tr.delete s +let make (d : (module DYN)) : t = d +let dummy_step_id : step_id = -1l + +let dummy : t = + (module struct + let enabled () = false + let add_step _ = dummy_step_id + let add_unsat _ = () + let delete _ = () + end) diff --git a/src/core/proof_trace.mli b/src/core/proof_trace.mli new file mode 100644 index 00000000..19cf533e --- /dev/null +++ b/src/core/proof_trace.mli @@ -0,0 +1,65 @@ +(** Proof traces. + + A proof trace is a log of all the deductive reasoning steps made by + the SMT solver and other reasoning components. It essentially stores + a DAG of all these steps, where each step points (via {!step_id}) + to its premises. +*) + +open Sidekick_core_logic + +type lit = Lit.t + +type step_id = Proof_term.step_id +(** Identifier for a tracing step (like a unique ID for a clause previously + added/proved) *) + +module Step_vec : Vec_sig.BASE with type elt = step_id +(** A vector indexed by steps. *) + +type proof_term = Proof_term.t + +(** {2 Traces} *) + +type t +(** The proof trace itself. + + A proof trace is a log of all deductive steps taken by the solver, + so we can later reconstruct a certificate for proof-checking. + + Each step in the proof trace should be a {b valid + lemma} (of its theory) or a {b valid consequence} of previous steps. +*) + +val enabled : t -> bool +(** Is proof tracing enabled? *) + +val add_step : t -> proof_term -> step_id +(** Create a new step in the trace. *) + +val add_unsat : t -> step_id -> unit +(** Signal "unsat" result at the given proof *) + +val delete : t -> step_id -> unit +(** Forget a step that won't be used in the rest of the trace. + Only useful for performance/memory considerations. *) + +(** {2 Dummy backend} *) + +val dummy_step_id : step_id + +val dummy : t +(** Dummy proof trace, logs nothing. *) + +(* TODO: something that just logs on stderr? or uses "Log"? *) + +(** {2 Dynamic interface} *) + +module type DYN = sig + val enabled : unit -> bool + val add_step : proof_term -> step_id + val add_unsat : step_id -> unit + val delete : step_id -> unit +end + +val make : (module DYN) -> t From 1905d2d628c4088af0bc21dbdf9895c0f0280839 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 00:02:06 -0400 Subject: [PATCH 039/174] feat(core): improve Lit --- src/core/Sidekick_core.ml | 10 ++++++---- src/core/lit.ml | 4 ++++ src/core/lit.mli | 2 ++ 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index e4e4ede8..fa8d7b4c 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -23,9 +23,11 @@ module Term = struct include Sidekick_core_logic.T_builtins end -module Var = Sidekick_core_logic.Var module Bvar = Sidekick_core_logic.Bvar -module Subst = Sidekick_core_logic.Subst -module Proof_trace = Proof_trace -module Proof_sat = Proof_sat +module Lit = Lit module Proof_core = Proof_core +module Proof_sat = Proof_sat +module Proof_trace = Proof_trace +module Proof_term = Proof_term +module Subst = Sidekick_core_logic.Subst +module Var = Sidekick_core_logic.Var diff --git a/src/core/lit.ml b/src/core/lit.ml index eb91d2da..8b85e2a4 100644 --- a/src/core/lit.ml +++ b/src/core/lit.ml @@ -21,6 +21,10 @@ let atom ?(sign = true) (t : term) : t = in make ~sign t +let make_eq ?sign store t u : t = + let p = T_builtins.eq store t u in + atom ?sign p + let equal a b = a.lit_sign = b.lit_sign && T.equal a.lit_term b.lit_term let hash a = diff --git a/src/core/lit.mli b/src/core/lit.mli index 25fe65e7..bf012a59 100644 --- a/src/core/lit.mli +++ b/src/core/lit.mli @@ -36,6 +36,8 @@ val atom : ?sign:bool -> term -> t its sign in the process. @param sign if provided, and [sign=false], negate the resulting lit. *) +val make_eq : ?sign:bool -> Term.store -> term -> term -> t + val norm_sign : t -> t * bool (** [norm_sign (+t)] is [+t, true], and [norm_sign (-t)] is [+t, false]. From 464bc6647454666e3dab31761f9e3fd4e480213f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 00:02:27 -0400 Subject: [PATCH 040/174] wip: refactor(cc): remove layers of functorization --- src/cc/Sidekick_cc.ml | 1211 +------------------------- src/cc/Sidekick_cc.mli | 16 +- src/cc/bits.ml | 26 + src/cc/bits.mli | 13 + src/cc/core_cc.ml | 1136 ++++++++++++++++++++++++ src/cc/dune | 6 +- src/cc/mini/Sidekick_mini_cc.ml | 55 +- src/cc/mini/Sidekick_mini_cc.mli | 29 +- src/cc/mini/dune | 2 +- src/cc/plugin/dune | 4 +- src/cc/plugin/sidekick_cc_plugin.ml | 2 +- src/cc/plugin/sidekick_cc_plugin.mli | 4 +- src/cc/sigs.ml | 506 +++++++++++ src/cc/view.ml | 38 + src/cc/view.mli | 33 + 15 files changed, 1805 insertions(+), 1276 deletions(-) create mode 100644 src/cc/bits.ml create mode 100644 src/cc/bits.mli create mode 100644 src/cc/core_cc.ml create mode 100644 src/cc/sigs.ml create mode 100644 src/cc/view.ml create mode 100644 src/cc/view.mli diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index ae1562ae..7648562c 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,1208 +1,9 @@ -open Sidekick_sigs_cc +open Sidekick_core module View = View -open View -module type S = sig - include S +module type ARG = Sigs.ARG +module type S = Sigs.S +module type MONOID_PLUGIN_ARG = Sigs.MONOID_PLUGIN_ARG +module type MONOID_PLUGIN_BUILDER = Sigs.MONOID_PLUGIN_BUILDER - val create : - ?stat:Stat.t -> ?size:[ `Small | `Big ] -> term_store -> proof_trace -> t - (** Create a new congruence closure. - - @param term_store used to be able to create new terms. All terms - interacting with this congruence closure must belong in this term state - as well. - *) - - (**/**) - - module Debug_ : sig - val pp : t Fmt.printer - (** Print the whole CC *) - end - - (**/**) -end - -module type ARG = ARG - -(* small bitfield *) -module Bits : sig - type t = private int - type field - type bitfield_gen - - val empty : t - val equal : t -> t -> bool - val mk_field : bitfield_gen -> field - val mk_gen : unit -> bitfield_gen - val get : field -> t -> bool - val set : field -> bool -> t -> t - val merge : t -> t -> t -end = struct - type bitfield_gen = int ref - - let max_width = Sys.word_size - 2 - let mk_gen () = ref 0 - - type t = int - type field = int - - let empty : t = 0 - - let mk_field (gen : bitfield_gen) : field = - let n = !gen in - if n > max_width then Error.errorf "maximum number of CC bitfields reached"; - incr gen; - 1 lsl n - - let[@inline] get field x = x land field <> 0 - - let[@inline] set field b x = - if b then - x lor field - else - x land lnot field - - let merge = ( lor ) - let equal : t -> t -> bool = CCEqual.poly -end - -module Make (A : ARG) : - S - with module T = A.T - and module Lit = A.Lit - and module Proof_trace = A.Proof_trace = struct - module T = A.T - module Lit = A.Lit - module Proof_trace = A.Proof_trace - module Term = T.Term - module Fun = T.Fun - - open struct - (* proof rules *) - module Rules_ = A.Rule_core - module P = Proof_trace - end - - type term = T.Term.t - type value = term - type term_store = T.Term.store - type lit = Lit.t - type fun_ = T.Fun.t - type proof_trace = A.Proof_trace.t - type step_id = A.Proof_trace.A.step_id - - type e_node = { - n_term: term; - mutable n_sig0: signature option; (* initial signature *) - mutable n_bits: Bits.t; (* bitfield for various properties *) - mutable n_parents: e_node Bag.t; (* parent terms of this node *) - mutable n_root: e_node; - (* representative of congruence class (itself if a representative) *) - mutable n_next: e_node; (* pointer to next element of congruence class *) - mutable n_size: int; (* size of the class *) - mutable n_as_lit: lit option; - (* TODO: put into payload? and only in root? *) - mutable n_expl: explanation_forest_link; - (* the rooted forest for explanations *) - } - (** A node of the congruence closure. - An equivalence class is represented by its "root" element, - the representative. *) - - and signature = (fun_, e_node, e_node list) View.t - - and explanation_forest_link = - | FL_none - | FL_some of { next: e_node; expl: explanation } - - (* atomic explanation in the congruence closure *) - and explanation = - | E_trivial (* by pure reduction, tautologically equal *) - | E_lit of lit (* because of this literal *) - | E_merge of e_node * e_node - | E_merge_t of term * term - | E_congruence of e_node * e_node (* caused by normal congruence *) - | E_and of explanation * explanation - | E_theory of term * term * (term * term * explanation list) list * step_id - - type repr = e_node - - module E_node = struct - type t = e_node - - let[@inline] equal (n1 : t) n2 = n1 == n2 - let[@inline] hash n = Term.hash n.n_term - let[@inline] term n = n.n_term - let[@inline] pp out n = Term.pp out n.n_term - let[@inline] as_lit n = n.n_as_lit - - let make (t : term) : t = - let rec n = - { - n_term = t; - n_sig0 = None; - n_bits = Bits.empty; - n_parents = Bag.empty; - n_as_lit = None; - (* TODO: provide a method to do it *) - n_root = n; - n_expl = FL_none; - n_next = n; - n_size = 1; - } - in - n - - let[@inline] is_root (n : e_node) : bool = n.n_root == n - - (* traverse the equivalence class of [n] *) - let iter_class_ (n : e_node) : e_node Iter.t = - fun yield -> - let rec aux u = - yield u; - if u.n_next != n then aux u.n_next - in - aux n - - let[@inline] iter_class n = - assert (is_root n); - iter_class_ n - - let[@inline] iter_parents (n : e_node) : e_node Iter.t = - assert (is_root n); - Bag.to_iter n.n_parents - - type bitfield = Bits.field - - let[@inline] get_field f t = Bits.get f t.n_bits - let[@inline] set_field f b t = t.n_bits <- Bits.set f b t.n_bits - end - - (* non-recursive, inlinable function for [find] *) - let[@inline] find_ (n : e_node) : repr = - let n2 = n.n_root in - assert (E_node.is_root n2); - n2 - - let[@inline] same_class (n1 : e_node) (n2 : e_node) : bool = - E_node.equal (find_ n1) (find_ n2) - - let[@inline] find _ n = find_ n - - module Expl = struct - type t = explanation - - let rec pp out (e : explanation) = - match e with - | E_trivial -> Fmt.string out "reduction" - | E_lit lit -> Lit.pp out lit - | E_congruence (n1, n2) -> - Fmt.fprintf out "(@[congruence@ %a@ %a@])" E_node.pp n1 E_node.pp n2 - | E_merge (a, b) -> - Fmt.fprintf out "(@[merge@ %a@ %a@])" E_node.pp a E_node.pp b - | E_merge_t (a, b) -> - Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp a - Term.pp b - | E_theory (t, u, es, _) -> - Fmt.fprintf out "(@[th@ :t `%a`@ :u `%a`@ :expl_sets %a@])" Term.pp t - Term.pp u - (Util.pp_list @@ Fmt.Dump.triple Term.pp Term.pp (Fmt.Dump.list pp)) - es - | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b - - let mk_trivial : t = E_trivial - let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) - - let[@inline] mk_merge a b : t = - if E_node.equal a b then - mk_trivial - else - E_merge (a, b) - - let[@inline] mk_merge_t a b : t = - if Term.equal a b then - mk_trivial - else - E_merge_t (a, b) - - let[@inline] mk_lit l : t = E_lit l - let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) - - let rec mk_list l = - match l with - | [] -> mk_trivial - | [ x ] -> x - | E_trivial :: tl -> mk_list tl - | x :: y -> - (match mk_list y with - | E_trivial -> x - | y' -> E_and (x, y')) - end - - module Resolved_expl = struct - type t = { lits: lit list; pr: proof_trace -> step_id } - - let pp out (self : t) = - Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits - end - - (** A signature is a shallow term shape where immediate subterms - are representative *) - module Signature = struct - type t = signature - - let equal (s1 : t) s2 : bool = - match s1, s2 with - | Bool b1, Bool b2 -> b1 = b2 - | App_fun (f1, []), App_fun (f2, []) -> Fun.equal f1 f2 - | App_fun (f1, l1), App_fun (f2, l2) -> - Fun.equal f1 f2 && CCList.equal E_node.equal l1 l2 - | App_ho (f1, a1), App_ho (f2, a2) -> - E_node.equal f1 f2 && E_node.equal a1 a2 - | Not a, Not b -> E_node.equal a b - | If (a1, b1, c1), If (a2, b2, c2) -> - E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 - | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 - | Opaque u1, Opaque u2 -> E_node.equal u1 u2 - | Bool _, _ - | App_fun _, _ - | App_ho _, _ - | If _, _ - | Eq _, _ - | Opaque _, _ - | Not _, _ -> - false - - let hash (s : t) : int = - let module H = CCHash in - match s with - | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list E_node.hash l) - | App_ho (f, a) -> H.combine3 30 (E_node.hash f) (E_node.hash a) - | Eq (a, b) -> H.combine3 40 (E_node.hash a) (E_node.hash b) - | Opaque u -> H.combine2 50 (E_node.hash u) - | If (a, b, c) -> - H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) - | Not u -> H.combine2 70 (E_node.hash u) - - let pp out = function - | Bool b -> Fmt.bool out b - | App_fun (f, []) -> Fun.pp out f - | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list E_node.pp) l - | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" E_node.pp f E_node.pp a - | Opaque t -> E_node.pp out t - | Not u -> Fmt.fprintf out "(@[not@ %a@])" E_node.pp u - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" E_node.pp a E_node.pp b - | If (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" E_node.pp a E_node.pp b - E_node.pp c - end - - module Sig_tbl = CCHashtbl.Make (Signature) - module T_tbl = CCHashtbl.Make (Term) - - type propagation_reason = unit -> lit list * step_id - - module Handler_action = struct - type t = - | Act_merge of E_node.t * E_node.t * Expl.t - | Act_propagate of lit * propagation_reason - - type conflict = Conflict of Expl.t [@@unboxed] - type or_conflict = (t list, conflict) result - end - - module Result_action = struct - type t = Act_propagate of { lit: lit; reason: propagation_reason } - type conflict = Conflict of lit list * step_id - type or_conflict = (t list, conflict) result - end - - type combine_task = - | CT_merge of e_node * e_node * explanation - | CT_act of Handler_action.t - - type t = { - tst: term_store; - proof: proof_trace; - tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) - signatures_tbl: e_node Sig_tbl.t; - (* map a signature to the corresponding e_node in some equivalence class. - A signature is a [term_cell] in which every immediate subterm - that participates in the congruence/evaluation relation - is normalized (i.e. is its own representative). - The critical property is that all members of an equivalence class - that have the same "shape" (including head symbol) - have the same signature *) - pending: e_node Vec.t; - combine: combine_task Vec.t; - undo: (unit -> unit) Backtrack_stack.t; - bitgen: Bits.bitfield_gen; - field_marked_explain: Bits.field; - (* used to mark traversed nodes when looking for a common ancestor *) - true_: e_node lazy_t; - false_: e_node lazy_t; - mutable in_loop: bool; (* currently being modified? *) - res_acts: Result_action.t Vec.t; (* to return *) - on_pre_merge: - ( t * E_node.t * E_node.t * Expl.t, - Handler_action.or_conflict ) - Event.Emitter.t; - on_pre_merge2: - ( t * E_node.t * E_node.t * Expl.t, - Handler_action.or_conflict ) - Event.Emitter.t; - on_post_merge: - (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; - on_new_term: (t * E_node.t * term, Handler_action.t list) Event.Emitter.t; - on_conflict: (ev_on_conflict, unit) Event.Emitter.t; - on_propagate: - (t * lit * propagation_reason, Handler_action.t list) Event.Emitter.t; - on_is_subterm: (t * E_node.t * term, Handler_action.t list) Event.Emitter.t; - count_conflict: int Stat.counter; - count_props: int Stat.counter; - count_merge: int Stat.counter; - } - (* TODO: an additional union-find to keep track, for each term, - of the terms they are known to be equal to, according - to the current explanation. That allows not to prove some equality - several times. - See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) - - and ev_on_conflict = { cc: t; th: bool; c: lit list } - - let[@inline] size_ (r : repr) = r.n_size - let[@inline] n_true self = Lazy.force self.true_ - let[@inline] n_false self = Lazy.force self.false_ - - let n_bool self b = - if b then - n_true self - else - n_false self - - let[@inline] term_store self = self.tst - let[@inline] proof self = self.proof - - let allocate_bitfield self ~descr = - Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); - Bits.mk_field self.bitgen - - let[@inline] on_backtrack self f : unit = - Backtrack_stack.push_if_nonzero_level self.undo f - - let[@inline] get_bitfield _cc field n = E_node.get_field field n - - let set_bitfield self field b n = - let old = E_node.get_field field n in - if old <> b then ( - on_backtrack self (fun () -> E_node.set_field field old n); - E_node.set_field field b n - ) - - (* check if [t] is in the congruence closure. - Invariant: [in_cc t ∧ do_cc t => forall u subterm t, in_cc u] *) - let[@inline] mem (self : t) (t : term) : bool = T_tbl.mem self.tbl t - - module Debug_ = struct - (* print full state *) - let pp out (self : t) : unit = - let pp_next out n = Fmt.fprintf out "@ :next %a" E_node.pp n.n_next in - let pp_root out n = - if E_node.is_root n then - Fmt.string out " :is-root" - else - Fmt.fprintf out "@ :root %a" E_node.pp n.n_root - in - let pp_expl out n = - match n.n_expl with - | FL_none -> () - | FL_some e -> - Fmt.fprintf out " (@[:forest %a :expl %a@])" E_node.pp e.next Expl.pp - e.expl - in - let pp_n out n = - Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp n.n_term pp_root n pp_next n - pp_expl n - and pp_sig_e out (s, n) = - Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s E_node.pp n - pp_root n - in - Fmt.fprintf out - "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ \ - %a@])@])" - (Util.pp_iter ~sep:" " pp_n) - (T_tbl.values self.tbl) - (Util.pp_iter ~sep:" " pp_sig_e) - (Sig_tbl.to_iter self.signatures_tbl) - end - - (* compute up-to-date signature *) - let update_sig (s : signature) : Signature.t = - View.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) - - (* find whether the given (parent) term corresponds to some signature - in [signatures_] *) - let[@inline] find_signature cc (s : signature) : repr option = - Sig_tbl.get cc.signatures_tbl s - - (* add to signature table. Assume it's not present already *) - let add_signature self (s : signature) (n : e_node) : unit = - assert (not @@ Sig_tbl.mem self.signatures_tbl s); - Log.debugf 50 (fun k -> - k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s E_node.pp n); - on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); - Sig_tbl.add self.signatures_tbl s n - - let push_pending self t : unit = - Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); - Vec.push self.pending t - - let push_action self (a : Handler_action.t) : unit = - Vec.push self.combine (CT_act a) - - let push_action_l self (l : _ list) : unit = List.iter (push_action self) l - - let merge_classes self t u e : unit = - if t != u && not (same_class t u) then ( - Log.debugf 50 (fun k -> - k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" E_node.pp t - E_node.pp u Expl.pp e); - Vec.push self.combine @@ CT_merge (t, u, e) - ) - - (* re-root the explanation tree of the equivalence class of [n] - so that it points to [n]. - postcondition: [n.n_expl = None] *) - let[@unroll 2] rec reroot_expl (self : t) (n : e_node) : unit = - match n.n_expl with - | FL_none -> () (* already root *) - | FL_some { next = u; expl = e_n_u } -> - (* reroot to [u], then invert link between [u] and [n] *) - reroot_expl self u; - u.n_expl <- FL_some { next = n; expl = e_n_u }; - n.n_expl <- FL_none - - exception E_confl of Result_action.conflict - - let raise_conflict_ (cc : t) ~th (e : lit list) (p : step_id) : _ = - Profile.instant "cc.conflict"; - (* clear tasks queue *) - Vec.clear cc.pending; - Vec.clear cc.combine; - Event.emit cc.on_conflict { cc; th; c = e }; - Stat.incr cc.count_conflict; - raise (E_confl (Conflict (e, p))) - - let[@inline] all_classes self : repr Iter.t = - T_tbl.values self.tbl |> Iter.filter E_node.is_root - - (* find the closest common ancestor of [a] and [b] in the proof forest. - - Precond: - - [a] and [b] are in the same class - - no e_node has the flag [field_marked_explain] on - Invariants: - - if [n] is marked, then all the predecessors of [n] - from [a] or [b] are marked too. - *) - let find_common_ancestor self (a : e_node) (b : e_node) : e_node = - (* catch up to the other e_node *) - let rec find1 a = - if E_node.get_field self.field_marked_explain a then - a - else ( - match a.n_expl with - | FL_none -> assert false - | FL_some r -> find1 r.next - ) - in - let rec find2 a b = - if E_node.equal a b then - a - else if E_node.get_field self.field_marked_explain a then - a - else if E_node.get_field self.field_marked_explain b then - b - else ( - E_node.set_field self.field_marked_explain true a; - E_node.set_field self.field_marked_explain true b; - match a.n_expl, b.n_expl with - | FL_some r1, FL_some r2 -> find2 r1.next r2.next - | FL_some r, FL_none -> find1 r.next - | FL_none, FL_some r -> find1 r.next - | FL_none, FL_none -> assert false - (* no common ancestor *) - ) - in - - (* cleanup tags on nodes traversed in [find2] *) - let rec cleanup_ n = - if E_node.get_field self.field_marked_explain n then ( - E_node.set_field self.field_marked_explain false n; - match n.n_expl with - | FL_none -> () - | FL_some { next; _ } -> cleanup_ next - ) - in - let n = find2 a b in - cleanup_ a; - cleanup_ b; - n - - module Expl_state = struct - type t = { - mutable lits: Lit.t list; - mutable th_lemmas: (Lit.t * (Lit.t * Lit.t list) list * step_id) list; - } - - let create () : t = { lits = []; th_lemmas = [] } - let[@inline] copy self : t = { self with lits = self.lits } - let[@inline] add_lit (self : t) lit = self.lits <- lit :: self.lits - - let[@inline] add_th (self : t) lit hyps pr : unit = - self.th_lemmas <- (lit, hyps, pr) :: self.th_lemmas - - let merge self other = - let { lits = o_lits; th_lemmas = o_lemmas } = other in - self.lits <- List.rev_append o_lits self.lits; - self.th_lemmas <- List.rev_append o_lemmas self.th_lemmas; - () - - (* proof of [\/_i ¬lits[i]] *) - let proof_of_th_lemmas (self : t) (proof : proof_trace) : step_id = - let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in - let p_lits2 = - Iter.of_list self.th_lemmas - |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) - in - let p_cc = - P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) - in - let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = - (* pr_th: [sub_proofs |- t=u]. - now resolve away [sub_proofs] to get literals that were - asserted in the congruence closure *) - let pr_th = - List.fold_left - (fun pr_th (lit_i, hyps_i) -> - (* [hyps_i |- lit_i] *) - let lemma_i = - P.add_step proof - @@ Rules_.lemma_cc - Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) - in - (* resolve [lit_i] away. *) - P.add_step proof - @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) - pr_th sub_proofs - in - P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr - in - (* resolve with theory proofs responsible for some merges, if any. *) - List.fold_left resolve_with_th_proof p_cc self.th_lemmas - - let to_resolved_expl (self : t) : Resolved_expl.t = - (* FIXME: package the th lemmas too *) - let { lits; th_lemmas = _ } = self in - let s2 = copy self in - let pr proof = proof_of_th_lemmas s2 proof in - { Resolved_expl.lits; pr } - end - - (* decompose explanation [e] into a list of literals added to [acc] *) - let rec explain_decompose_expl self (st : Expl_state.t) (e : explanation) : - unit = - Log.debugf 5 (fun k -> k "(@[cc.decompose_expl@ %a@])" Expl.pp e); - match e with - | E_trivial -> () - | E_congruence (n1, n2) -> - (match n1.n_sig0, n2.n_sig0 with - | Some (App_fun (f1, a1)), Some (App_fun (f2, a2)) -> - assert (Fun.equal f1 f2); - assert (List.length a1 = List.length a2); - List.iter2 (explain_equal_rec_ self st) a1 a2 - | Some (App_ho (f1, a1)), Some (App_ho (f2, a2)) -> - explain_equal_rec_ self st f1 f2; - explain_equal_rec_ self st a1 a2 - | Some (If (a1, b1, c1)), Some (If (a2, b2, c2)) -> - explain_equal_rec_ self st a1 a2; - explain_equal_rec_ self st b1 b2; - explain_equal_rec_ self st c1 c2 - | _ -> assert false) - | E_lit lit -> Expl_state.add_lit st lit - | E_theory (t, u, expl_sets, pr) -> - let sub_proofs = - List.map - (fun (t_i, u_i, expls_i) -> - let lit_i = A.mk_lit_eq self.tst t_i u_i in - (* use a separate call to [explain_expls] for each set *) - let sub = explain_expls self expls_i in - Expl_state.merge st sub; - lit_i, sub.lits) - expl_sets - in - let lit_t_u = A.mk_lit_eq self.tst t u in - Expl_state.add_th st lit_t_u sub_proofs pr - | E_merge (a, b) -> explain_equal_rec_ self st a b - | E_merge_t (a, b) -> - (* find nodes for [a] and [b] on the fly *) - (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with - | a, b -> explain_equal_rec_ self st a b - | exception Not_found -> - Error.errorf "expl: cannot find e_node(s) for %a, %a" Term.pp a Term.pp - b) - | E_and (a, b) -> - explain_decompose_expl self st a; - explain_decompose_expl self st b - - and explain_expls self (es : explanation list) : Expl_state.t = - let st = Expl_state.create () in - List.iter (explain_decompose_expl self st) es; - st - - and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) - : unit = - Log.debugf 5 (fun k -> - k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); - assert (E_node.equal (find_ a) (find_ b)); - let ancestor = find_common_ancestor cc a b in - explain_along_path cc st a ancestor; - explain_along_path cc st b ancestor - - (* explain why [a = parent_a], where [a -> ... -> target] in the - proof forest *) - and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) - : unit = - let rec aux n = - if n == target then - () - else ( - match n.n_expl with - | FL_none -> assert false - | FL_some { next = next_n; expl } -> - explain_decompose_expl self st expl; - (* now prove [next_n = target] *) - aux next_n - ) - in - aux a - - (* add a term *) - let[@inline] rec add_term_rec_ self t : e_node = - match T_tbl.find self.tbl t with - | n -> n - | exception Not_found -> add_new_term_ self t - - (* add [t] when not present already *) - and add_new_term_ self (t : term) : e_node = - assert (not @@ mem self t); - Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp t); - let n = E_node.make t in - (* register sub-terms, add [t] to their parent list, and return the - corresponding initial signature *) - let sig0 = compute_sig0 self n in - n.n_sig0 <- sig0; - (* remove term when we backtrack *) - on_backtrack self (fun () -> - Log.debugf 30 (fun k -> k "(@[cc.remove-term@ %a@])" Term.pp t); - T_tbl.remove self.tbl t); - (* add term to the table *) - T_tbl.add self.tbl t n; - if Option.is_some sig0 then - (* [n] might be merged with other equiv classes *) - push_pending self n; - Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); - n - - (* compute the initial signature of the given e_node *) - and compute_sig0 (self : t) (n : e_node) : Signature.t option = - (* add sub-term to [cc], and register [n] to its parents. - Note that we return the exact sub-term, to get proper - explanations, but we add to the sub-term's root's parent list. *) - let deref_sub (u : term) : e_node = - let sub = add_term_rec_ self u in - (* add [n] to [sub.root]'s parent list *) - (let sub_r = find_ sub in - let old_parents = sub_r.n_parents in - if Bag.is_empty old_parents then - (* first time it has parents: tell watchers that this is a subterm *) - Event.emit_iter self.on_is_subterm (self, sub, u) - ~f:(push_action_l self); - on_backtrack self (fun () -> sub_r.n_parents <- old_parents); - sub_r.n_parents <- Bag.cons n sub_r.n_parents); - sub - in - let[@inline] return x = Some x in - match A.view_as_cc n.n_term with - | Bool _ | Opaque _ -> None - | Eq (a, b) -> - let a = deref_sub a in - let b = deref_sub b in - return @@ Eq (a, b) - | Not u -> return @@ Not (deref_sub u) - | App_fun (f, args) -> - let args = args |> Iter.map deref_sub |> Iter.to_list in - if args <> [] then - return @@ App_fun (f, args) - else - None - | App_ho (f, a) -> - let f = deref_sub f in - let a = deref_sub a in - return @@ App_ho (f, a) - | If (a, b, c) -> return @@ If (deref_sub a, deref_sub b, deref_sub c) - - let[@inline] add_term self t : e_node = add_term_rec_ self t - let mem_term = mem - - let set_as_lit self (n : e_node) (lit : lit) : unit = - match n.n_as_lit with - | Some _ -> () - | None -> - Log.debugf 15 (fun k -> - k "(@[cc.set-as-lit@ %a@ %a@])" E_node.pp n Lit.pp lit); - on_backtrack self (fun () -> n.n_as_lit <- None); - n.n_as_lit <- Some lit - - (* is [n] true or false? *) - let n_is_bool_value (self : t) n : bool = - E_node.equal n (n_true self) || E_node.equal n (n_false self) - - (* gather a pair [lits, pr], where [lits] is the set of - asserted literals needed in the explanation (which is useful for - the SAT solver), and [pr] is a proof, including sub-proofs for theory - merges. *) - let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : - Lit.t list * step_id = - let { Expl_state.lits; th_lemmas = _ } = st in - let pr = Expl_state.proof_of_th_lemmas st self.proof in - lits, pr - - (* main CC algo: add terms from [pending] to the signature table, - check for collisions *) - let rec update_tasks (self : t) : unit = - while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do - while not @@ Vec.is_empty self.pending do - task_pending_ self (Vec.pop_exn self.pending) - done; - while not @@ Vec.is_empty self.combine do - task_combine_ self (Vec.pop_exn self.combine) - done - done - - and task_pending_ self (n : e_node) : unit = - (* check if some parent collided *) - match n.n_sig0 with - | None -> () (* no-op *) - | Some (Eq (a, b)) -> - (* if [a=b] is now true, merge [(a=b)] and [true] *) - if same_class a b then ( - let expl = Expl.mk_merge a b in - Log.debugf 5 (fun k -> - k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a - E_node.pp b); - merge_classes self n (n_true self) expl - ) - | Some (Not u) -> - (* [u = bool ==> not u = not bool] *) - let r_u = find_ u in - if E_node.equal r_u (n_true self) then ( - let expl = Expl.mk_merge u (n_true self) in - merge_classes self n (n_false self) expl - ) else if E_node.equal r_u (n_false self) then ( - let expl = Expl.mk_merge u (n_false self) in - merge_classes self n (n_true self) expl - ) - | Some s0 -> - (* update the signature by using [find] on each sub-e_node *) - let s = update_sig s0 in - (match find_signature self s with - | None -> - (* add to the signature table [sig(n) --> n] *) - add_signature self s n - | Some u when E_node.equal n u -> () - | Some u -> - (* [t1] and [t2] must be applications of the same symbol to - arguments that are pairwise equal *) - assert (n != u); - let expl = Expl.mk_congruence n u in - merge_classes self n u expl) - - and task_combine_ self = function - | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab - | CT_act (Handler_action.Act_merge (t, u, e)) -> task_merge_ self t u e - | CT_act (Handler_action.Act_propagate (lit, reason)) -> - (* will return this propagation to the caller *) - Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }) - - (* main CC algo: merge equivalence classes in [st.combine]. - @raise Exn_unsat if merge fails *) - and task_merge_ self a b e_ab : unit = - let ra = find_ a in - let rb = find_ b in - if not @@ E_node.equal ra rb then ( - assert (E_node.is_root ra); - assert (E_node.is_root rb); - Stat.incr self.count_merge; - (* check we're not merging [true] and [false] *) - if - (E_node.equal ra (n_true self) && E_node.equal rb (n_false self)) - || (E_node.equal rb (n_true self) && E_node.equal ra (n_false self)) - then ( - Log.debugf 5 (fun k -> - k - "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ - %a@ :t2 %a@]@ :e_ab %a@])" - E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); - let th = ref false in - (* TODO: - C1: P.true_neq_false - C2: lemma [lits |- true=false] (and resolve on theory proofs) - C3: r1 C1 C2 - *) - let expl_st = Expl_state.create () in - explain_decompose_expl self expl_st e_ab; - explain_equal_rec_ self expl_st a ra; - explain_equal_rec_ self expl_st b rb; - - (* regular conflict *) - let lits, pr = lits_and_proof_of_expl self expl_st in - raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr - ); - (* We will merge [r_from] into [r_into]. - we try to ensure that [size ra <= size rb] in general, but always - keep values as representative *) - let r_from, r_into = - if n_is_bool_value self ra then - rb, ra - else if n_is_bool_value self rb then - ra, rb - else if size_ ra > size_ rb then - rb, ra - else - ra, rb - in - (* when merging terms with [true] or [false], possibly propagate them to SAT *) - let merge_bool r1 t1 r2 t2 = - if E_node.equal r1 (n_true self) then - propagate_bools self r2 t2 r1 t1 e_ab true - else if E_node.equal r1 (n_false self) then - propagate_bools self r2 t2 r1 t1 e_ab false - in - - merge_bool ra a rb b; - merge_bool rb b ra a; - - (* perform [union r_from r_into] *) - Log.debugf 15 (fun k -> - k "(@[cc.merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp - r_into); - - (* call [on_pre_merge] functions, and merge theory data items *) - (* explanation is [a=ra & e_ab & b=rb] *) - (let expl = - Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] - in - - let handle_act = function - | Ok l -> push_action_l self l - | Error (Handler_action.Conflict expl) -> - raise_conflict_from_expl self expl - in - - Event.emit_iter self.on_pre_merge - (self, r_into, r_from, expl) - ~f:handle_act; - Event.emit_iter self.on_pre_merge2 - (self, r_into, r_from, expl) - ~f:handle_act); - - (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, - so they have a chance of observing pre-merge plugin data *) - ((* parents might have a different signature, check for collisions *) - E_node.iter_parents r_from (fun parent -> push_pending self parent); - (* for each e_node in [r_from]'s class, make it point to [r_into] *) - E_node.iter_class r_from (fun u -> - assert (u.n_root == r_from); - u.n_root <- r_into); - (* capture current state *) - let r_into_old_next = r_into.n_next in - let r_from_old_next = r_from.n_next in - let r_into_old_parents = r_into.n_parents in - let r_into_old_bits = r_into.n_bits in - (* swap [into.next] and [from.next], merging the classes *) - r_into.n_next <- r_from_old_next; - r_from.n_next <- r_into_old_next; - r_into.n_parents <- Bag.append r_into.n_parents r_from.n_parents; - r_into.n_size <- r_into.n_size + r_from.n_size; - r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; - (* on backtrack, unmerge classes and restore the pointers to [r_from] *) - on_backtrack self (fun () -> - Log.debugf 30 (fun k -> - k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from - E_node.pp r_into); - r_into.n_bits <- r_into_old_bits; - r_into.n_next <- r_into_old_next; - r_from.n_next <- r_from_old_next; - r_into.n_parents <- r_into_old_parents; - (* NOTE: this must come after the restoration of [next] pointers, - otherwise we'd iterate on too big a class *) - E_node.iter_class_ r_from (fun u -> u.n_root <- r_from); - r_into.n_size <- r_into.n_size - r_from.n_size)); - - (* update explanations (a -> b), arbitrarily. - Note that here we merge the classes by adding a bridge between [a] - and [b], not their roots. *) - reroot_expl self a; - assert (a.n_expl = FL_none); - (* on backtracking, link may be inverted, but we delete the one - that bridges between [a] and [b] *) - on_backtrack self (fun () -> - match a.n_expl, b.n_expl with - | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none - | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none - | _ -> assert false); - a.n_expl <- FL_some { next = b; expl = e_ab }; - (* call [on_post_merge] *) - Event.emit_iter self.on_post_merge (self, r_into, r_from) - ~f:(push_action_l self) - ) - - (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] - in the equiv class of [r1] that is a known literal back to the SAT solver - and which is not the one initially merged. - We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) - and propagate_bools self r1 t1 r2 t2 (e_12 : explanation) sign : unit = - (* explanation for [t1 =e= t2 = r2] *) - let half_expl_and_pr = - lazy - (let st = Expl_state.create () in - explain_decompose_expl self st e_12; - explain_equal_rec_ self st r2 t2; - st) - in - (* TODO: flag per class, `or`-ed on merge, to indicate if the class - contains at least one lit *) - E_node.iter_class r1 (fun u1 -> - (* propagate if: - - [u1] is a proper literal - - [t2 != r2], because that can only happen - after an explicit merge (no way to obtain that by propagation) - *) - match E_node.as_lit u1 with - | Some lit when not (E_node.equal r2 t2) -> - let lit = - if sign then - lit - else - Lit.neg lit - in - (* apply sign *) - Log.debugf 5 (fun k -> k "(@[cc.bool_propagate@ %a@])" Lit.pp lit); - (* complete explanation with the [u1=t1] chunk *) - let (lazy st) = half_expl_and_pr in - let st = Expl_state.copy st in - (* do not modify shared st *) - explain_equal_rec_ self st u1 t1; - - (* propagate only if this doesn't depend on some semantic values *) - let reason () = - (* true literals explaining why t1=t2 *) - let guard = st.lits in - (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) - Expl_state.add_lit st (Lit.neg lit); - let _, pr = lits_and_proof_of_expl self st in - guard, pr - in - Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }); - Event.emit_iter self.on_propagate (self, lit, reason) - ~f:(push_action_l self); - Stat.incr self.count_props - | _ -> ()) - - (* raise a conflict from an explanation, typically from an event handler. - Raises E_confl with a result conflict. *) - and raise_conflict_from_expl self (expl : Expl.t) : 'a = - Log.debugf 5 (fun k -> - k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); - let st = Expl_state.create () in - explain_decompose_expl self st expl; - let lits, pr = lits_and_proof_of_expl self st in - let c = List.rev_map Lit.neg lits in - let th = st.th_lemmas <> [] in - raise_conflict_ self ~th c pr - - let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) - - let push_level (self : t) : unit = - assert (not self.in_loop); - Backtrack_stack.push_level self.undo - - let pop_levels (self : t) n : unit = - assert (not self.in_loop); - Vec.clear self.pending; - Vec.clear self.combine; - Log.debugf 15 (fun k -> - k "(@[cc.pop-levels %d@ :n-lvls %d@])" n - (Backtrack_stack.n_levels self.undo)); - Backtrack_stack.pop_levels self.undo n ~f:(fun f -> f ()); - () - - let assert_eq self t u expl : unit = - assert (not self.in_loop); - let t = add_term self t in - let u = add_term self u in - (* merge [a] and [b] *) - merge_classes self t u expl - - (* assert that this boolean literal holds. - if a lit is [= a b], merge [a] and [b]; - otherwise merge the atom with true/false *) - let assert_lit self lit : unit = - assert (not self.in_loop); - let t = Lit.term lit in - Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); - let sign = Lit.sign lit in - match A.view_as_cc t with - | Eq (a, b) when sign -> assert_eq self a b (Expl.mk_lit lit) - | _ -> - (* equate t and true/false *) - let rhs = n_bool self sign in - let n = add_term self t in - (* TODO: ensure that this is O(1). - basically, just have [n] point to true/false and thus acquire - the corresponding value, so its superterms (like [ite]) can evaluate - properly *) - (* TODO: use oriented merge (force direction [n -> rhs]) *) - merge_classes self n rhs (Expl.mk_lit lit) - - let[@inline] assert_lits self lits : unit = - assert (not self.in_loop); - Iter.iter (assert_lit self) lits - - let merge self n1 n2 expl = - assert (not self.in_loop); - Log.debugf 5 (fun k -> - k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" E_node.pp n1 - E_node.pp n2 Expl.pp expl); - assert (T.Ty.equal (T.Term.ty n1.n_term) (T.Term.ty n2.n_term)); - merge_classes self n1 n2 expl - - let merge_t self t1 t2 expl = - merge self (add_term self t1) (add_term self t2) expl - - let explain_eq self n1 n2 : Resolved_expl.t = - let st = Expl_state.create () in - explain_equal_rec_ self st n1 n2; - (* FIXME: also need to return the proof? *) - Expl_state.to_resolved_expl st - - let explain_expl (self : t) expl : Resolved_expl.t = - let expl_st = Expl_state.create () in - explain_decompose_expl self expl_st expl; - Expl_state.to_resolved_expl expl_st - - let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge - let[@inline] on_pre_merge2 self = Event.of_emitter self.on_pre_merge2 - let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge - let[@inline] on_new_term self = Event.of_emitter self.on_new_term - let[@inline] on_conflict self = Event.of_emitter self.on_conflict - let[@inline] on_propagate self = Event.of_emitter self.on_propagate - let[@inline] on_is_subterm self = Event.of_emitter self.on_is_subterm - - let create ?(stat = Stat.global) ?(size = `Big) (tst : term_store) - (proof : proof_trace) : t = - let size = - match size with - | `Small -> 128 - | `Big -> 2048 - in - let bitgen = Bits.mk_gen () in - let field_marked_explain = Bits.mk_field bitgen in - let rec cc = - { - tst; - proof; - tbl = T_tbl.create size; - signatures_tbl = Sig_tbl.create size; - bitgen; - on_pre_merge = Event.Emitter.create (); - on_pre_merge2 = Event.Emitter.create (); - on_post_merge = Event.Emitter.create (); - on_new_term = Event.Emitter.create (); - on_conflict = Event.Emitter.create (); - on_propagate = Event.Emitter.create (); - on_is_subterm = Event.Emitter.create (); - pending = Vec.create (); - combine = Vec.create (); - undo = Backtrack_stack.create (); - true_; - false_; - in_loop = false; - res_acts = Vec.create (); - field_marked_explain; - count_conflict = Stat.mk_int stat "cc.conflicts"; - count_props = Stat.mk_int stat "cc.propagations"; - count_merge = Stat.mk_int stat "cc.merges"; - } - and true_ = lazy (add_term cc (Term.bool tst true)) - and false_ = lazy (add_term cc (Term.bool tst false)) in - ignore (Lazy.force true_ : e_node); - ignore (Lazy.force false_ : e_node); - cc - - let[@inline] find_t self t : repr = - let n = T_tbl.find self.tbl t in - find_ n - - let pop_acts_ self = - let rec loop acc = - match Vec.pop self.res_acts with - | None -> acc - | Some x -> loop (x :: acc) - in - loop [] - - let check self : Result_action.or_conflict = - Log.debug 5 "(cc.check)"; - self.in_loop <- true; - let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in - try - update_tasks self; - let l = pop_acts_ self in - Ok l - with E_confl c -> Error c - - let check_inv_enabled_ = true (* XXX NUDGE *) - - (* check some internal invariants *) - let check_inv_ (self : t) : unit = - if check_inv_enabled_ then ( - Log.debug 2 "(cc.check-invariants)"; - all_classes self - |> Iter.flat_map E_node.iter_class - |> Iter.iter (fun n -> - match n.n_sig0 with - | None -> () - | Some s -> - let s' = update_sig s in - let ok = - match find_signature self s' with - | None -> false - | Some r -> E_node.equal r n.n_root - in - if not ok then - Log.debugf 0 (fun k -> - k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" - E_node.pp n Signature.pp s Signature.pp s')) - ) - - (* model: return all the classes *) - let get_model (self : t) : repr Iter.t Iter.t = - check_inv_ self; - all_classes self |> Iter.map E_node.iter_class -end +module Make (A : ARG) : S = Core_cc.Make (A) diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 2ecc963d..0eb9def5 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -1,15 +1,15 @@ (** Congruence Closure Implementation *) -module View = Sidekick_sigs_cc.View -open Sidekick_sigs_cc +open Sidekick_core +module View = View -module type ARG = ARG +module type ARG = Sigs.ARG module type S = sig - include S + include Sigs.S val create : - ?stat:Stat.t -> ?size:[ `Small | `Big ] -> term_store -> proof_trace -> t + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t (** Create a new congruence closure. @param term_store used to be able to create new terms. All terms @@ -26,8 +26,4 @@ module type S = sig (**/**) end -module Make (A : ARG) : - S - with module T = A.T - and module Lit = A.Lit - and module Proof_trace = A.Proof_trace +module Make (_ : ARG) : S diff --git a/src/cc/bits.ml b/src/cc/bits.ml new file mode 100644 index 00000000..3e376b56 --- /dev/null +++ b/src/cc/bits.ml @@ -0,0 +1,26 @@ +type bitfield_gen = int ref + +let max_width = Sys.word_size - 2 +let mk_gen () = ref 0 + +type t = int +type field = int + +let empty : t = 0 + +let mk_field (gen : bitfield_gen) : field = + let n = !gen in + if n > max_width then Error.errorf "maximum number of CC bitfields reached"; + incr gen; + 1 lsl n + +let[@inline] get field x = x land field <> 0 + +let[@inline] set field b x = + if b then + x lor field + else + x land lnot field + +let merge = ( lor ) +let equal : t -> t -> bool = CCEqual.poly diff --git a/src/cc/bits.mli b/src/cc/bits.mli new file mode 100644 index 00000000..1460ed8f --- /dev/null +++ b/src/cc/bits.mli @@ -0,0 +1,13 @@ +(** Basic bitfield *) + +type t = private int +type field +type bitfield_gen + +val empty : t +val equal : t -> t -> bool +val mk_field : bitfield_gen -> field +val mk_gen : unit -> bitfield_gen +val get : field -> t -> bool +val set : field -> bool -> t -> t +val merge : t -> t -> t diff --git a/src/cc/core_cc.ml b/src/cc/core_cc.ml new file mode 100644 index 00000000..0df1b40a --- /dev/null +++ b/src/cc/core_cc.ml @@ -0,0 +1,1136 @@ +(* actual implementation *) + +open Sidekick_core +open View + +module type ARG = Sigs.ARG + +module Make (A : ARG) : Sigs.S = struct + open struct + (* proof rules *) + module Rules_ = Proof_core + module P = Proof_trace + end + + type e_node = { + n_term: Term.t; + mutable n_sig0: signature option; (* initial signature *) + mutable n_bits: Bits.t; (* bitfield for various properties *) + mutable n_parents: e_node Bag.t; (* parent terms of this node *) + mutable n_root: e_node; + (* representative of congruence class (itself if a representative) *) + mutable n_next: e_node; (* pointer to next element of congruence class *) + mutable n_size: int; (* size of the class *) + mutable n_as_lit: Lit.t option; + (* TODO: put into payload? and only in root? *) + mutable n_expl: explanation_forest_link; + (* the rooted forest for explanations *) + } + (** A node of the congruence closure. + An equivalence class is represented by its "root" element, + the representative. *) + + and signature = (Const.t, e_node, e_node list) View.t + + and explanation_forest_link = + | FL_none + | FL_some of { next: e_node; expl: explanation } + + (* atomic explanation in the congruence closure *) + and explanation = + | E_trivial (* by pure reduction, tautologically equal *) + | E_lit of Lit.t (* because of this literal *) + | E_merge of e_node * e_node + | E_merge_t of Term.t * Term.t + | E_congruence of e_node * e_node (* caused by normal congruence *) + | E_and of explanation * explanation + | E_theory of + Term.t + * Term.t + * (Term.t * Term.t * explanation list) list + * Proof_term.step_id + + type repr = e_node + + module E_node = struct + type t = e_node + + let[@inline] equal (n1 : t) n2 = n1 == n2 + let[@inline] hash n = Term.hash n.n_term + let[@inline] term n = n.n_term + let[@inline] pp out n = Term.pp_debug out n.n_term + let[@inline] as_lit n = n.n_as_lit + + let make (t : Term.t) : t = + let rec n = + { + n_term = t; + n_sig0 = None; + n_bits = Bits.empty; + n_parents = Bag.empty; + n_as_lit = None; + (* TODO: provide a method to do it *) + n_root = n; + n_expl = FL_none; + n_next = n; + n_size = 1; + } + in + n + + let[@inline] is_root (n : e_node) : bool = n.n_root == n + + (* traverse the equivalence class of [n] *) + let iter_class_ (n : e_node) : e_node Iter.t = + fun yield -> + let rec aux u = + yield u; + if u.n_next != n then aux u.n_next + in + aux n + + let[@inline] iter_class n = + assert (is_root n); + iter_class_ n + + let[@inline] iter_parents (n : e_node) : e_node Iter.t = + assert (is_root n); + Bag.to_iter n.n_parents + + type bitfield = Bits.field + + let[@inline] get_field f t = Bits.get f t.n_bits + let[@inline] set_field f b t = t.n_bits <- Bits.set f b t.n_bits + end + + (* non-recursive, inlinable function for [find] *) + let[@inline] find_ (n : e_node) : repr = + let n2 = n.n_root in + assert (E_node.is_root n2); + n2 + + let[@inline] same_class (n1 : e_node) (n2 : e_node) : bool = + E_node.equal (find_ n1) (find_ n2) + + let[@inline] find _ n = find_ n + + module Expl = struct + type t = explanation + + let rec pp out (e : explanation) = + match e with + | E_trivial -> Fmt.string out "reduction" + | E_lit lit -> Lit.pp out lit + | E_congruence (n1, n2) -> + Fmt.fprintf out "(@[congruence@ %a@ %a@])" E_node.pp n1 E_node.pp n2 + | E_merge (a, b) -> + Fmt.fprintf out "(@[merge@ %a@ %a@])" E_node.pp a E_node.pp b + | E_merge_t (a, b) -> + Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp_debug + a Term.pp_debug b + | E_theory (t, u, es, _) -> + Fmt.fprintf out "(@[th@ :t `%a`@ :u `%a`@ :expl_sets %a@])" + Term.pp_debug t Term.pp_debug u + (Util.pp_list + @@ Fmt.Dump.triple Term.pp_debug Term.pp_debug (Fmt.Dump.list pp)) + es + | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b + + let mk_trivial : t = E_trivial + let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) + + let[@inline] mk_merge a b : t = + if E_node.equal a b then + mk_trivial + else + E_merge (a, b) + + let[@inline] mk_merge_t a b : t = + if Term.equal a b then + mk_trivial + else + E_merge_t (a, b) + + let[@inline] mk_lit l : t = E_lit l + let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) + + let rec mk_list l = + match l with + | [] -> mk_trivial + | [ x ] -> x + | E_trivial :: tl -> mk_list tl + | x :: y -> + (match mk_list y with + | E_trivial -> x + | y' -> E_and (x, y')) + end + + module Resolved_expl = struct + type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } + + let pp out (self : t) = + Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits + end + + (** A signature is a shallow term shape where immediate subterms + are representative *) + module Signature = struct + type t = signature + + let equal (s1 : t) s2 : bool = + match s1, s2 with + | Bool b1, Bool b2 -> b1 = b2 + | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 + | App_fun (f1, l1), App_fun (f2, l2) -> + Const.equal f1 f2 && CCList.equal E_node.equal l1 l2 + | App_ho (f1, a1), App_ho (f2, a2) -> + E_node.equal f1 f2 && E_node.equal a1 a2 + | Not a, Not b -> E_node.equal a b + | If (a1, b1, c1), If (a2, b2, c2) -> + E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 + | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 + | Opaque u1, Opaque u2 -> E_node.equal u1 u2 + | Bool _, _ + | App_fun _, _ + | App_ho _, _ + | If _, _ + | Eq _, _ + | Opaque _, _ + | Not _, _ -> + false + + let hash (s : t) : int = + let module H = CCHash in + match s with + | Bool b -> H.combine2 10 (H.bool b) + | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list E_node.hash l) + | App_ho (f, a) -> H.combine3 30 (E_node.hash f) (E_node.hash a) + | Eq (a, b) -> H.combine3 40 (E_node.hash a) (E_node.hash b) + | Opaque u -> H.combine2 50 (E_node.hash u) + | If (a, b, c) -> + H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) + | Not u -> H.combine2 70 (E_node.hash u) + + let pp out = function + | Bool b -> Fmt.bool out b + | App_fun (f, []) -> Const.pp out f + | App_fun (f, l) -> + Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list E_node.pp) l + | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" E_node.pp f E_node.pp a + | Opaque t -> E_node.pp out t + | Not u -> Fmt.fprintf out "(@[not@ %a@])" E_node.pp u + | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" E_node.pp a E_node.pp b + | If (a, b, c) -> + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" E_node.pp a E_node.pp b + E_node.pp c + end + + module Sig_tbl = CCHashtbl.Make (Signature) + module T_tbl = CCHashtbl.Make (Term) + + type propagation_reason = unit -> Lit.t list * Proof_term.step_id + + module Handler_action = struct + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of Lit.t * propagation_reason + + type conflict = Conflict of Expl.t [@@unboxed] + type or_conflict = (t list, conflict) result + end + + module Result_action = struct + type t = Act_propagate of { lit: Lit.t; reason: propagation_reason } + type conflict = Conflict of Lit.t list * Proof_term.step_id + type or_conflict = (t list, conflict) result + end + + type combine_task = + | CT_merge of e_node * e_node * explanation + | CT_act of Handler_action.t + + type t = { + tst: Term.store; + proof: Proof_trace.t; + tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) + signatures_tbl: e_node Sig_tbl.t; + (* map a signature to the corresponding e_node in some equivalence class. + A signature is a [term_cell] in which every immediate subterm + that participates in the congruence/evaluation relation + is normalized (i.e. is its own representative). + The critical property is that all members of an equivalence class + that have the same "shape" (including head symbol) + have the same signature *) + pending: e_node Vec.t; + combine: combine_task Vec.t; + undo: (unit -> unit) Backtrack_stack.t; + bitgen: Bits.bitfield_gen; + field_marked_explain: Bits.field; + (* used to mark traversed nodes when looking for a common ancestor *) + true_: e_node lazy_t; + false_: e_node lazy_t; + mutable in_loop: bool; (* currently being modified? *) + res_acts: Result_action.t Vec.t; (* to return *) + on_pre_merge: + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; + on_pre_merge2: + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; + on_post_merge: + (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; + on_new_term: (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; + on_conflict: (ev_on_conflict, unit) Event.Emitter.t; + on_propagate: + (t * Lit.t * propagation_reason, Handler_action.t list) Event.Emitter.t; + on_is_subterm: + (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; + count_conflict: int Stat.counter; + count_props: int Stat.counter; + count_merge: int Stat.counter; + } + (* TODO: an additional union-find to keep track, for each term, + of the terms they are known to be equal to, according + to the current explanation. That allows not to prove some equality + several times. + See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) + + and ev_on_conflict = { cc: t; th: bool; c: Lit.t list } + + let[@inline] size_ (r : repr) = r.n_size + let[@inline] n_true self = Lazy.force self.true_ + let[@inline] n_false self = Lazy.force self.false_ + + let n_bool self b = + if b then + n_true self + else + n_false self + + let[@inline] term_store self = self.tst + let[@inline] proof self = self.proof + + let allocate_bitfield self ~descr = + Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); + Bits.mk_field self.bitgen + + let[@inline] on_backtrack self f : unit = + Backtrack_stack.push_if_nonzero_level self.undo f + + let[@inline] get_bitfield _cc field n = E_node.get_field field n + + let set_bitfield self field b n = + let old = E_node.get_field field n in + if old <> b then ( + on_backtrack self (fun () -> E_node.set_field field old n); + E_node.set_field field b n + ) + + (* check if [t] is in the congruence closure. + Invariant: [in_cc t ∧ do_cc t => forall u subterm t, in_cc u] *) + let[@inline] mem (self : t) (t : Term.t) : bool = T_tbl.mem self.tbl t + + module Debug_ = struct + (* print full state *) + let pp out (self : t) : unit = + let pp_next out n = Fmt.fprintf out "@ :next %a" E_node.pp n.n_next in + let pp_root out n = + if E_node.is_root n then + Fmt.string out " :is-root" + else + Fmt.fprintf out "@ :root %a" E_node.pp n.n_root + in + let pp_expl out n = + match n.n_expl with + | FL_none -> () + | FL_some e -> + Fmt.fprintf out " (@[:forest %a :expl %a@])" E_node.pp e.next Expl.pp + e.expl + in + let pp_n out n = + Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp_debug n.n_term pp_root n + pp_next n pp_expl n + and pp_sig_e out (s, n) = + Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s E_node.pp n + pp_root n + in + Fmt.fprintf out + "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ \ + %a@])@])" + (Util.pp_iter ~sep:" " pp_n) + (T_tbl.values self.tbl) + (Util.pp_iter ~sep:" " pp_sig_e) + (Sig_tbl.to_iter self.signatures_tbl) + end + + (* compute up-to-date signature *) + let update_sig (s : signature) : Signature.t = + View.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) + + (* find whether the given (parent) term corresponds to some signature + in [signatures_] *) + let[@inline] find_signature cc (s : signature) : repr option = + Sig_tbl.get cc.signatures_tbl s + + (* add to signature table. Assume it's not present already *) + let add_signature self (s : signature) (n : e_node) : unit = + assert (not @@ Sig_tbl.mem self.signatures_tbl s); + Log.debugf 50 (fun k -> + k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s E_node.pp n); + on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); + Sig_tbl.add self.signatures_tbl s n + + let push_pending self t : unit = + Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); + Vec.push self.pending t + + let push_action self (a : Handler_action.t) : unit = + Vec.push self.combine (CT_act a) + + let push_action_l self (l : _ list) : unit = List.iter (push_action self) l + + let merge_classes self t u e : unit = + if t != u && not (same_class t u) then ( + Log.debugf 50 (fun k -> + k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" E_node.pp t + E_node.pp u Expl.pp e); + Vec.push self.combine @@ CT_merge (t, u, e) + ) + + (* re-root the explanation tree of the equivalence class of [n] + so that it points to [n]. + postcondition: [n.n_expl = None] *) + let[@unroll 2] rec reroot_expl (self : t) (n : e_node) : unit = + match n.n_expl with + | FL_none -> () (* already root *) + | FL_some { next = u; expl = e_n_u } -> + (* reroot to [u], then invert link between [u] and [n] *) + reroot_expl self u; + u.n_expl <- FL_some { next = n; expl = e_n_u }; + n.n_expl <- FL_none + + exception E_confl of Result_action.conflict + + let raise_conflict_ (cc : t) ~th (e : Lit.t list) (p : Proof_term.step_id) : _ + = + Profile.instant "cc.conflict"; + (* clear tasks queue *) + Vec.clear cc.pending; + Vec.clear cc.combine; + Event.emit cc.on_conflict { cc; th; c = e }; + Stat.incr cc.count_conflict; + raise (E_confl (Conflict (e, p))) + + let[@inline] all_classes self : repr Iter.t = + T_tbl.values self.tbl |> Iter.filter E_node.is_root + + (* find the closest common ancestor of [a] and [b] in the proof forest. + + Precond: + - [a] and [b] are in the same class + - no e_node has the flag [field_marked_explain] on + Invariants: + - if [n] is marked, then all the predecessors of [n] + from [a] or [b] are marked too. + *) + let find_common_ancestor self (a : e_node) (b : e_node) : e_node = + (* catch up to the other e_node *) + let rec find1 a = + if E_node.get_field self.field_marked_explain a then + a + else ( + match a.n_expl with + | FL_none -> assert false + | FL_some r -> find1 r.next + ) + in + let rec find2 a b = + if E_node.equal a b then + a + else if E_node.get_field self.field_marked_explain a then + a + else if E_node.get_field self.field_marked_explain b then + b + else ( + E_node.set_field self.field_marked_explain true a; + E_node.set_field self.field_marked_explain true b; + match a.n_expl, b.n_expl with + | FL_some r1, FL_some r2 -> find2 r1.next r2.next + | FL_some r, FL_none -> find1 r.next + | FL_none, FL_some r -> find1 r.next + | FL_none, FL_none -> assert false + (* no common ancestor *) + ) + in + + (* cleanup tags on nodes traversed in [find2] *) + let rec cleanup_ n = + if E_node.get_field self.field_marked_explain n then ( + E_node.set_field self.field_marked_explain false n; + match n.n_expl with + | FL_none -> () + | FL_some { next; _ } -> cleanup_ next + ) + in + let n = find2 a b in + cleanup_ a; + cleanup_ b; + n + + module Expl_state = struct + type t = { + mutable lits: Lit.t list; + mutable th_lemmas: + (Lit.t * (Lit.t * Lit.t list) list * Proof_term.step_id) list; + } + + let create () : t = { lits = []; th_lemmas = [] } + let[@inline] copy self : t = { self with lits = self.lits } + let[@inline] add_lit (self : t) lit = self.lits <- lit :: self.lits + + let[@inline] add_th (self : t) lit hyps pr : unit = + self.th_lemmas <- (lit, hyps, pr) :: self.th_lemmas + + let merge self other = + let { lits = o_lits; th_lemmas = o_lemmas } = other in + self.lits <- List.rev_append o_lits self.lits; + self.th_lemmas <- List.rev_append o_lemmas self.th_lemmas; + () + + (* proof of [\/_i ¬lits[i]] *) + let proof_of_th_lemmas (self : t) (proof : Proof_trace.t) : + Proof_term.step_id = + let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in + let p_lits2 = + Iter.of_list self.th_lemmas + |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) + in + let p_cc = + P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) + in + let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = + (* pr_th: [sub_proofs |- t=u]. + now resolve away [sub_proofs] to get literals that were + asserted in the congruence closure *) + let pr_th = + List.fold_left + (fun pr_th (lit_i, hyps_i) -> + (* [hyps_i |- lit_i] *) + let lemma_i = + P.add_step proof + @@ Rules_.lemma_cc + Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) + in + (* resolve [lit_i] away. *) + P.add_step proof + @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) + pr_th sub_proofs + in + P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr + in + (* resolve with theory proofs responsible for some merges, if any. *) + List.fold_left resolve_with_th_proof p_cc self.th_lemmas + + let to_resolved_expl (self : t) : Resolved_expl.t = + (* FIXME: package the th lemmas too *) + let { lits; th_lemmas = _ } = self in + let s2 = copy self in + let pr proof = proof_of_th_lemmas s2 proof in + { Resolved_expl.lits; pr } + end + + (* decompose explanation [e] into a list of literals added to [acc] *) + let rec explain_decompose_expl self (st : Expl_state.t) (e : explanation) : + unit = + Log.debugf 5 (fun k -> k "(@[cc.decompose_expl@ %a@])" Expl.pp e); + match e with + | E_trivial -> () + | E_congruence (n1, n2) -> + (match n1.n_sig0, n2.n_sig0 with + | Some (App_fun (f1, a1)), Some (App_fun (f2, a2)) -> + assert (Const.equal f1 f2); + assert (List.length a1 = List.length a2); + List.iter2 (explain_equal_rec_ self st) a1 a2 + | Some (App_ho (f1, a1)), Some (App_ho (f2, a2)) -> + explain_equal_rec_ self st f1 f2; + explain_equal_rec_ self st a1 a2 + | Some (If (a1, b1, c1)), Some (If (a2, b2, c2)) -> + explain_equal_rec_ self st a1 a2; + explain_equal_rec_ self st b1 b2; + explain_equal_rec_ self st c1 c2 + | _ -> assert false) + | E_lit lit -> Expl_state.add_lit st lit + | E_theory (t, u, expl_sets, pr) -> + let sub_proofs = + List.map + (fun (t_i, u_i, expls_i) -> + let lit_i = Lit.make_eq self.tst t_i u_i in + (* use a separate call to [explain_expls] for each set *) + let sub = explain_expls self expls_i in + Expl_state.merge st sub; + lit_i, sub.lits) + expl_sets + in + let lit_t_u = Lit.make_eq self.tst t u in + Expl_state.add_th st lit_t_u sub_proofs pr + | E_merge (a, b) -> explain_equal_rec_ self st a b + | E_merge_t (a, b) -> + (* find nodes for [a] and [b] on the fly *) + (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with + | a, b -> explain_equal_rec_ self st a b + | exception Not_found -> + Error.errorf "expl: cannot find e_node(s) for %a, %a" Term.pp_debug a + Term.pp_debug b) + | E_and (a, b) -> + explain_decompose_expl self st a; + explain_decompose_expl self st b + + and explain_expls self (es : explanation list) : Expl_state.t = + let st = Expl_state.create () in + List.iter (explain_decompose_expl self st) es; + st + + and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) + : unit = + Log.debugf 5 (fun k -> + k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); + assert (E_node.equal (find_ a) (find_ b)); + let ancestor = find_common_ancestor cc a b in + explain_along_path cc st a ancestor; + explain_along_path cc st b ancestor + + (* explain why [a = parent_a], where [a -> ... -> target] in the + proof forest *) + and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) + : unit = + let rec aux n = + if n == target then + () + else ( + match n.n_expl with + | FL_none -> assert false + | FL_some { next = next_n; expl } -> + explain_decompose_expl self st expl; + (* now prove [next_n = target] *) + aux next_n + ) + in + aux a + + (* add a term *) + let[@inline] rec add_term_rec_ self t : e_node = + match T_tbl.find self.tbl t with + | n -> n + | exception Not_found -> add_new_term_ self t + + (* add [t] when not present already *) + and add_new_term_ self (t : Term.t) : e_node = + assert (not @@ mem self t); + Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp_debug t); + let n = E_node.make t in + (* register sub-terms, add [t] to their parent list, and return the + corresponding initial signature *) + let sig0 = compute_sig0 self n in + n.n_sig0 <- sig0; + (* remove term when we backtrack *) + on_backtrack self (fun () -> + Log.debugf 30 (fun k -> k "(@[cc.remove-term@ %a@])" Term.pp_debug t); + T_tbl.remove self.tbl t); + (* add term to the table *) + T_tbl.add self.tbl t n; + if Option.is_some sig0 then + (* [n] might be merged with other equiv classes *) + push_pending self n; + Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); + n + + (* compute the initial signature of the given e_node *) + and compute_sig0 (self : t) (n : e_node) : Signature.t option = + (* add sub-term to [cc], and register [n] to its parents. + Note that we return the exact sub-term, to get proper + explanations, but we add to the sub-term's root's parent list. *) + let deref_sub (u : Term.t) : e_node = + let sub = add_term_rec_ self u in + (* add [n] to [sub.root]'s parent list *) + (let sub_r = find_ sub in + let old_parents = sub_r.n_parents in + if Bag.is_empty old_parents then + (* first time it has parents: tell watchers that this is a subterm *) + Event.emit_iter self.on_is_subterm (self, sub, u) + ~f:(push_action_l self); + on_backtrack self (fun () -> sub_r.n_parents <- old_parents); + sub_r.n_parents <- Bag.cons n sub_r.n_parents); + sub + in + let[@inline] return x = Some x in + match A.view_as_cc n.n_term with + | Bool _ | Opaque _ -> None + | Eq (a, b) -> + let a = deref_sub a in + let b = deref_sub b in + return @@ Eq (a, b) + | Not u -> return @@ Not (deref_sub u) + | App_fun (f, args) -> + let args = args |> Iter.map deref_sub |> Iter.to_list in + if args <> [] then + return @@ App_fun (f, args) + else + None + | App_ho (f, a) -> + let f = deref_sub f in + let a = deref_sub a in + return @@ App_ho (f, a) + | If (a, b, c) -> return @@ If (deref_sub a, deref_sub b, deref_sub c) + + let[@inline] add_term self t : e_node = add_term_rec_ self t + let mem_term = mem + + let set_as_lit self (n : e_node) (lit : Lit.t) : unit = + match n.n_as_lit with + | Some _ -> () + | None -> + Log.debugf 15 (fun k -> + k "(@[cc.set-as-lit@ %a@ %a@])" E_node.pp n Lit.pp lit); + on_backtrack self (fun () -> n.n_as_lit <- None); + n.n_as_lit <- Some lit + + (* is [n] true or false? *) + let n_is_bool_value (self : t) n : bool = + E_node.equal n (n_true self) || E_node.equal n (n_false self) + + (* gather a pair [lits, pr], where [lits] is the set of + asserted literals needed in the explanation (which is useful for + the SAT solver), and [pr] is a proof, including sub-proofs for theory + merges. *) + let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : + Lit.t list * Proof_term.step_id = + let { Expl_state.lits; th_lemmas = _ } = st in + let pr = Expl_state.proof_of_th_lemmas st self.proof in + lits, pr + + (* main CC algo: add terms from [pending] to the signature table, + check for collisions *) + let rec update_tasks (self : t) : unit = + while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do + while not @@ Vec.is_empty self.pending do + task_pending_ self (Vec.pop_exn self.pending) + done; + while not @@ Vec.is_empty self.combine do + task_combine_ self (Vec.pop_exn self.combine) + done + done + + and task_pending_ self (n : e_node) : unit = + (* check if some parent collided *) + match n.n_sig0 with + | None -> () (* no-op *) + | Some (Eq (a, b)) -> + (* if [a=b] is now true, merge [(a=b)] and [true] *) + if same_class a b then ( + let expl = Expl.mk_merge a b in + Log.debugf 5 (fun k -> + k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a + E_node.pp b); + merge_classes self n (n_true self) expl + ) + | Some (Not u) -> + (* [u = bool ==> not u = not bool] *) + let r_u = find_ u in + if E_node.equal r_u (n_true self) then ( + let expl = Expl.mk_merge u (n_true self) in + merge_classes self n (n_false self) expl + ) else if E_node.equal r_u (n_false self) then ( + let expl = Expl.mk_merge u (n_false self) in + merge_classes self n (n_true self) expl + ) + | Some s0 -> + (* update the signature by using [find] on each sub-e_node *) + let s = update_sig s0 in + (match find_signature self s with + | None -> + (* add to the signature table [sig(n) --> n] *) + add_signature self s n + | Some u when E_node.equal n u -> () + | Some u -> + (* [t1] and [t2] must be applications of the same symbol to + arguments that are pairwise equal *) + assert (n != u); + let expl = Expl.mk_congruence n u in + merge_classes self n u expl) + + and task_combine_ self = function + | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab + | CT_act (Handler_action.Act_merge (t, u, e)) -> task_merge_ self t u e + | CT_act (Handler_action.Act_propagate (lit, reason)) -> + (* will return this propagation to the caller *) + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }) + + (* main CC algo: merge equivalence classes in [st.combine]. + @raise Exn_unsat if merge fails *) + and task_merge_ self a b e_ab : unit = + let ra = find_ a in + let rb = find_ b in + if not @@ E_node.equal ra rb then ( + assert (E_node.is_root ra); + assert (E_node.is_root rb); + Stat.incr self.count_merge; + (* check we're not merging [true] and [false] *) + if + (E_node.equal ra (n_true self) && E_node.equal rb (n_false self)) + || (E_node.equal rb (n_true self) && E_node.equal ra (n_false self)) + then ( + Log.debugf 5 (fun k -> + k + "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ + %a@ :t2 %a@]@ :e_ab %a@])" + E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); + let th = ref false in + (* TODO: + C1: P.true_neq_false + C2: lemma [lits |- true=false] (and resolve on theory proofs) + C3: r1 C1 C2 + *) + let expl_st = Expl_state.create () in + explain_decompose_expl self expl_st e_ab; + explain_equal_rec_ self expl_st a ra; + explain_equal_rec_ self expl_st b rb; + + (* regular conflict *) + let lits, pr = lits_and_proof_of_expl self expl_st in + raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr + ); + (* We will merge [r_from] into [r_into]. + we try to ensure that [size ra <= size rb] in general, but always + keep values as representative *) + let r_from, r_into = + if n_is_bool_value self ra then + rb, ra + else if n_is_bool_value self rb then + ra, rb + else if size_ ra > size_ rb then + rb, ra + else + ra, rb + in + (* when merging terms with [true] or [false], possibly propagate them to SAT *) + let merge_bool r1 t1 r2 t2 = + if E_node.equal r1 (n_true self) then + propagate_bools self r2 t2 r1 t1 e_ab true + else if E_node.equal r1 (n_false self) then + propagate_bools self r2 t2 r1 t1 e_ab false + in + + merge_bool ra a rb b; + merge_bool rb b ra a; + + (* perform [union r_from r_into] *) + Log.debugf 15 (fun k -> + k "(@[cc.merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp + r_into); + + (* call [on_pre_merge] functions, and merge theory data items *) + (* explanation is [a=ra & e_ab & b=rb] *) + (let expl = + Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] + in + + let handle_act = function + | Ok l -> push_action_l self l + | Error (Handler_action.Conflict expl) -> + raise_conflict_from_expl self expl + in + + Event.emit_iter self.on_pre_merge + (self, r_into, r_from, expl) + ~f:handle_act; + Event.emit_iter self.on_pre_merge2 + (self, r_into, r_from, expl) + ~f:handle_act); + + (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, + so they have a chance of observing pre-merge plugin data *) + ((* parents might have a different signature, check for collisions *) + E_node.iter_parents r_from (fun parent -> push_pending self parent); + (* for each e_node in [r_from]'s class, make it point to [r_into] *) + E_node.iter_class r_from (fun u -> + assert (u.n_root == r_from); + u.n_root <- r_into); + (* capture current state *) + let r_into_old_next = r_into.n_next in + let r_from_old_next = r_from.n_next in + let r_into_old_parents = r_into.n_parents in + let r_into_old_bits = r_into.n_bits in + (* swap [into.next] and [from.next], merging the classes *) + r_into.n_next <- r_from_old_next; + r_from.n_next <- r_into_old_next; + r_into.n_parents <- Bag.append r_into.n_parents r_from.n_parents; + r_into.n_size <- r_into.n_size + r_from.n_size; + r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; + (* on backtrack, unmerge classes and restore the pointers to [r_from] *) + on_backtrack self (fun () -> + Log.debugf 30 (fun k -> + k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from + E_node.pp r_into); + r_into.n_bits <- r_into_old_bits; + r_into.n_next <- r_into_old_next; + r_from.n_next <- r_from_old_next; + r_into.n_parents <- r_into_old_parents; + (* NOTE: this must come after the restoration of [next] pointers, + otherwise we'd iterate on too big a class *) + E_node.iter_class_ r_from (fun u -> u.n_root <- r_from); + r_into.n_size <- r_into.n_size - r_from.n_size)); + + (* update explanations (a -> b), arbitrarily. + Note that here we merge the classes by adding a bridge between [a] + and [b], not their roots. *) + reroot_expl self a; + assert (a.n_expl = FL_none); + (* on backtracking, link may be inverted, but we delete the one + that bridges between [a] and [b] *) + on_backtrack self (fun () -> + match a.n_expl, b.n_expl with + | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none + | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none + | _ -> assert false); + a.n_expl <- FL_some { next = b; expl = e_ab }; + (* call [on_post_merge] *) + Event.emit_iter self.on_post_merge (self, r_into, r_from) + ~f:(push_action_l self) + ) + + (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] + in the equiv class of [r1] that is a known literal back to the SAT solver + and which is not the one initially merged. + We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) + and propagate_bools self r1 t1 r2 t2 (e_12 : explanation) sign : unit = + (* explanation for [t1 =e= t2 = r2] *) + let half_expl_and_pr = + lazy + (let st = Expl_state.create () in + explain_decompose_expl self st e_12; + explain_equal_rec_ self st r2 t2; + st) + in + (* TODO: flag per class, `or`-ed on merge, to indicate if the class + contains at least one lit *) + E_node.iter_class r1 (fun u1 -> + (* propagate if: + - [u1] is a proper literal + - [t2 != r2], because that can only happen + after an explicit merge (no way to obtain that by propagation) + *) + match E_node.as_lit u1 with + | Some lit when not (E_node.equal r2 t2) -> + let lit = + if sign then + lit + else + Lit.neg lit + in + (* apply sign *) + Log.debugf 5 (fun k -> k "(@[cc.bool_propagate@ %a@])" Lit.pp lit); + (* complete explanation with the [u1=t1] chunk *) + let (lazy st) = half_expl_and_pr in + let st = Expl_state.copy st in + (* do not modify shared st *) + explain_equal_rec_ self st u1 t1; + + (* propagate only if this doesn't depend on some semantic values *) + let reason () = + (* true literals explaining why t1=t2 *) + let guard = st.lits in + (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) + Expl_state.add_lit st (Lit.neg lit); + let _, pr = lits_and_proof_of_expl self st in + guard, pr + in + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }); + Event.emit_iter self.on_propagate (self, lit, reason) + ~f:(push_action_l self); + Stat.incr self.count_props + | _ -> ()) + + (* raise a conflict from an explanation, typically from an event handler. + Raises E_confl with a result conflict. *) + and raise_conflict_from_expl self (expl : Expl.t) : 'a = + Log.debugf 5 (fun k -> + k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); + let st = Expl_state.create () in + explain_decompose_expl self st expl; + let lits, pr = lits_and_proof_of_expl self st in + let c = List.rev_map Lit.neg lits in + let th = st.th_lemmas <> [] in + raise_conflict_ self ~th c pr + + let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) + + let push_level (self : t) : unit = + assert (not self.in_loop); + Backtrack_stack.push_level self.undo + + let pop_levels (self : t) n : unit = + assert (not self.in_loop); + Vec.clear self.pending; + Vec.clear self.combine; + Log.debugf 15 (fun k -> + k "(@[cc.pop-levels %d@ :n-lvls %d@])" n + (Backtrack_stack.n_levels self.undo)); + Backtrack_stack.pop_levels self.undo n ~f:(fun f -> f ()); + () + + let assert_eq self t u expl : unit = + assert (not self.in_loop); + let t = add_term self t in + let u = add_term self u in + (* merge [a] and [b] *) + merge_classes self t u expl + + (* assert that this boolean literal holds. + if a lit is [= a b], merge [a] and [b]; + otherwise merge the atom with true/false *) + let assert_lit self lit : unit = + assert (not self.in_loop); + let t = Lit.term lit in + Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); + let sign = Lit.sign lit in + match A.view_as_cc t with + | Eq (a, b) when sign -> assert_eq self a b (Expl.mk_lit lit) + | _ -> + (* equate t and true/false *) + let rhs = n_bool self sign in + let n = add_term self t in + (* TODO: ensure that this is O(1). + basically, just have [n] point to true/false and thus acquire + the corresponding value, so its superterms (like [ite]) can evaluate + properly *) + (* TODO: use oriented merge (force direction [n -> rhs]) *) + merge_classes self n rhs (Expl.mk_lit lit) + + let[@inline] assert_lits self lits : unit = + assert (not self.in_loop); + Iter.iter (assert_lit self) lits + + let merge self n1 n2 expl = + assert (not self.in_loop); + Log.debugf 5 (fun k -> + k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" E_node.pp n1 + E_node.pp n2 Expl.pp expl); + assert (Term.equal (Term.ty n1.n_term) (Term.ty n2.n_term)); + merge_classes self n1 n2 expl + + let merge_t self t1 t2 expl = + merge self (add_term self t1) (add_term self t2) expl + + let explain_eq self n1 n2 : Resolved_expl.t = + let st = Expl_state.create () in + explain_equal_rec_ self st n1 n2; + (* FIXME: also need to return the proof? *) + Expl_state.to_resolved_expl st + + let explain_expl (self : t) expl : Resolved_expl.t = + let expl_st = Expl_state.create () in + explain_decompose_expl self expl_st expl; + Expl_state.to_resolved_expl expl_st + + let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge + let[@inline] on_pre_merge2 self = Event.of_emitter self.on_pre_merge2 + let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge + let[@inline] on_new_term self = Event.of_emitter self.on_new_term + let[@inline] on_conflict self = Event.of_emitter self.on_conflict + let[@inline] on_propagate self = Event.of_emitter self.on_propagate + let[@inline] on_is_subterm self = Event.of_emitter self.on_is_subterm + + let create ?(stat = Stat.global) ?(size = `Big) (tst : Term.store) + (proof : Proof_trace.t) : t = + let size = + match size with + | `Small -> 128 + | `Big -> 2048 + in + let bitgen = Bits.mk_gen () in + let field_marked_explain = Bits.mk_field bitgen in + let rec cc = + { + tst; + proof; + tbl = T_tbl.create size; + signatures_tbl = Sig_tbl.create size; + bitgen; + on_pre_merge = Event.Emitter.create (); + on_pre_merge2 = Event.Emitter.create (); + on_post_merge = Event.Emitter.create (); + on_new_term = Event.Emitter.create (); + on_conflict = Event.Emitter.create (); + on_propagate = Event.Emitter.create (); + on_is_subterm = Event.Emitter.create (); + pending = Vec.create (); + combine = Vec.create (); + undo = Backtrack_stack.create (); + true_; + false_; + in_loop = false; + res_acts = Vec.create (); + field_marked_explain; + count_conflict = Stat.mk_int stat "cc.conflicts"; + count_props = Stat.mk_int stat "cc.propagations"; + count_merge = Stat.mk_int stat "cc.merges"; + } + and true_ = lazy (add_term cc (Term.true_ tst)) + and false_ = lazy (add_term cc (Term.false_ tst)) in + ignore (Lazy.force true_ : e_node); + ignore (Lazy.force false_ : e_node); + cc + + let[@inline] find_t self t : repr = + let n = T_tbl.find self.tbl t in + find_ n + + let pop_acts_ self = + let rec loop acc = + match Vec.pop self.res_acts with + | None -> acc + | Some x -> loop (x :: acc) + in + loop [] + + let check self : Result_action.or_conflict = + Log.debug 5 "(cc.check)"; + self.in_loop <- true; + let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in + try + update_tasks self; + let l = pop_acts_ self in + Ok l + with E_confl c -> Error c + + let check_inv_enabled_ = true (* XXX NUDGE *) + + (* check some internal invariants *) + let check_inv_ (self : t) : unit = + if check_inv_enabled_ then ( + Log.debug 2 "(cc.check-invariants)"; + all_classes self + |> Iter.flat_map E_node.iter_class + |> Iter.iter (fun n -> + match n.n_sig0 with + | None -> () + | Some s -> + let s' = update_sig s in + let ok = + match find_signature self s' with + | None -> false + | Some r -> E_node.equal r n.n_root + in + if not ok then + Log.debugf 0 (fun k -> + k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" + E_node.pp n Signature.pp s Signature.pp s')) + ) + + (* model: return all the classes *) + let get_model (self : t) : repr Iter.t Iter.t = + check_inv_ self; + all_classes self |> Iter.map E_node.iter_class +end diff --git a/src/cc/dune b/src/cc/dune index b33f850d..d249010d 100644 --- a/src/cc/dune +++ b/src/cc/dune @@ -1,5 +1,7 @@ (library (name Sidekick_cc) (public_name sidekick.cc) - (libraries containers iter sidekick.sigs sidekick.sigs.cc sidekick.util) - (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) + (synopsis "main congruence closure implementation") + (private_modules core_cc) + (libraries containers iter sidekick.sigs sidekick.core sidekick.util) + (flags :standard -open Sidekick_util)) diff --git a/src/cc/mini/Sidekick_mini_cc.ml b/src/cc/mini/Sidekick_mini_cc.ml index 6decc650..059ad1b5 100644 --- a/src/cc/mini/Sidekick_mini_cc.ml +++ b/src/cc/mini/Sidekick_mini_cc.ml @@ -1,46 +1,34 @@ -module CC_view = Sidekick_sigs_cc.View - -module type TERM = Sidekick_sigs_term.S +open Sidekick_core +module CC_view = Sidekick_cc.View module type ARG = sig - module T : TERM - - val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t + val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) CC_view.t end module type S = sig - type term - type fun_ - type term_store type t - val create : term_store -> t + val create : Term.store -> t val clear : t -> unit - val add_lit : t -> term -> bool -> unit + val add_lit : t -> Term.t -> bool -> unit val check_sat : t -> bool - val classes : t -> term Iter.t Iter.t + val classes : t -> Term.t Iter.t Iter.t end module Make (A : ARG) = struct open CC_view - module Fun = A.T.Fun - module T = A.T.Term - - type fun_ = A.T.Fun.t - type term = T.t - type term_store = T.store - - module T_tbl = CCHashtbl.Make (T) + module T = Term + module T_tbl = Term.Tbl type node = { - n_t: term; + n_t: Term.t; mutable n_next: node; (* next in class *) mutable n_size: int; (* size of class *) mutable n_parents: node list; mutable n_root: node; (* root of the class *) } - type signature = (fun_, node, node list) CC_view.t + type signature = (Const.t, node, node list) CC_view.t module Node = struct type t = node @@ -51,7 +39,7 @@ module Make (A : ARG) = struct let[@inline] is_root n = n == n.n_root let[@inline] root n = n.n_root let[@inline] term n = n.n_t - let pp out n = T.pp out n.n_t + let pp out n = T.pp_debug out n.n_t let add_parent (self : t) ~p : unit = self.n_parents <- p :: self.n_parents let make (t : T.t) : t = @@ -79,9 +67,9 @@ module Make (A : ARG) = struct let equal (s1 : t) s2 : bool = match s1, s2 with | Bool b1, Bool b2 -> b1 = b2 - | App_fun (f1, []), App_fun (f2, []) -> Fun.equal f1 f2 + | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 | App_fun (f1, l1), App_fun (f2, l2) -> - Fun.equal f1 f2 && CCList.equal Node.equal l1 l2 + Const.equal f1 f2 && CCList.equal Node.equal l1 l2 | App_ho (f1, a1), App_ho (f2, a2) -> Node.equal f1 f2 && Node.equal a1 a2 | Not n1, Not n2 -> Node.equal n1 n2 | If (a1, b1, c1), If (a2, b2, c2) -> @@ -101,7 +89,7 @@ module Make (A : ARG) = struct let module H = CCHash in match s with | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Fun.hash f) (H.list Node.hash l) + | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list Node.hash l) | App_ho (f, a) -> H.combine3 30 (Node.hash f) (Node.hash a) | Eq (a, b) -> H.combine3 40 (Node.hash a) (Node.hash b) | Opaque u -> H.combine2 50 (Node.hash u) @@ -110,9 +98,9 @@ module Make (A : ARG) = struct let pp out = function | Bool b -> Fmt.bool out b - | App_fun (f, []) -> Fun.pp out f + | App_fun (f, []) -> Const.pp out f | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Fun.pp f (Util.pp_list Node.pp) l + Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list Node.pp) l | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" Node.pp f Node.pp a | Opaque t -> Node.pp out t | Not u -> Fmt.fprintf out "(@[not@ %a@])" Node.pp u @@ -134,8 +122,8 @@ module Make (A : ARG) = struct } let create tst : t = - let true_ = T.bool tst true in - let false_ = T.bool tst false in + let true_ = Term.true_ tst in + let false_ = Term.false_ tst in let self = { ok = true; @@ -180,7 +168,7 @@ module Make (A : ARG) = struct k b; k c - let rec add_t (self : t) (t : term) : node = + let rec add_t (self : t) (t : Term.t) : node = match T_tbl.find self.tbl t with | n -> n | exception Not_found -> @@ -194,9 +182,10 @@ module Make (A : ARG) = struct self.pending <- node :: self.pending; node - let find_t_ (self : t) (t : term) : node = + let find_t_ (self : t) (t : Term.t) : node = try T_tbl.find self.tbl t |> Node.root - with Not_found -> Error.errorf "mini-cc.find_t: no node for %a" T.pp t + with Not_found -> + Error.errorf "mini-cc.find_t: no node for %a" T.pp_debug t exception E_unsat diff --git a/src/cc/mini/Sidekick_mini_cc.mli b/src/cc/mini/Sidekick_mini_cc.mli index 413d2518..fd4b4493 100644 --- a/src/cc/mini/Sidekick_mini_cc.mli +++ b/src/cc/mini/Sidekick_mini_cc.mli @@ -5,35 +5,28 @@ It just decides the satisfiability of a set of (dis)equations. *) -module CC_view = Sidekick_sigs_cc.View - -module type TERM = Sidekick_sigs_term.S +open Sidekick_core +module CC_view = Sidekick_cc.View (** Argument for the functor {!Make} - It only requires a term structure, and a congruence-oriented view. *) + It only requires a Term.t structure, and a congruence-oriented view. *) module type ARG = sig - module T : TERM - - val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) CC_view.t + val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) CC_view.t end (** Main signature for an instance of the mini congruence closure *) module type S = sig - type term - type fun_ - type term_store - type t (** An instance of the congruence closure. Mutable *) - val create : term_store -> t + val create : Term.store -> t (** New instance *) val clear : t -> unit (** Fully reset the congruence closure's state *) - val add_lit : t -> term -> bool -> unit + val add_lit : t -> Term.t -> bool -> unit (** [add_lit cc p sign] asserts that [p] is true if [sign], or [p] is false if [not sign]. If [p] is an equation and [sign] is [true], this adds a new equation to the congruence relation. *) @@ -42,14 +35,10 @@ module type S = sig (** [check_sat cc] returns [true] if the current state is satisfiable, [false] if it's unsatisfiable. *) - val classes : t -> term Iter.t Iter.t + val classes : t -> Term.t Iter.t Iter.t (** Traverse the set of classes in the congruence closure. This should be called only if {!check} returned [Sat]. *) end -(** Instantiate the congruence closure for the given term structure. *) -module Make (A : ARG) : - S - with type term = A.T.Term.t - and type fun_ = A.T.Fun.t - and type term_store = A.T.Term.store +(** Instantiate the congruence closure for the given Term.t structure. *) +module Make (_ : ARG) : S diff --git a/src/cc/mini/dune b/src/cc/mini/dune index bbcbb9ad..23187086 100644 --- a/src/cc/mini/dune +++ b/src/cc/mini/dune @@ -1,5 +1,5 @@ (library (name Sidekick_mini_cc) (public_name sidekick.mini-cc) - (libraries containers iter sidekick.sigs.cc sidekick.sigs.term sidekick.util) + (libraries containers iter sidekick.cc sidekick.core sidekick.util) (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) diff --git a/src/cc/plugin/dune b/src/cc/plugin/dune index 269abd1e..46f79cee 100644 --- a/src/cc/plugin/dune +++ b/src/cc/plugin/dune @@ -1,5 +1,5 @@ (library (name Sidekick_cc_plugin) (public_name sidekick.cc.plugin) - (libraries containers iter sidekick.sigs sidekick.sigs.cc sidekick.util) - (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) + (libraries containers iter sidekick.sigs sidekick.cc sidekick.util) + (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml index 6ee73414..0563977e 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -1,4 +1,4 @@ -open Sidekick_sigs_cc +open Sidekick_cc module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER diff --git a/src/cc/plugin/sidekick_cc_plugin.mli b/src/cc/plugin/sidekick_cc_plugin.mli index 71ccdbc5..413d8408 100644 --- a/src/cc/plugin/sidekick_cc_plugin.mli +++ b/src/cc/plugin/sidekick_cc_plugin.mli @@ -1,6 +1,6 @@ -(** Congruence Closure Implementation *) +(** Congruence Closure Plugin *) -open Sidekick_sigs_cc +open Sidekick_cc module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER diff --git a/src/cc/sigs.ml b/src/cc/sigs.ml new file mode 100644 index 00000000..20541c45 --- /dev/null +++ b/src/cc/sigs.ml @@ -0,0 +1,506 @@ +(** Main types for congruence closure *) + +open Sidekick_core +module View = View + +(** Arguments to a congruence closure's implementation *) +module type ARG = sig + val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t + (** View the Term.t through the lens of the congruence closure *) +end + +(** Collection of input types, and types defined by the congruence closure *) +module type ARGS_CLASSES_EXPL_EVENT = sig + (** E-node. + + An e-node is a node in the congruence closure that is contained + in some equivalence classe). + An equivalence class is a set of terms that are currently equal + in the partial model built by the solver. + The class is represented by a collection of nodes, one of which is + distinguished and is called the "representative". + + All information pertaining to the whole equivalence class is stored + in its representative's {!E_node.t}. + + When two classes become equal (are "merged"), one of the two + representatives is picked as the representative of the new class. + The new class contains the union of the two old classes' nodes. + + We also allow theories to store additional information in the + representative. This information can be used when two classes are + merged, to detect conflicts and solve equations à la Shostak. + *) + module E_node : sig + type t + (** An E-node. + + A value of type [t] points to a particular Term.t, but see + {!find} to get the representative of the class. *) + + include Sidekick_sigs.PRINT with type t := t + + val term : t -> Term.t + (** Term contained in this equivalence class. + If [is_root n], then [Term.t n] is the class' representative Term.t. *) + + val equal : t -> t -> bool + (** Are two classes {b physically} equal? To check for + logical equality, use [CC.E_node.equal (CC.find cc n1) (CC.find cc n2)] + which checks for equality of representatives. *) + + val hash : t -> int + (** An opaque hash of this E_node.t. *) + + val is_root : t -> bool + (** Is the E_node.t a root (ie the representative of its class)? + See {!find} to get the root. *) + + val iter_class : t -> t Iter.t + (** Traverse the congruence class. + Precondition: [is_root n] (see {!find} below) *) + + val iter_parents : t -> t Iter.t + (** Traverse the parents of the class. + Precondition: [is_root n] (see {!find} below) *) + + (* FIXME: + [@@alert refactor "this should be replaced with a Per_class concept"] + *) + + type bitfield + (** A field in the bitfield of this node. This should only be + allocated when a theory is initialized. + + Bitfields are accessed using preallocated keys. + See {!CC_S.allocate_bitfield}. + + All fields are initially 0, are backtracked automatically, + and are merged automatically when classes are merged. *) + end + + (** Explanations + + Explanations are specialized proofs, created by the congruence closure + when asked to justify why two terms are equal. *) + module Expl : sig + type t + + include Sidekick_sigs.PRINT with type t := t + + val mk_merge : E_node.t -> E_node.t -> t + (** Explanation: the nodes were explicitly merged *) + + val mk_merge_t : Term.t -> Term.t -> t + (** Explanation: the terms were explicitly merged *) + + val mk_lit : Lit.t -> t + (** Explanation: we merged [t] and [u] because of literal [t=u], + or we merged [t] and [true] because of literal [t], + or [t] and [false] because of literal [¬t] *) + + val mk_list : t list -> t + (** Conjunction of explanations *) + + val mk_theory : + Term.t -> + Term.t -> + (Term.t * Term.t * t list) list -> + Proof_term.step_id -> + t + (** [mk_theory t u expl_sets pr] builds a theory explanation for + why [|- t=u]. It depends on sub-explanations [expl_sets] which + are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are + explanations that justify [t_i = u_i] in the current congruence closure. + + The proof [pr] is the theory lemma, of the form + [ (t_i = u_i)_i |- t=u ]. + It is resolved against each [expls_i |- t_i=u_i] obtained from + [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] + where [Gamma] is a subset of the literals asserted into the congruence + closure. + + For example for the lemma [a=b] deduced by injectivity + from [Some a=Some b] in the theory of datatypes, + the arguments would be + [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] + where [pr] is the injectivity lemma [Some a=Some b |- a=b]. + *) + end + + (** Resolved explanations. + + The congruence closure keeps explanations for why terms are in the same + class. However these are represented in a compact, cheap form. + To use these explanations we need to {b resolve} them into a + resolved explanation, typically a list of + literals that are true in the current trail and are responsible for + merges. + + However, we can also have merged classes because they have the same value + in the current model. *) + module Resolved_expl : sig + type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } + + include Sidekick_sigs.PRINT with type t := t + end + + (** Per-node data *) + + type e_node = E_node.t + (** A node of the congruence closure *) + + type repr = E_node.t + (** Node that is currently a representative. *) + + type explanation = Expl.t +end + +(** Main congruence closure signature. + + The congruence closure handles the theory QF_UF (uninterpreted + function symbols). + It is also responsible for {i theory combination}, and provides + a general framework for equality reasoning that other + theories piggyback on. + + For example, the theory of datatypes relies on the congruence closure + to do most of the work, and "only" adds injectivity/disjointness/acyclicity + lemmas when needed. + + Similarly, a theory of arrays would hook into the congruence closure and + assert (dis)equalities as needed. +*) +module type S = sig + include ARGS_CLASSES_EXPL_EVENT + + type t + (** The congruence closure object. + It contains a fair amount of state and is mutable + and backtrackable. *) + + (** {3 Accessors} *) + + val term_store : t -> Term.store + val proof : t -> Proof_trace.t + + val find : t -> e_node -> repr + (** Current representative *) + + val add_term : t -> Term.t -> e_node + (** Add the Term.t to the congruence closure, if not present already. + Will be backtracked. *) + + val mem_term : t -> Term.t -> bool + (** Returns [true] if the Term.t is explicitly present in the congruence closure *) + + val allocate_bitfield : t -> descr:string -> E_node.bitfield + (** Allocate a new e_node field (see {!E_node.bitfield}). + + This field descriptor is henceforth reserved for all nodes + in this congruence closure, and can be set using {!set_bitfield} + for each class_ individually. + This can be used to efficiently store some metadata on nodes + (e.g. "is there a numeric value in the class" + or "is there a constructor Term.t in the class"). + + There may be restrictions on how many distinct fields are allocated + for a given congruence closure (e.g. at most {!Sys.int_size} fields). + *) + + val get_bitfield : t -> E_node.bitfield -> E_node.t -> bool + (** Access the bit field of the given e_node *) + + val set_bitfield : t -> E_node.bitfield -> bool -> E_node.t -> unit + (** Set the bitfield for the e_node. This will be backtracked. + See {!E_node.bitfield}. *) + + type propagation_reason = unit -> Lit.t list * Proof_term.step_id + + (** Handler Actions + + Actions that can be scheduled by event handlers. *) + module Handler_action : sig + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of Lit.t * propagation_reason + + (* TODO: + - an action to modify data associated with a class + *) + + type conflict = Conflict of Expl.t [@@unboxed] + + type or_conflict = (t list, conflict) result + (** Actions or conflict scheduled by an event handler. + + - [Ok acts] is a list of merges and propagations + - [Error confl] is a conflict to resolve. + *) + end + + (** Result Actions. + + + Actions returned by the congruence closure after calling {!check}. *) + module Result_action : sig + type t = + | Act_propagate of { lit: Lit.t; reason: propagation_reason } + (** [propagate (Lit.t, reason)] declares that [reason() => Lit.t] + is a tautology. + + - [reason()] should return a list of literals that are currently true, + as well as a proof. + - [Lit.t] should be a literal of interest (see {!S.set_as_lit}). + + This function might never be called, a congruence closure has the right + to not propagate and only trigger conflicts. *) + + type conflict = + | Conflict of Lit.t list * Proof_term.step_id + (** [raise_conflict (c,pr)] declares that [c] is a tautology of + the theory of congruence. + @param pr the proof of [c] being a tautology *) + + type or_conflict = (t list, conflict) result + end + + (** {3 Events} + + Events triggered by the congruence closure, to which + other plugins can subscribe. *) + + (** Events emitted by the congruence closure when something changes. *) + val on_pre_merge : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t + (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] + and [n2] are merged with explanation [expl]. *) + + val on_pre_merge2 : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t + (** Second phase of "on pre merge". This runs after {!on_pre_merge} + and is used by Plugins. {b NOTE}: Plugin state might be observed as already + changed in these handlers. *) + + val on_post_merge : + t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t + (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] + and [n2] were merged. [find cc n1] and [find cc n2] will return + the same E_node.t. *) + + val on_new_term : t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t + (** [ev_on_new_term n t] is emitted whenever a new Term.t [t] + is added to the congruence closure. Its E_node.t is [n]. *) + + type ev_on_conflict = { cc: t; th: bool; c: Lit.t list } + (** Event emitted when a conflict occurs in the CC. + + [th] is true if the explanation for this conflict involves + at least one "theory" explanation; i.e. some of the equations + participating in the conflict are purely syntactic theories + like injectivity of constructors. *) + + val on_conflict : t -> (ev_on_conflict, unit) Event.t + (** [ev_on_conflict {th; c}] is emitted when the congruence + closure triggers a conflict by asserting the tautology [c]. *) + + val on_propagate : + t -> + ( t * Lit.t * (unit -> Lit.t list * Proof_term.step_id), + Handler_action.t list ) + Event.t + (** [ev_on_propagate Lit.t reason] is emitted whenever [reason() => Lit.t] + is a propagated lemma. See {!CC_ACTIONS.propagate}. *) + + val on_is_subterm : + t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t + (** [ev_on_is_subterm n t] is emitted when [n] is a subterm of + another E_node.t for the first time. [t] is the Term.t corresponding to + the E_node.t [n]. This can be useful for theory combination. *) + + (** {3 Misc} *) + + val n_true : t -> E_node.t + (** Node for [true] *) + + val n_false : t -> E_node.t + (** Node for [false] *) + + val n_bool : t -> bool -> E_node.t + (** Node for either true or false *) + + val set_as_lit : t -> E_node.t -> Lit.t -> unit + (** map the given e_node to a literal. *) + + val find_t : t -> Term.t -> repr + (** Current representative of the Term.t. + @raise E_node.t_found if the Term.t is not already {!add}-ed. *) + + val add_iter : t -> Term.t Iter.t -> unit + (** Add a sequence of terms to the congruence closure *) + + val all_classes : t -> repr Iter.t + (** All current classes. This is costly, only use if there is no other solution *) + + val explain_eq : t -> E_node.t -> E_node.t -> Resolved_expl.t + (** Explain why the two nodes are equal. + Fails if they are not, in an unspecified way. *) + + val explain_expl : t -> Expl.t -> Resolved_expl.t + (** Transform explanation into an actionable conflict clause *) + + (* FIXME: remove + val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a + (** Raise a conflict with the given explanation. + It must be a theory tautology that [expl ==> absurd]. + To be used in theories. + + This fails in an unspecified way if the explanation, once resolved, + satisfies {!Resolved_expl.is_semantic}. *) + *) + + val merge : t -> E_node.t -> E_node.t -> Expl.t -> unit + (** Merge these two nodes given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + + val merge_t : t -> Term.t -> Term.t -> Expl.t -> unit + (** Shortcut for adding + merging *) + + (** {3 Main API *) + + val assert_eq : t -> Term.t -> Term.t -> Expl.t -> unit + (** Assert that two terms are equal, using the given explanation. *) + + val assert_lit : t -> Lit.t -> unit + (** Given a literal, assume it in the congruence closure and propagate + its consequences. Will be backtracked. + + Useful for the theory combination or the SAT solver's functor *) + + val assert_lits : t -> Lit.t Iter.t -> unit + (** Addition of many literals *) + + val check : t -> Result_action.or_conflict + (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. + Will use the {!actions} to propagate literals, declare conflicts, etc. *) + + val push_level : t -> unit + (** Push backtracking level *) + + val pop_levels : t -> int -> unit + (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) + + val get_model : t -> E_node.t Iter.t Iter.t + (** get all the equivalence classes so they can be merged in the model *) + + val create : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. + *) + + (**/**) + + module Debug_ : sig + val pp : t Fmt.printer + (** Print the whole CC *) + end + + (**/**) +end + +(* TODO: full EGG, also have a function to update the value when + the subterms (produced in [of_term]) are updated *) + +(** Data attached to the congruence closure classes. + + This helps theories keeping track of some state for each class. + The state of a class is the monoidal combination of the state for each + Term.t in the class (for example, the set of terms in the + class whose head symbol is a datatype constructor). *) +module type MONOID_PLUGIN_ARG = sig + module CC : S + + type t + (** Some type with a monoid structure *) + + include Sidekick_sigs.PRINT with type t := t + + val name : string + (** name of the monoid structure (short) *) + + (* FIXME: for subs, return list of e_nodes, and assume of_term already + returned data for them. *) + val of_term : + CC.t -> CC.E_node.t -> Term.t -> t option * (CC.E_node.t * t) list + (** [of_term n t], where [t] is the Term.t annotating node [n], + must return [maybe_m, l], where: + + - [maybe_m = Some m] if [t] has monoid value [m]; + otherwise [maybe_m=None] + - [l] is a list of [(u, m_u)] where each [u]'s Term.t + is a direct subterm of [t] + and [m_u] is the monoid value attached to [u]. + + *) + + val merge : + CC.t -> + CC.E_node.t -> + t -> + CC.E_node.t -> + t -> + CC.Expl.t -> + (t * CC.Handler_action.t list, CC.Handler_action.conflict) result + (** Monoidal combination of two values. + + [merge cc n1 mon1 n2 mon2 expl] returns the result of merging + monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) + when [n1] and [n2] are merged with explanation [expl]. + + @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; + or [Error expl'] if the merge is unsatisfiable. [expl'] can then be + used to trigger a conflict and undo the merge. + *) +end + +(** Stateful plugin holding a per-equivalence-class monoid. + + Helps keep track of monoid state per equivalence class. + A theory might use one or more instance(s) of this to + aggregate some theory-specific state over all terms, with + the information of what terms are already known to be equal + potentially saving work for the theory. *) +module type DYN_MONOID_PLUGIN = sig + module M : MONOID_PLUGIN_ARG + include Sidekick_sigs.DYN_BACKTRACKABLE + + val pp : unit Fmt.printer + + val mem : M.CC.E_node.t -> bool + (** Does the CC E_node.t have a monoid value? *) + + val get : M.CC.E_node.t -> M.t option + (** Get monoid value for this CC E_node.t, if any *) + + val iter_all : (M.CC.repr * M.t) Iter.t +end + +(** Builder for a plugin. + + The builder takes a congruence closure, and instantiate the + plugin on it. *) +module type MONOID_PLUGIN_BUILDER = sig + module M : MONOID_PLUGIN_ARG + + module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M + + type t = (module DYN_PL_FOR_M) + + val create_and_setup : ?size:int -> M.CC.t -> t + (** Create a new monoid state *) +end diff --git a/src/cc/view.ml b/src/cc/view.ml new file mode 100644 index 00000000..e319f5ef --- /dev/null +++ b/src/cc/view.ml @@ -0,0 +1,38 @@ +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't +(* do not enter *) + +let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = + match v with + | Bool b -> Bool b + | App_fun (f, args) -> App_fun (f_f f, f_ts args) + | App_ho (f, a) -> App_ho (f_t f, f_t a) + | Not t -> Not (f_t t) + | If (a, b, c) -> If (f_t a, f_t b, f_t c) + | Eq (a, b) -> Eq (f_t a, f_t b) + | Opaque t -> Opaque (f_t t) + +let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = + match v with + | Bool _ -> () + | App_fun (f, args) -> + f_f f; + f_ts args + | App_ho (f, a) -> + f_t f; + f_t a + | Not t -> f_t t + | If (a, b, c) -> + f_t a; + f_t b; + f_t c + | Eq (a, b) -> + f_t a; + f_t b + | Opaque t -> f_t t diff --git a/src/cc/view.mli b/src/cc/view.mli new file mode 100644 index 00000000..038ea1a6 --- /dev/null +++ b/src/cc/view.mli @@ -0,0 +1,33 @@ +(** View terms through the lens of the Congruence Closure *) + +(** A view of a term fron the point of view of the congruence closure. + + - ['f] is the type of function symbols + - ['t] is the type of terms + - ['ts] is the type of sequences of terms (arguments of function application) + *) +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't (** do not enter *) + +val map_view : + f_f:('a -> 'b) -> + f_t:('c -> 'd) -> + f_ts:('e -> 'f) -> + ('a, 'c, 'e) t -> + ('b, 'd, 'f) t +(** Map function over a view, one level deep. + Each function maps over a different type, e.g. [f_t] maps over terms *) + +val iter_view : + f_f:('a -> unit) -> + f_t:('b -> unit) -> + f_ts:('c -> unit) -> + ('a, 'b, 'c) t -> + unit +(** Iterate over a view, one level deep. *) From c09650db513a322a869bfbe6570db93f0d361407 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 00:15:05 -0400 Subject: [PATCH 041/174] refactor(cc): continue de-functorizing --- src/cc/Sidekick_cc.ml | 13 +++++++++++++ src/cc/Sidekick_cc.mli | 28 +++++++--------------------- src/cc/plugin/sidekick_cc_plugin.ml | 5 ++--- 3 files changed, 22 insertions(+), 24 deletions(-) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 7648562c..9b272403 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -3,7 +3,20 @@ module View = View module type ARG = Sigs.ARG module type S = Sigs.S +module type DYN_MONOID_PLUGIN = Sigs.DYN_MONOID_PLUGIN module type MONOID_PLUGIN_ARG = Sigs.MONOID_PLUGIN_ARG module type MONOID_PLUGIN_BUILDER = Sigs.MONOID_PLUGIN_BUILDER module Make (A : ARG) : S = Core_cc.Make (A) + +module Base : S = Make (struct + let view_as_cc (t : Term.t) : _ View.t = + let f, args = Term.unfold_app t in + match Term.view f, args with + | _, [ _; t; u ] when Term.is_eq f -> View.Eq (t, u) + | _ -> + (match Term.view t with + | Term.E_app (f, a) -> View.App_ho (f, a) + | Term.E_const c -> View.App_fun (c, Iter.empty) + | _ -> View.Opaque t) +end) diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 0eb9def5..9c7da989 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -4,26 +4,12 @@ open Sidekick_core module View = View module type ARG = Sigs.ARG - -module type S = sig - include Sigs.S - - val create : - ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t - (** Create a new congruence closure. - - @param term_store used to be able to create new terms. All terms - interacting with this congruence closure must belong in this term state - as well. *) - - (**/**) - - module Debug_ : sig - val pp : t Fmt.printer - (** Print the whole CC *) - end - - (**/**) -end +module type S = Sigs.S +module type DYN_MONOID_PLUGIN = Sigs.DYN_MONOID_PLUGIN +module type MONOID_PLUGIN_ARG = Sigs.MONOID_PLUGIN_ARG +module type MONOID_PLUGIN_BUILDER = Sigs.MONOID_PLUGIN_BUILDER module Make (_ : ARG) : S + +module Base : S +(** Basic implementation following terms' shape *) diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin/sidekick_cc_plugin.ml index 0563977e..39327e1e 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin/sidekick_cc_plugin.ml @@ -1,3 +1,4 @@ +open Sidekick_core open Sidekick_cc module type EXTENDED_PLUGIN_BUILDER = sig @@ -23,8 +24,6 @@ module Make (M : MONOID_PLUGIN_ARG) : module Cls_tbl = Backtrackable_tbl.Make (E_node) module Expl = CC.Expl - type term = CC.term - module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M type t = (module DYN_PL_FOR_M) @@ -63,7 +62,7 @@ module Make (M : MONOID_PLUGIN_ARG) : else None - let on_new_term cc n (t : term) : CC.Handler_action.t list = + let on_new_term cc n (t : Term.t) : CC.Handler_action.t list = (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) let acts = ref [] in let maybe_m, l = M.of_term cc n t in From d4ba4602a421d0270dadaa0a99e951374978ada5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 22:28:21 -0400 Subject: [PATCH 042/174] refactor(sat): simplify interface a lot - pure_sat is not a functor anymore - make_cdcl_t is only functorized over theory - both use standard `Lit.t` and proofs --- src/sat/Proof_dummy.ml | 31 --------- src/sat/Sidekick_sat.ml | 19 ++---- src/sat/Solver.ml | 135 ++++++++++++++++-------------------- src/sat/Solver.mli | 15 +--- src/sat/Solver_intf.ml | 148 ++++++++++++---------------------------- src/sat/dune | 5 +- 6 files changed, 111 insertions(+), 242 deletions(-) delete mode 100644 src/sat/Proof_dummy.ml diff --git a/src/sat/Proof_dummy.ml b/src/sat/Proof_dummy.ml deleted file mode 100644 index 947be4b4..00000000 --- a/src/sat/Proof_dummy.ml +++ /dev/null @@ -1,31 +0,0 @@ -(** Dummy proof module using rule=[unit]. - - These proof traces will not record anything. *) - -module Make (Lit : sig - type t -end) : sig - module Proof_trace : - Sidekick_sigs_proof_trace.S - with type A.rule = unit - and type A.step_id = unit - and type t = unit - - module Proof_rules : - Solver_intf.PROOF_RULES - with type lit = Lit.t - and type rule = unit - and type step_id = unit -end = struct - module Proof_trace = Sidekick_proof_trace_dummy.Unit - - module Proof_rules = struct - type lit = Lit.t - type rule = unit - type step_id = unit - - let sat_input_clause _ = () - let sat_redundant_clause _ ~hyps:_ = () - let sat_unsat_core _ = () - end -end diff --git a/src/sat/Sidekick_sat.ml b/src/sat/Sidekick_sat.ml index 2210b271..bbbb6089 100644 --- a/src/sat/Sidekick_sat.ml +++ b/src/sat/Sidekick_sat.ml @@ -1,29 +1,25 @@ (** Main API *) +open Sidekick_core module Solver_intf = Solver_intf module type S = Solver_intf.S module type LIT = Solver_intf.LIT module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T -module type PLUGIN_SAT = Solver_intf.PLUGIN_SAT -module type PROOF_RULES = Solver_intf.PROOF_RULES type lbool = Solver_intf.lbool = L_true | L_false | L_undefined module type SAT_STATE = Solver_intf.SAT_STATE -type 'form sat_state = 'form Solver_intf.sat_state +type sat_state = Solver_intf.sat_state -type ('lit, 'proof) reason = ('lit, 'proof) Solver_intf.reason = - | Consequence of (unit -> 'lit list * 'proof) +type reason = Solver_intf.reason = + | Consequence of (unit -> Lit.t list * Proof_step.id) [@@unboxed] module type ACTS = Solver_intf.ACTS -type ('lit, 'proof, 'proof_step) acts = - ('lit, 'proof, 'proof_step) Solver_intf.acts - -type negated = bool +type acts = (module ACTS) (** Print {!lbool} values *) let pp_lbool out = function @@ -36,7 +32,4 @@ exception Resource_exhausted = Solver_intf.Resource_exhausted module Solver = Solver module Make_cdcl_t = Solver.Make_cdcl_t -module Make_pure_sat = Solver.Make_pure_sat - -module Proof_dummy = Proof_dummy -(** Module for dummy proofs based on unit *) +module Pure_sat = Solver.Pure_sat diff --git a/src/sat/Solver.ml b/src/sat/Solver.ml index 1d33c63c..58a9a986 100644 --- a/src/sat/Solver.ml +++ b/src/sat/Solver.ml @@ -1,3 +1,5 @@ +open Sidekick_core + module type PLUGIN = sig val has_theory : bool (** [true] iff the solver is parametrized by a theory, not just @@ -13,16 +15,9 @@ let invalid_argf fmt = Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt module Make (Plugin : PLUGIN) = struct - module Lit = Plugin.Lit - module Proof_trace = Plugin.Proof_trace - module Proof_rules = Plugin.Proof_rules - module Step_vec = Proof_trace.A.Step_vec + module Step_vec = Proof_trace.Step_vec - type lit = Plugin.Lit.t type theory = Plugin.t - type proof_rule = Proof_trace.A.rule - type proof_step = Proof_trace.A.step_id - type proof_trace = Proof_trace.t module Clause_pool_id : sig type t = private int @@ -128,10 +123,10 @@ module Make (Plugin : PLUGIN) = struct (* atoms *) a_is_true: Bitvec.t; a_seen: Bitvec.t; - a_form: lit Vec.t; + a_form: Lit.t Vec.t; (* TODO: store watches in clauses instead *) a_watched: Clause0.CVec.t Vec.t; - a_proof_lvl0: proof_step ATbl.t; + a_proof_lvl0: Proof_step.id ATbl.t; (* atom -> proof for it to be true at level 0 *) stat_n_atoms: int Stat.counter; (* clauses *) @@ -296,9 +291,9 @@ module Make (Plugin : PLUGIN) = struct (** Make a clause with the given atoms *) - val make_a : store -> removable:bool -> atom array -> proof_step -> t - val make_l : store -> removable:bool -> atom list -> proof_step -> t - val make_vec : store -> removable:bool -> atom Vec.t -> proof_step -> t + val make_a : store -> removable:bool -> atom array -> Proof_step.id -> t + val make_l : store -> removable:bool -> atom list -> Proof_step.id -> t + val make_vec : store -> removable:bool -> atom Vec.t -> Proof_step.id -> t val n_atoms : store -> t -> int val marked : store -> t -> bool val set_marked : store -> t -> bool -> unit @@ -312,8 +307,8 @@ module Make (Plugin : PLUGIN) = struct val dealloc : store -> t -> unit (** Delete the clause *) - val set_proof_step : store -> t -> proof_step -> unit - val proof_step : store -> t -> proof_step + val set_proof_step : store -> t -> Proof_step.id -> unit + val proof_step : store -> t -> Proof_step.id val activity : store -> t -> float val set_activity : store -> t -> float -> unit val iter : store -> f:(atom -> unit) -> t -> unit @@ -321,9 +316,9 @@ module Make (Plugin : PLUGIN) = struct val for_all : store -> f:(atom -> bool) -> t -> bool val exists : store -> f:(atom -> bool) -> t -> bool val atoms_a : store -> t -> atom array - val lits_l : store -> t -> lit list - val lits_a : store -> t -> lit array - val lits_iter : store -> t -> lit Iter.t + val lits_l : store -> t -> Lit.t list + val lits_a : store -> t -> Lit.t array + val lits_iter : store -> t -> Lit.t Iter.t val short_name : store -> t -> string val pp : store -> Format.formatter -> t -> unit val debug : store -> Format.formatter -> t -> unit @@ -485,15 +480,15 @@ module Make (Plugin : PLUGIN) = struct let[@inline] atoms_a store c : atom array = Vec.get store.c_store.c_lits (c : t :> int) - let lits_l store c : lit list = + let lits_l store c : Lit.t list = let arr = atoms_a store c in Util.array_to_list_map (Atom.lit store) arr - let lits_a store c : lit array = + let lits_a store c : Lit.t array = let arr = atoms_a store c in Array.map (Atom.lit store) arr - let lits_iter store c : lit Iter.t = + let lits_iter store c : Lit.t Iter.t = let arr = atoms_a store c in Iter.of_array arr |> Iter.map (Atom.lit store) @@ -512,7 +507,8 @@ module Make (Plugin : PLUGIN) = struct end (* allocate new variable *) - let alloc_var_uncached_ ?default_pol:(pol = true) self (form : lit) : var = + let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var + = let { v_count; v_of_lit; @@ -560,7 +556,7 @@ module Make (Plugin : PLUGIN) = struct v (* create new variable *) - let alloc_var (self : t) ?default_pol (lit : lit) : + let alloc_var (self : t) ?default_pol (lit : Lit.t) : var * Solver_intf.same_sign = let lit, same_sign = Lit.norm_sign lit in try Lit_tbl.find self.v_of_lit lit, same_sign @@ -882,9 +878,9 @@ module Make (Plugin : PLUGIN) = struct mutable clause_incr: float; (* increment for clauses' activity *) (* FIXME: use event *) on_conflict: (Clause.t, unit) Event.Emitter.t; - on_decision: (lit, unit) Event.Emitter.t; + on_decision: (Lit.t, unit) Event.Emitter.t; on_learnt: (Clause.t, unit) Event.Emitter.t; - on_gc: (lit array, unit) Event.Emitter.t; + on_gc: (Lit.t array, unit) Event.Emitter.t; stat: Stat.t; n_conflicts: int Stat.counter; n_propagations: int Stat.counter; @@ -975,11 +971,11 @@ module Make (Plugin : PLUGIN) = struct let[@inline] insert_var_order st (v : var) : unit = H.insert st.order v (* find atom for the lit, if any *) - let[@inline] find_atom_ (self : t) (p : lit) : atom option = + let[@inline] find_atom_ (self : t) (p : Lit.t) : atom option = Store.find_atom self.store p (* create a new atom, pushing it into the decision queue if needed *) - let make_atom_ (self : t) ?default_pol (p : lit) : atom = + let make_atom_ (self : t) ?default_pol (p : Lit.t) : atom = let a = Store.alloc_atom self.store ?default_pol p in if Atom.level self.store a < 0 then insert_var_order self (Atom.var a) @@ -1041,7 +1037,7 @@ module Make (Plugin : PLUGIN) = struct (* get/build the proof for [a], which must be an atom true at level 0. This uses a global cache to avoid repeated computations, as many clauses might resolve against a given 0-level atom. *) - let rec proof_of_atom_lvl0_ (self : t) (a : atom) : proof_step = + let rec proof_of_atom_lvl0_ (self : t) (a : atom) : Proof_step.id = assert (Atom.is_true self.store a && Atom.level self.store a = 0); match Atom.proof_lvl0 self.store a with @@ -1075,7 +1071,7 @@ module Make (Plugin : PLUGIN) = struct proof_c2 else Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause + @@ Proof_sat.sat_redundant_clause (Iter.return (Atom.lit self.store a)) ~hyps:Iter.(cons proof_c2 (of_list !steps)) in @@ -1168,7 +1164,7 @@ module Make (Plugin : PLUGIN) = struct let proof = let lits = Iter.of_array atoms |> Iter.map (Atom.lit store) in Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause lits + @@ Proof_sat.sat_redundant_clause lits ~hyps: Iter.( cons (Clause.proof_step self.store c) (of_list !res0_proofs)) @@ -1282,7 +1278,7 @@ module Make (Plugin : PLUGIN) = struct let p_empty = Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause Iter.empty + @@ Proof_sat.sat_redundant_clause Iter.empty ~hyps:(Step_vec.to_iter pvec) in Step_vec.clear pvec; @@ -1643,7 +1639,7 @@ module Make (Plugin : PLUGIN) = struct let p = Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause + @@ Proof_sat.sat_redundant_clause (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) ~hyps:(Step_vec.to_iter cr.cr_steps) in @@ -1660,7 +1656,7 @@ module Make (Plugin : PLUGIN) = struct let fuip = cr.cr_learnt.(0) in let p = Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause + @@ Proof_sat.sat_redundant_clause (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) ~hyps:(Step_vec.to_iter cr.cr_steps) in @@ -1842,8 +1838,8 @@ module Make (Plugin : PLUGIN) = struct let[@inline] slice_get st i = AVec.get st.trail i - let acts_add_clause self ?(keep = false) (l : lit list) (p : proof_step) : - unit = + let acts_add_clause self ?(keep = false) (l : Lit.t list) (p : Proof_step.id) + : unit = let atoms = List.rev_map (make_atom_ self) l in let removable = not keep in let c = Clause.make_l self.store ~removable atoms p in @@ -1852,8 +1848,8 @@ module Make (Plugin : PLUGIN) = struct (* will be added later, even if we backtrack *) Delayed_actions.add_clause_learnt self.delayed_actions c - let acts_add_clause_in_pool self ~pool (l : lit list) (p : proof_step) : unit - = + let acts_add_clause_in_pool self ~pool (l : Lit.t list) (p : Proof_step.id) : + unit = let atoms = List.rev_map (make_atom_ self) l in let removable = true in let c = Clause.make_l self.store ~removable atoms p in @@ -1864,7 +1860,7 @@ module Make (Plugin : PLUGIN) = struct (* will be added later, even if we backtrack *) Delayed_actions.add_clause_pool self.delayed_actions c pool - let acts_add_decision_lit (self : t) (f : lit) (sign : bool) : unit = + let acts_add_decision_lit (self : t) (f : Lit.t) (sign : bool) : unit = let store = self.store in let a = make_atom_ self f in let a = @@ -1879,7 +1875,7 @@ module Make (Plugin : PLUGIN) = struct Delayed_actions.add_decision self.delayed_actions a ) - let acts_raise self (l : lit list) (p : proof_step) : 'a = + let acts_raise self (l : Lit.t list) (p : Proof_step.id) : 'a = let atoms = List.rev_map (make_atom_ self) l in (* conflicts can be removed *) let c = Clause.make_l self.store ~removable:true atoms p in @@ -1903,7 +1899,7 @@ module Make (Plugin : PLUGIN) = struct (Atom.debug store) (Atom.neg a) | exception Not_found -> () - let acts_propagate (self : t) f (expl : (_, proof_step) Solver_intf.reason) = + let acts_propagate (self : t) f (expl : Solver_intf.reason) = let store = self.store in match expl with | Solver_intf.Consequence mk_expl -> @@ -1994,19 +1990,15 @@ module Make (Plugin : PLUGIN) = struct else Solver_intf.L_undefined - let[@inline] acts_eval_lit self (f : lit) : Solver_intf.lbool = + let[@inline] acts_eval_lit self (f : Lit.t) : Solver_intf.lbool = let a = make_atom_ self f in eval_atom_ self a let[@inline] acts_add_lit self ?default_pol f : unit = ignore (make_atom_ ?default_pol self f : atom) - let[@inline] current_slice st : _ Solver_intf.acts = + let[@inline] current_slice st : Solver_intf.acts = let module M = struct - type nonrec proof = Proof_trace.t - type nonrec proof_step = proof_step - type nonrec lit = lit - let proof = st.proof let iter_assumptions = acts_iter st ~full:false st.th_head let eval_lit = acts_eval_lit st @@ -2019,12 +2011,8 @@ module Make (Plugin : PLUGIN) = struct (module M) (* full slice, for [if_sat] final check *) - let[@inline] full_slice st : _ Solver_intf.acts = + let[@inline] full_slice st : Solver_intf.acts = let module M = struct - type nonrec proof = Proof_trace.t - type nonrec proof_step = proof_step - type nonrec lit = lit - let proof = st.proof let iter_assumptions = acts_iter st ~full:true st.th_head let eval_lit = acts_eval_lit st @@ -2403,7 +2391,7 @@ module Make (Plugin : PLUGIN) = struct let atoms = Util.array_of_list_map (make_atom_ self) l in let proof = Proof_trace.add_step self.proof - @@ Proof_rules.sat_input_clause (Iter.of_list l) + @@ Proof_sat.sat_input_clause (Iter.of_list l) in let c = Clause.make_a self.store ~removable:false atoms proof in Log.debugf 10 (fun k -> @@ -2419,14 +2407,14 @@ module Make (Plugin : PLUGIN) = struct let[@inline] add_lit self ?default_pol lit = ignore (make_atom_ self lit ?default_pol : atom) - let[@inline] set_default_pol (self : t) (lit : lit) (pol : bool) : unit = + let[@inline] set_default_pol (self : t) (lit : Lit.t) (pol : bool) : unit = let a = make_atom_ self lit ~default_pol:pol in Var.set_default_pol self.store (Atom.var a) pol (* Result type *) type res = - | Sat of Lit.t Solver_intf.sat_state - | Unsat of (lit, clause, proof_step) Solver_intf.unsat_state + | Sat of Solver_intf.sat_state + | Unsat of clause Solver_intf.unsat_state let pp_all self lvl status = Log.debugf lvl (fun k -> @@ -2447,7 +2435,7 @@ module Make (Plugin : PLUGIN) = struct (Util.pp_iter @@ Clause.debug self.store) (cp_to_iter_ self.clauses_learnt)) - let mk_sat (self : t) : Lit.t Solver_intf.sat_state = + let mk_sat (self : t) : Solver_intf.sat_state = pp_all self 99 "SAT"; let t = self.trail in let module M = struct @@ -2495,7 +2483,7 @@ module Make (Plugin : PLUGIN) = struct let lits = Iter.of_list !res |> Iter.map (Atom.lit self.store) in let hyps = Iter.of_list (Clause.proof_step self.store c :: !lvl0) in Proof_trace.add_step self.proof - @@ Proof_rules.sat_redundant_clause lits ~hyps + @@ Proof_sat.sat_redundant_clause lits ~hyps in Clause.make_l self.store ~removable:false !res proof ) @@ -2530,16 +2518,13 @@ module Make (Plugin : PLUGIN) = struct assert (Atom.equal first @@ List.hd core); let proof = let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in - Proof_trace.add_step self.proof - @@ Proof_rules.sat_unsat_core lits + Proof_trace.add_step self.proof @@ Proof_sat.sat_unsat_core lits in Clause.make_l self.store ~removable:false [] proof) in fun () -> Lazy.force c in let module M = struct - type nonrec lit = lit - type nonrec proof_step = proof_step type clause = Clause.t let unsat_conflict = unsat_conflict @@ -2554,7 +2539,7 @@ module Make (Plugin : PLUGIN) = struct type propagation_result = | PR_sat | PR_conflict of { backtracked: int } - | PR_unsat of (lit, clause, proof_step) Solver_intf.unsat_state + | PR_unsat of clause Solver_intf.unsat_state (* decide on assumptions, and do propagations, but no other kind of decision *) let propagate_under_assumptions (self : t) : propagation_result = @@ -2591,8 +2576,8 @@ module Make (Plugin : PLUGIN) = struct assert false with Exit -> !result - let add_clause_atoms_ self ~pool ~removable (c : atom array) (pr : proof_step) - : unit = + let add_clause_atoms_ self ~pool ~removable (c : atom array) + (pr : Proof_step.id) : unit = try let c = Clause.make_a self.store ~removable c pr in add_clause_ ~pool self c @@ -2602,26 +2587,26 @@ module Make (Plugin : PLUGIN) = struct let c = Array.map (make_atom_ self) c in add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr - let add_clause self (c : lit list) (pr : proof_step) : unit = + let add_clause self (c : Lit.t list) (pr : Proof_step.id) : unit = let c = Util.array_of_list_map (make_atom_ self) c in add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr - let add_input_clause self (c : lit list) = + let add_input_clause self (c : Lit.t list) = let pr = Proof_trace.add_step self.proof - @@ Proof_rules.sat_input_clause (Iter.of_list c) + @@ Proof_sat.sat_input_clause (Iter.of_list c) in add_clause self c pr let add_input_clause_a self c = let pr = Proof_trace.add_step self.proof - @@ Proof_rules.sat_input_clause (Iter.of_array c) + @@ Proof_sat.sat_input_clause (Iter.of_array c) in add_clause_a self c pr (* run [f()] with additional assumptions *) - let with_local_assumptions_ (self : t) (assumptions : lit list) f = + let with_local_assumptions_ (self : t) (assumptions : Lit.t list) f = let old_assm_lvl = AVec.size self.assumptions in List.iter (fun lit -> @@ -2645,7 +2630,7 @@ module Make (Plugin : PLUGIN) = struct Sat (mk_sat self) with E_unsat us -> Unsat (mk_unsat self us) - let push_assumption (self : t) (lit : lit) : unit = + let push_assumption (self : t) (lit : Lit.t) : unit = let a = make_atom_ self lit in AVec.push self.assumptions a @@ -2667,7 +2652,7 @@ module Make (Plugin : PLUGIN) = struct let us = mk_unsat self us in PR_unsat us - let true_at_level0 (self : t) (lit : lit) : bool = + let true_at_level0 (self : t) (lit : Lit.t) : bool = match find_atom_ self lit with | None -> false | Some a -> @@ -2676,7 +2661,7 @@ module Make (Plugin : PLUGIN) = struct b && lev = 0 with UndecidedLit -> false) - let[@inline] eval_lit self (lit : lit) : Solver_intf.lbool = + let[@inline] eval_lit self (lit : Lit.t) : Solver_intf.lbool = match find_atom_ self lit with | Some a -> eval_atom_ self a | None -> Solver_intf.L_undefined @@ -2690,11 +2675,7 @@ module Make_cdcl_t (Plugin : Solver_intf.PLUGIN_CDCL_T) = Make (struct end) [@@inline] [@@specialise] -module Make_pure_sat (Plugin : Solver_intf.PLUGIN_SAT) = Make (struct - module Lit = Plugin.Lit - module Proof_trace = Plugin.Proof_trace - module Proof_rules = Plugin.Proof_rules - +module Pure_sat = Make (struct type t = unit let push_level () = () diff --git a/src/sat/Solver.mli b/src/sat/Solver.mli index 3a0858d0..499e94ee 100644 --- a/src/sat/Solver.mli +++ b/src/sat/Solver.mli @@ -1,16 +1,5 @@ module type S = Solver_intf.S (** Safe external interface of solvers. *) -module Make_pure_sat (Th : Solver_intf.PLUGIN_SAT) : - S - with module Lit = Th.Lit - and module Proof_trace = Th.Proof_trace - and module Proof_rules = Th.Proof_rules - and type theory = unit - -module Make_cdcl_t (Th : Solver_intf.PLUGIN_CDCL_T) : - S - with module Lit = Th.Lit - and module Proof_trace = Th.Proof_trace - and module Proof_rules = Th.Proof_rules - and type theory = Th.t +module Pure_sat : S with type theory = unit +module Make_cdcl_t (Th : Solver_intf.PLUGIN_CDCL_T) : S with type theory = Th.t diff --git a/src/sat/Solver_intf.ml b/src/sat/Solver_intf.ml index a0797607..f3630ba0 100644 --- a/src/sat/Solver_intf.ml +++ b/src/sat/Solver_intf.ml @@ -11,53 +11,46 @@ Copyright 2016 Guillaume Bury Copyright 2016 Simon Cruanes *) +open Sidekick_core + type 'a printer = Format.formatter -> 'a -> unit (** Solver in a "SATISFIABLE" state *) module type SAT_STATE = sig - type lit - (** Literals (signed boolean atoms) *) - - val eval : lit -> bool + val eval : Lit.t -> bool (** Returns the valuation of a lit in the current state of the sat solver. @raise UndecidedLit if the literal is not decided *) - val eval_level : lit -> bool * int + val eval_level : Lit.t -> bool * int (** Return the current assignement of the literals, as well as its decision level. If the level is 0, then it is necessary for the literal to have this value; otherwise it is due to choices that can potentially be backtracked. @raise UndecidedLit if the literal is not decided *) - val iter_trail : (lit -> unit) -> unit + val iter_trail : (Lit.t -> unit) -> unit (** Iter through the lits in order of decision/propagation (starting from the first propagation, to the last propagation). *) end -type 'form sat_state = (module SAT_STATE with type lit = 'form) +type sat_state = (module SAT_STATE) (** The type of values returned when the solver reaches a SAT state. *) (** Solver in an "UNSATISFIABLE" state *) module type UNSAT_STATE = sig - type lit type clause - type proof_step val unsat_conflict : unit -> clause (** Returns the unsat clause found at the toplevel *) - val unsat_assumptions : unit -> lit Iter.t + val unsat_assumptions : unit -> Lit.t Iter.t (** Subset of assumptions responsible for "unsat" *) - val unsat_proof : unit -> proof_step + val unsat_proof : unit -> Proof_term.step_id end -type ('lit, 'clause, 'proof_step) unsat_state = - (module UNSAT_STATE - with type lit = 'lit - and type clause = 'clause - and type proof_step = 'proof_step) +type 'clause unsat_state = (module UNSAT_STATE with type clause = 'clause) (** The type of values returned when the solver reaches an UNSAT state. *) type same_sign = bool @@ -65,9 +58,7 @@ type same_sign = bool [true] means the literal stayed the same, [false] that its sign was flipped. *) (** The type of reasons for propagations of a lit [f]. *) -type ('lit, 'proof_step) reason = - | Consequence of (unit -> 'lit list * 'proof_step) -[@@unboxed] +type reason = Consequence of (unit -> Lit.t list * Proof_step.id) [@@unboxed] (** [Consequence (l, p)] means that the lits in [l] imply the propagated lit [f]. The proof should be a proof of the clause "[l] implies [f]". @@ -95,23 +86,19 @@ type lbool = L_true | L_false | L_undefined (** Valuation of an atom *) are provided with a [(module ACTS)] so they can modify the SAT solver by adding new lemmas, raise conflicts, etc. *) module type ACTS = sig - type lit - type proof - type proof_step + val proof : Proof_trace.t - val proof : proof - - val iter_assumptions : (lit -> unit) -> unit + val iter_assumptions : (Lit.t -> unit) -> unit (** Traverse the new assumptions on the boolean trail. *) - val eval_lit : lit -> lbool + val eval_lit : Lit.t -> lbool (** Obtain current value of the given literal *) - val add_lit : ?default_pol:bool -> lit -> unit + val add_lit : ?default_pol:bool -> Lit.t -> unit (** Map the given lit to an internal atom, which will be decided by the SAT solver. *) - val add_clause : ?keep:bool -> lit list -> proof_step -> unit + val add_clause : ?keep:bool -> Lit.t list -> Proof_step.id -> unit (** Add a clause to the solver. @param keep if true, the clause will be kept by the solver. Otherwise the solver is allowed to GC the clause and propose this @@ -119,26 +106,22 @@ module type ACTS = sig - [C_use_allocator alloc] puts the clause in the given allocator. *) - val raise_conflict : lit list -> proof_step -> 'b + val raise_conflict : Lit.t list -> Proof_step.id -> 'b (** Raise a conflict, yielding control back to the solver. The list of atoms must be a valid theory lemma that is false in the current trail. *) - val propagate : lit -> (lit, proof_step) reason -> unit + val propagate : Lit.t -> reason -> unit (** Propagate a lit, i.e. the theory can evaluate the lit to be true (see the definition of {!type:eval_res} *) - val add_decision_lit : lit -> bool -> unit + val add_decision_lit : Lit.t -> bool -> unit (** Ask the SAT solver to decide on the given lit with given sign before it can answer [SAT]. The order of decisions is still unspecified. Useful for theory combination. This will be undone on backtracking. *) end -type ('lit, 'proof, 'proof_step) acts = - (module ACTS - with type lit = 'lit - and type proof = 'proof - and type proof_step = 'proof_step) +type acts = (module ACTS) (** The type for a slice of assertions to assume/propagate in the theory. *) exception No_proof @@ -169,77 +152,39 @@ module type LIT = sig but one returns [false] and the other [true]. *) end -module type PROOF_RULES = Sidekick_sigs_proof_sat.S - (** Signature for theories to be given to the CDCL(T) solver *) module type PLUGIN_CDCL_T = sig type t (** The plugin state itself *) - module Lit : LIT - module Proof_trace : Sidekick_sigs_proof_trace.S - - module Proof_rules : - PROOF_RULES - with type lit = Lit.t - and type rule = Proof_trace.A.rule - and type step_id = Proof_trace.A.step_id - val push_level : t -> unit (** Create a new backtrack level *) val pop_levels : t -> int -> unit (** Pop [n] levels of the theory *) - val partial_check : - t -> (Lit.t, Proof_trace.t, Proof_trace.A.step_id) acts -> unit + val partial_check : t -> acts -> unit (** Assume the lits in the slice, possibly using the [slice] to push new lits to be propagated or to raising a conflict or to add new lemmas. *) - val final_check : - t -> (Lit.t, Proof_trace.t, Proof_trace.A.step_id) acts -> unit + val final_check : t -> acts -> unit (** Called at the end of the search in case a model has been found. If no new clause is pushed, then proof search ends and "sat" is returned; if lemmas are added, search is resumed; if a conflict clause is added, search backtracks and then resumes. *) end -(** Signature for pure SAT solvers *) -module type PLUGIN_SAT = sig - module Lit : LIT - module Proof_trace : Sidekick_sigs_proof_trace.S - - module Proof_rules : - PROOF_RULES - with type lit = Lit.t - and type rule = Proof_trace.A.rule - and type step_id = Proof_trace.A.step_id -end - exception Resource_exhausted (** Can be raised in a progress handler *) (** The external interface implemented by safe solvers, such as the one created by the {!Solver.Make} and {!Mcsolver.Make} functors. *) module type S = sig - (** {2 Internal modules} - These are the internal modules used, you should probably not use them - if you're not familiar with the internals of mSAT. *) - - module Lit : LIT - module Proof_trace : Sidekick_sigs_proof_trace.S - - type lit = Lit.t (** literals *) type clause type theory - type proof_rule = Proof_trace.A.rule - type proof_step = Proof_trace.A.step_id - - type proof_trace = Proof_trace.t - (** A representation of a full proof *) type solver (** The main solver type. *) @@ -262,23 +207,16 @@ module type S = sig val n_atoms : store -> t -> int - val lits_iter : store -> t -> lit Iter.t + val lits_iter : store -> t -> Lit.t Iter.t (** Literals of a clause *) - val lits_a : store -> t -> lit array + val lits_a : store -> t -> Lit.t array (** Atoms of a clause *) - val lits_l : store -> t -> lit list + val lits_l : store -> t -> Lit.t list (** List of atoms of a clause *) end - (** Proof rules for SAT solving *) - module Proof_rules : - PROOF_RULES - with type lit = lit - and type rule = proof_rule - and type step_id = proof_step - (** {2 Main Solver Type} *) type t = solver @@ -287,7 +225,7 @@ module type S = sig val create : ?stat:Stat.t -> ?size:[ `Tiny | `Small | `Big ] -> - proof:proof_trace -> + proof:Proof_trace.t -> theory -> t (** Create new solver @@ -305,21 +243,21 @@ module type S = sig val stat : t -> Stat.t (** Statistics *) - val proof : t -> proof_trace + val proof : t -> Proof_trace.t (** Access the inner proof *) val on_conflict : t -> (Clause.t, unit) Event.t - val on_decision : t -> (lit, unit) Event.t + val on_decision : t -> (Lit.t, unit) Event.t val on_learnt : t -> (Clause.t, unit) Event.t - val on_gc : t -> (lit array, unit) Event.t + val on_gc : t -> (Lit.t array, unit) Event.t (** {2 Types} *) (** Result type for the solver *) type res = - | Sat of lit sat_state + | Sat of sat_state (** Returned when the solver reaches SAT, with a model *) - | Unsat of (lit, clause, proof_step) unsat_state + | Unsat of clause unsat_state (** Returned when the solver reaches UNSAT, with a proof *) exception UndecidedLit @@ -328,25 +266,25 @@ module type S = sig (** {2 Base operations} *) - val assume : t -> lit list list -> unit + val assume : t -> Lit.t list list -> unit (** Add the list of clauses to the current set of assumptions. Modifies the sat solver state in place. *) - val add_clause : t -> lit list -> proof_step -> unit + val add_clause : t -> Lit.t list -> Proof_step.id -> unit (** Lower level addition of clauses *) - val add_clause_a : t -> lit array -> proof_step -> unit + val add_clause_a : t -> Lit.t array -> Proof_step.id -> unit (** Lower level addition of clauses *) - val add_input_clause : t -> lit list -> unit + val add_input_clause : t -> Lit.t list -> unit (** Like {!add_clause} but with the justification of being an input clause *) - val add_input_clause_a : t -> lit array -> unit + val add_input_clause_a : t -> Lit.t array -> unit (** Like {!add_clause_a} but with justification of being an input clause *) (** {2 Solving} *) - val solve : ?on_progress:(unit -> unit) -> ?assumptions:lit list -> t -> res + val solve : ?on_progress:(unit -> unit) -> ?assumptions:Lit.t list -> t -> res (** Try and solves the current set of clauses. @param assumptions additional atomic assumptions to be temporarily added. The assumptions are just used for this call to [solve], they are @@ -360,24 +298,24 @@ module type S = sig (** {2 Evaluating and adding literals} *) - val add_lit : t -> ?default_pol:bool -> lit -> unit + val add_lit : t -> ?default_pol:bool -> Lit.t -> unit (** Ensure the SAT solver handles this particular literal, ie add a boolean variable for it if it's not already there. *) - val set_default_pol : t -> lit -> bool -> unit + val set_default_pol : t -> Lit.t -> bool -> unit (** Set default polarity for the given boolean variable. Sign of the literal is ignored. *) - val true_at_level0 : t -> lit -> bool + val true_at_level0 : t -> Lit.t -> bool (** [true_at_level0 a] returns [true] if [a] was proved at level0, i.e. it must hold in all models *) - val eval_lit : t -> lit -> lbool + val eval_lit : t -> Lit.t -> lbool (** Evaluate atom in current state *) (** {2 Assumption stack} *) - val push_assumption : t -> lit -> unit + val push_assumption : t -> Lit.t -> unit (** Pushes an assumption onto the assumption stack. It will remain there until it's pop'd by {!pop_assumptions}. *) @@ -390,10 +328,10 @@ module type S = sig type propagation_result = | PR_sat | PR_conflict of { backtracked: int } - | PR_unsat of (lit, clause, proof_step) unsat_state + | PR_unsat of clause unsat_state val check_sat_propagations_only : - ?assumptions:lit list -> t -> propagation_result + ?assumptions:Lit.t list -> t -> propagation_result (** [check_sat_propagations_only solver] uses the added clauses and local assumptions (using {!push_assumptions} and [assumptions]) to quickly assess whether the context is satisfiable. diff --git a/src/sat/dune b/src/sat/dune index b912a7b6..56fdf8e7 100644 --- a/src/sat/dune +++ b/src/sat/dune @@ -1,7 +1,6 @@ (library (name sidekick_sat) (public_name sidekick.sat) - (libraries iter sidekick.util sidekick.core sidekick.sigs.proof-trace - sidekick.proof-trace.dummy) (synopsis "Pure OCaml SAT solver implementation for sidekick") - (flags :standard -open Sidekick_util)) + (libraries iter sidekick.util sidekick.core) + (flags :standard -w +32 -open Sidekick_util)) From e30590955e58ceedec34c9efa289573b2bd995b9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 22:37:31 -0400 Subject: [PATCH 043/174] refactor(sat): remove unused values, split code off main functor --- src/sat/Solver.ml | 1016 ++++++++++++++++++++------------------------- src/sat/dune | 1 + 2 files changed, 448 insertions(+), 569 deletions(-) diff --git a/src/sat/Solver.ml b/src/sat/Solver.ml index 58a9a986..891274e2 100644 --- a/src/sat/Solver.ml +++ b/src/sat/Solver.ml @@ -14,579 +14,518 @@ module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T let invalid_argf fmt = Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt -module Make (Plugin : PLUGIN) = struct - module Step_vec = Proof_trace.Step_vec +(* ### types ### *) - type theory = Plugin.t +(* a boolean variable (positive int) *) +module Var0 : sig + include Int_id.S +end = struct + include Int_id.Make () +end - module Clause_pool_id : sig - type t = private int +type var = Var0.t - val _unsafe_of_int : int -> t - end = struct - type t = int +(* a signed atom. +v is (v << 1), -v is (v<<1 | 1) *) +module Atom0 : sig + include Int_id.S - let _unsafe_of_int x = x - end + val neg : t -> t + val sign : t -> bool + val of_var : var -> t + val var : t -> var + val pa : var -> t + val na : var -> t - (* ### types ### *) + module AVec : Vec_sig.S with type elt := t + module ATbl : CCHashtbl.S with type key = t +end = struct + include Int_id.Make () - (* a boolean variable (positive int) *) - module Var0 : sig - include Int_id.S - end = struct - include Int_id.Make () - end + let[@inline] neg i = i lxor 1 + let[@inline] sign i = i land 1 = 0 + let[@inline] pa v = (v : var :> int) lsl 1 + let of_var = pa + let[@inline] var a = Var0.of_int_unsafe (a lsr 1) + let[@inline] na v = ((v : var :> int) lsl 1) lor 1 - type var = Var0.t + module AVec = Veci + module ATbl = CCHashtbl.Make (CCInt) +end - (* a signed atom. +v is (v << 1), -v is (v<<1 | 1) *) - module Atom0 : sig - include Int_id.S +module Clause0 : sig + include Int_id.S + module Tbl : Hashtbl.S with type key = t + module CVec : Vec_sig.S with type elt := t +end = struct + include Int_id.Make () + module Tbl = Util.Int_tbl + module CVec = Veci +end - val neg : t -> t - val sign : t -> bool - val of_var : var -> t - val var : t -> var - val abs : t -> t - val pa : var -> t - val na : var -> t +module Step_vec = Proof_trace.Step_vec - module AVec : Vec_sig.S with type elt := t - module ATbl : CCHashtbl.S with type key = t - end = struct - include Int_id.Make () +type atom = Atom0.t - let[@inline] neg i = i lxor 1 - let[@inline] sign i = i land 1 = 0 - let[@inline] pa v = (v : var :> int) lsl 1 - let of_var = pa - let[@inline] abs a = a land lnot 1 - let[@inline] var a = Var0.of_int_unsafe (a lsr 1) - let[@inline] na v = ((v : var :> int) lsl 1) lor 1 +type clause = Clause0.t +and reason = Decision | Bcp of clause | Bcp_lazy of clause lazy_t - module AVec = Veci - module ATbl = CCHashtbl.Make (CCInt) - end +module AVec = Atom0.AVec +(** Vector of atoms *) - type atom = Atom0.t +module ATbl = Atom0.ATbl +(** Hashtbl of atoms *) - module Clause0 : sig - include Int_id.S - module Tbl : Hashtbl.S with type key = t - module CVec : Vec_sig.S with type elt := t - end = struct - include Int_id.Make () - module Tbl = Util.Int_tbl - module CVec = Veci - end +module CVec = Clause0.CVec +(** Vector of clauses *) - type clause = Clause0.t - and reason = Decision | Bcp of clause | Bcp_lazy of clause lazy_t +(* ### stores ### *) - module AVec = Atom0.AVec - (** Vector of atoms *) +module Lit_tbl = Hashtbl.Make (Lit) - module ATbl = Atom0.ATbl - (** Hashtbl of atoms *) +(* variable/atom store *) +module Store = struct + type cstore = { + c_lits: atom array Vec.t; (* storage for clause content *) + c_activity: Vec_float.t; + c_recycle_idx: Veci.t; (* recycle clause numbers that were GC'd *) + c_proof: Step_vec.t; (* clause -> proof_rule for its proof *) + c_attached: Bitvec.t; + c_marked: Bitvec.t; + c_removable: Bitvec.t; + c_dead: Bitvec.t; + } - module CVec = Clause0.CVec - (** Vector of clauses *) + type t = { + (* variables *) + v_of_lit: var Lit_tbl.t; (* lit -> var *) + v_level: int Vec.t; (* decision/assignment level, or -1 *) + v_heap_idx: int Vec.t; (* index in priority heap *) + v_weight: Vec_float.t; (* heuristic activity *) + v_reason: reason option Vec.t; (* reason for assignment *) + v_seen: Bitvec.t; (* generic temporary marker *) + v_default_polarity: Bitvec.t; (* default polarity in decisions *) + mutable v_count: int; + (* atoms *) + a_is_true: Bitvec.t; + a_seen: Bitvec.t; + a_form: Lit.t Vec.t; + (* TODO: store watches in clauses instead *) + a_watched: Clause0.CVec.t Vec.t; + a_proof_lvl0: Proof_step.id ATbl.t; + (* atom -> proof for it to be true at level 0 *) + stat_n_atoms: int Stat.counter; + (* clauses *) + c_store: cstore; + } - (* ### stores ### *) + type store = t - module Lit_tbl = Hashtbl.Make (Lit) - - (* variable/atom store *) - module Store = struct - type cstore = { - c_lits: atom array Vec.t; (* storage for clause content *) - c_activity: Vec_float.t; - c_recycle_idx: Veci.t; (* recycle clause numbers that were GC'd *) - c_proof: Step_vec.t; (* clause -> proof_rule for its proof *) - c_attached: Bitvec.t; - c_marked: Bitvec.t; - c_removable: Bitvec.t; - c_dead: Bitvec.t; + let create ?(size = `Big) ~stat () : t = + let size_map = + match size with + | `Tiny -> 8 + | `Small -> 16 + | `Big -> 4096 + in + let stat_n_atoms = Stat.mk_int stat "sat.n-atoms" in + { + v_of_lit = Lit_tbl.create size_map; + v_level = Vec.create (); + v_heap_idx = Vec.create (); + v_weight = Vec_float.create (); + v_reason = Vec.create (); + v_seen = Bitvec.create (); + v_default_polarity = Bitvec.create (); + v_count = 0; + a_is_true = Bitvec.create (); + a_form = Vec.create (); + a_watched = Vec.create (); + a_seen = Bitvec.create (); + a_proof_lvl0 = ATbl.create 16; + stat_n_atoms; + c_store = + { + c_lits = Vec.create (); + c_activity = Vec_float.create (); + c_recycle_idx = Veci.create ~cap:0 (); + c_proof = Step_vec.create ~cap:0 (); + c_dead = Bitvec.create (); + c_attached = Bitvec.create (); + c_removable = Bitvec.create (); + c_marked = Bitvec.create (); + }; } - type t = { - (* variables *) - v_of_lit: var Lit_tbl.t; (* lit -> var *) - v_level: int Vec.t; (* decision/assignment level, or -1 *) - v_heap_idx: int Vec.t; (* index in priority heap *) - v_weight: Vec_float.t; (* heuristic activity *) - v_reason: reason option Vec.t; (* reason for assignment *) - v_seen: Bitvec.t; (* generic temporary marker *) - v_default_polarity: Bitvec.t; (* default polarity in decisions *) - mutable v_count: int; - (* atoms *) - a_is_true: Bitvec.t; - a_seen: Bitvec.t; - a_form: Lit.t Vec.t; - (* TODO: store watches in clauses instead *) - a_watched: Clause0.CVec.t Vec.t; - a_proof_lvl0: Proof_step.id ATbl.t; - (* atom -> proof for it to be true at level 0 *) - stat_n_atoms: int Stat.counter; - (* clauses *) - c_store: cstore; - } + (** iterate on variables *) + let iter_vars self f = + Vec.iteri self.v_level ~f:(fun i _ -> f (Var0.of_int_unsafe i)) - type store = t + module Var = struct + include Var0 - let create ?(size = `Big) ~stat () : t = - let size_map = - match size with - | `Tiny -> 8 - | `Small -> 16 - | `Big -> 4096 - in - let stat_n_atoms = Stat.mk_int stat "sat.n-atoms" in - { - v_of_lit = Lit_tbl.create size_map; - v_level = Vec.create (); - v_heap_idx = Vec.create (); - v_weight = Vec_float.create (); - v_reason = Vec.create (); - v_seen = Bitvec.create (); - v_default_polarity = Bitvec.create (); - v_count = 0; - a_is_true = Bitvec.create (); - a_form = Vec.create (); - a_watched = Vec.create (); - a_seen = Bitvec.create (); - a_proof_lvl0 = ATbl.create 16; - stat_n_atoms; - c_store = - { - c_lits = Vec.create (); - c_activity = Vec_float.create (); - c_recycle_idx = Veci.create ~cap:0 (); - c_proof = Step_vec.create ~cap:0 (); - c_dead = Bitvec.create (); - c_attached = Bitvec.create (); - c_removable = Bitvec.create (); - c_marked = Bitvec.create (); - }; - } + let[@inline] level self v = Vec.get self.v_level (v : var :> int) + let[@inline] set_level self v l = Vec.set self.v_level (v : var :> int) l + let[@inline] reason self v = Vec.get self.v_reason (v : var :> int) + let[@inline] set_reason self v r = Vec.set self.v_reason (v : var :> int) r + let[@inline] weight self v = Vec_float.get self.v_weight (v : var :> int) - (** Number of variables *) - let[@inline] n_vars self : int = Vec.size self.v_level + let[@inline] set_weight self v w = + Vec_float.set self.v_weight (v : var :> int) w - (** iterate on variables *) - let iter_vars self f = - Vec.iteri self.v_level ~f:(fun i _ -> f (Var0.of_int_unsafe i)) + let[@inline] mark self v = Bitvec.set self.v_seen (v : var :> int) true + let[@inline] unmark self v = Bitvec.set self.v_seen (v : var :> int) false + let[@inline] marked self v = Bitvec.get self.v_seen (v : var :> int) - module Var = struct - include Var0 + let[@inline] set_default_pol self v b = + Bitvec.set self.v_default_polarity (v : var :> int) b - let[@inline] level self v = Vec.get self.v_level (v : var :> int) - let[@inline] set_level self v l = Vec.set self.v_level (v : var :> int) l - let[@inline] reason self v = Vec.get self.v_reason (v : var :> int) + let[@inline] default_pol self v = + Bitvec.get self.v_default_polarity (v : var :> int) - let[@inline] set_reason self v r = - Vec.set self.v_reason (v : var :> int) r + let[@inline] heap_idx self v = Vec.get self.v_heap_idx (v : var :> int) - let[@inline] weight self v = Vec_float.get self.v_weight (v : var :> int) + let[@inline] set_heap_idx self v i = + Vec.set self.v_heap_idx (v : var :> int) i + end - let[@inline] set_weight self v w = - Vec_float.set self.v_weight (v : var :> int) w + module Atom = struct + include Atom0 - let[@inline] mark self v = Bitvec.set self.v_seen (v : var :> int) true - let[@inline] unmark self v = Bitvec.set self.v_seen (v : var :> int) false - let[@inline] marked self v = Bitvec.get self.v_seen (v : var :> int) + let[@inline] lit self a = Vec.get self.a_form (a : atom :> int) + let lit = lit + let[@inline] mark self a = Bitvec.set self.a_seen (a : atom :> int) true + let[@inline] unmark self a = Bitvec.set self.a_seen (a : atom :> int) false + let[@inline] marked self a = Bitvec.get self.a_seen (a : atom :> int) + let[@inline] watched self a = Vec.get self.a_watched (a : atom :> int) + let[@inline] is_true self a = Bitvec.get self.a_is_true (a : atom :> int) - let[@inline] set_default_pol self v b = - Bitvec.set self.v_default_polarity (v : var :> int) b + let[@inline] set_is_true self a b = + Bitvec.set self.a_is_true (a : atom :> int) b - let[@inline] default_pol self v = - Bitvec.get self.v_default_polarity (v : var :> int) + let[@inline] is_false self a = is_true self (neg a) + let[@inline] has_value self a = is_true self a || is_false self a + let[@inline] reason self a = Var.reason self (var a) + let[@inline] level self a = Var.level self (var a) + let[@inline] marked_both self a = marked self a && marked self (neg a) + let proof_lvl0 self a = ATbl.get self.a_proof_lvl0 a + let set_proof_lvl0 self a p = ATbl.replace self.a_proof_lvl0 a p + let pp self fmt a = Lit.pp fmt (lit self a) - let[@inline] heap_idx self v = Vec.get self.v_heap_idx (v : var :> int) + let pp_a self fmt v = + if Array.length v = 0 then + Format.fprintf fmt "@<1>∅" + else ( + pp self fmt v.(0); + if Array.length v > 1 then + for i = 1 to Array.length v - 1 do + Format.fprintf fmt " @<1>∨ %a" (pp self) v.(i) + done + ) - let[@inline] set_heap_idx self v i = - Vec.set self.v_heap_idx (v : var :> int) i - end + (* Complete debug printing *) - module Atom = struct - include Atom0 + let[@inline] pp_sign a = + if sign a then + "+" + else + "-" - let[@inline] lit self a = Vec.get self.a_form (a : atom :> int) - let lit = lit - let[@inline] mark self a = Bitvec.set self.a_seen (a : atom :> int) true + (* print level+reason of assignment *) + let debug_reason _self out = function + | n, _ when n < 0 -> Format.fprintf out "%%" + | n, None -> Format.fprintf out "%d" n + | n, Some Decision -> Format.fprintf out "@@%d" n + | n, Some (Bcp c) -> Format.fprintf out "->%d/%d" n (c :> int) + | n, Some (Bcp_lazy _) -> Format.fprintf out "->%d/" n - let[@inline] unmark self a = - Bitvec.set self.a_seen (a : atom :> int) false + let pp_level self out a = + let v = var a in + debug_reason self out (Var.level self v, Var.reason self v) - let[@inline] marked self a = Bitvec.get self.a_seen (a : atom :> int) - let[@inline] watched self a = Vec.get self.a_watched (a : atom :> int) - let[@inline] is_true self a = Bitvec.get self.a_is_true (a : atom :> int) - - let[@inline] set_is_true self a b = - Bitvec.set self.a_is_true (a : atom :> int) b - - let[@inline] is_false self a = is_true self (neg a) - let[@inline] has_value self a = is_true self a || is_false self a - let[@inline] reason self a = Var.reason self (var a) - let[@inline] level self a = Var.level self (var a) - let[@inline] marked_both self a = marked self a && marked self (neg a) - let proof_lvl0 self a = ATbl.get self.a_proof_lvl0 a - let set_proof_lvl0 self a p = ATbl.replace self.a_proof_lvl0 a p - let pp self fmt a = Lit.pp fmt (lit self a) - - let pp_a self fmt v = - if Array.length v = 0 then - Format.fprintf fmt "@<1>∅" - else ( - pp self fmt v.(0); - if Array.length v > 1 then - for i = 1 to Array.length v - 1 do - Format.fprintf fmt " @<1>∨ %a" (pp self) v.(i) - done - ) - - (* Complete debug printing *) - - let[@inline] pp_sign a = - if sign a then - "+" - else - "-" - - (* print level+reason of assignment *) - let debug_reason _self out = function - | n, _ when n < 0 -> Format.fprintf out "%%" - | n, None -> Format.fprintf out "%d" n - | n, Some Decision -> Format.fprintf out "@@%d" n - | n, Some (Bcp c) -> Format.fprintf out "->%d/%d" n (c :> int) - | n, Some (Bcp_lazy _) -> Format.fprintf out "->%d/" n - - let pp_level self out a = - let v = var a in - debug_reason self out (Var.level self v, Var.reason self v) - - let debug_value self out (a : atom) = - if is_true self a then - Format.fprintf out "T%a" (pp_level self) a - else if is_false self a then - Format.fprintf out "F%a" (pp_level self) a - else - () - - let debug self out a = - Format.fprintf out "%s%d[%a][atom:@[%a@]]" (pp_sign a) - (var a : var :> int) - (debug_value self) a Lit.pp (lit self a) - - let debug_a self out vec = - Array.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) vec - - let debug_l self out l = - List.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) l - end - - module Clause : sig - include module type of Clause0 with type t = Clause0.t - - (** Make a clause with the given atoms *) - - val make_a : store -> removable:bool -> atom array -> Proof_step.id -> t - val make_l : store -> removable:bool -> atom list -> Proof_step.id -> t - val make_vec : store -> removable:bool -> atom Vec.t -> Proof_step.id -> t - val n_atoms : store -> t -> int - val marked : store -> t -> bool - val set_marked : store -> t -> bool -> unit - val attached : store -> t -> bool - val set_attached : store -> t -> bool -> unit - val removable : store -> t -> bool - val set_removable : store -> t -> bool -> unit - val dead : store -> t -> bool - val set_dead : store -> t -> bool -> unit - - val dealloc : store -> t -> unit - (** Delete the clause *) - - val set_proof_step : store -> t -> Proof_step.id -> unit - val proof_step : store -> t -> Proof_step.id - val activity : store -> t -> float - val set_activity : store -> t -> float -> unit - val iter : store -> f:(atom -> unit) -> t -> unit - val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a - val for_all : store -> f:(atom -> bool) -> t -> bool - val exists : store -> f:(atom -> bool) -> t -> bool - val atoms_a : store -> t -> atom array - val lits_l : store -> t -> Lit.t list - val lits_a : store -> t -> Lit.t array - val lits_iter : store -> t -> Lit.t Iter.t - val short_name : store -> t -> string - val pp : store -> Format.formatter -> t -> unit - val debug : store -> Format.formatter -> t -> unit - end = struct - include Clause0 - - (* TODO: store watch lists inside clauses *) - - let make_a (store : store) ~removable (atoms : atom array) proof_step : t - = - let { - c_recycle_idx; - c_lits; - c_activity; - c_attached; - c_dead; - c_removable; - c_marked; - c_proof; - } = - store.c_store - in - (* allocate new ID *) - let cid = - if Veci.is_empty c_recycle_idx then - Vec.size c_lits - else - Veci.pop c_recycle_idx - in - - (* allocate space *) - (let new_len = cid + 1 in - Vec.ensure_size c_lits ~elt:[||] new_len; - Vec_float.ensure_size c_activity new_len; - Step_vec.ensure_size c_proof new_len; - Bitvec.ensure_size c_attached new_len; - Bitvec.ensure_size c_dead new_len; - Bitvec.ensure_size c_removable new_len; - Bitvec.ensure_size c_marked new_len; - - Bitvec.set c_removable cid removable); - - Vec.set c_lits cid atoms; - Step_vec.set c_proof cid proof_step; - - let c = of_int_unsafe cid in - c - - let make_l store ~removable atoms proof_rule : t = - make_a store ~removable (Array.of_list atoms) proof_rule - - let make_vec store ~removable atoms proof_rule : t = - make_a store ~removable (Vec.to_array atoms) proof_rule - - let[@inline] n_atoms (store : store) (c : t) : int = - Array.length (Vec.get store.c_store.c_lits (c : t :> int)) - - let[@inline] iter (store : store) ~f c = - let { c_lits; _ } = store.c_store in - Array.iter f (Vec.get c_lits (c : t :> int)) - - exception Early_exit - - let for_all store ~f c = - try - iter store c ~f:(fun x -> if not (f x) then raise_notrace Early_exit); - true - with Early_exit -> false - - let exists store ~f c = - try - iter store c ~f:(fun x -> if f x then raise_notrace Early_exit); - false - with Early_exit -> true - - let fold (store : store) ~f acc c = - let { c_lits; _ } = store.c_store in - Array.fold_left f acc (Vec.get c_lits (c : t :> int)) - - let[@inline] marked store c = - Bitvec.get store.c_store.c_marked (c : t :> int) - - let[@inline] set_marked store c b = - Bitvec.set store.c_store.c_marked (c : t :> int) b - - let[@inline] attached store c = - Bitvec.get store.c_store.c_attached (c : t :> int) - - let[@inline] set_attached store c b = - Bitvec.set store.c_store.c_attached (c : t :> int) b - - let[@inline] dead store c = Bitvec.get store.c_store.c_dead (c : t :> int) - - let[@inline] set_dead store c b = - Bitvec.set store.c_store.c_dead (c : t :> int) b - - let[@inline] removable store c = - Bitvec.get store.c_store.c_removable (c : t :> int) - - let[@inline] set_removable store c b = - Bitvec.set store.c_store.c_removable (c : t :> int) b - - let[@inline] set_proof_step store c p = - Step_vec.set store.c_store.c_proof (c : t :> int) p - - let[@inline] proof_step store c = - Step_vec.get store.c_store.c_proof (c : t :> int) - - let dealloc store c : unit = - assert (dead store c); - let { - c_lits; - c_recycle_idx; - c_activity; - c_proof = _; - c_dead; - c_removable; - c_attached; - c_marked; - } = - store.c_store - in - - (* clear data *) - let cid = (c : t :> int) in - Bitvec.set c_attached cid false; - Bitvec.set c_dead cid false; - Bitvec.set c_removable cid false; - Bitvec.set c_marked cid false; - Vec.set c_lits cid [||]; - Vec_float.set c_activity cid 0.; - - Veci.push c_recycle_idx cid; - (* recycle idx *) + let debug_value self out (a : atom) = + if is_true self a then + Format.fprintf out "T%a" (pp_level self) a + else if is_false self a then + Format.fprintf out "F%a" (pp_level self) a + else () - let copy_flags store c1 c2 : unit = - set_removable store c2 (removable store c1); - () + let debug self out a = + Format.fprintf out "%s%d[%a][atom:@[%a@]]" (pp_sign a) + (var a : var :> int) + (debug_value self) a Lit.pp (lit self a) - let[@inline] activity store c = - Vec_float.get store.c_store.c_activity (c : t :> int) + let debug_a self out vec = + Array.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) vec + end - let[@inline] set_activity store c f = - Vec_float.set store.c_store.c_activity (c : t :> int) f + module Clause : sig + include module type of Clause0 with type t = Clause0.t - let[@inline] make_removable store l proof_rule : t = - make_l store ~removable:true l proof_rule + (** Make a clause with the given atoms *) - let[@inline] make_removable_a store a proof_rule = - make_a store ~removable:true a proof_rule + val make_a : store -> removable:bool -> atom array -> Proof_step.id -> t + val make_l : store -> removable:bool -> atom list -> Proof_step.id -> t + val n_atoms : store -> t -> int + val marked : store -> t -> bool + val set_marked : store -> t -> bool -> unit + val attached : store -> t -> bool + val set_attached : store -> t -> bool -> unit + val removable : store -> t -> bool + val dead : store -> t -> bool + val set_dead : store -> t -> bool -> unit - let[@inline] make_permanent store l proof_rule : t = - let c = make_l store ~removable:false l proof_rule in - assert (not (removable store c)); - (* permanent by default *) - c + val dealloc : store -> t -> unit + (** Delete the clause *) - let[@inline] atoms_a store c : atom array = - Vec.get store.c_store.c_lits (c : t :> int) + val proof_step : store -> t -> Proof_step.id + val activity : store -> t -> float + val set_activity : store -> t -> float -> unit + val iter : store -> f:(atom -> unit) -> t -> unit + val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a + val for_all : store -> f:(atom -> bool) -> t -> bool + val atoms_a : store -> t -> atom array + val lits_l : store -> t -> Lit.t list + val lits_a : store -> t -> Lit.t array + val lits_iter : store -> t -> Lit.t Iter.t + val short_name : store -> t -> string + val pp : store -> Format.formatter -> t -> unit + val debug : store -> Format.formatter -> t -> unit + end = struct + include Clause0 - let lits_l store c : Lit.t list = - let arr = atoms_a store c in - Util.array_to_list_map (Atom.lit store) arr + (* TODO: store watch lists inside clauses *) - let lits_a store c : Lit.t array = - let arr = atoms_a store c in - Array.map (Atom.lit store) arr - - let lits_iter store c : Lit.t Iter.t = - let arr = atoms_a store c in - Iter.of_array arr |> Iter.map (Atom.lit store) - - let short_name _store c = Printf.sprintf "cl[%d]" (c : t :> int) - - let pp store fmt c = - Format.fprintf fmt "(cl[%d] : %a" - (c : t :> int) - (Atom.pp_a store) (atoms_a store c) - - let debug store out c = - let atoms = atoms_a store c in - Format.fprintf out "(@[cl[%d]@ {@[%a@]}@])" - (c : t :> int) - (Atom.debug_a store) atoms - end - - (* allocate new variable *) - let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var - = + let make_a (store : store) ~removable (atoms : atom array) proof_step : t = let { - v_count; - v_of_lit; - v_level; - v_heap_idx; - v_weight; - v_reason; - v_seen; - v_default_polarity; - stat_n_atoms; - a_is_true; - a_seen; - a_watched; - a_form; - c_store = _; - a_proof_lvl0 = _; + c_recycle_idx; + c_lits; + c_activity; + c_attached; + c_dead; + c_removable; + c_marked; + c_proof; } = - self + store.c_store + in + (* allocate new ID *) + let cid = + if Veci.is_empty c_recycle_idx then + Vec.size c_lits + else + Veci.pop c_recycle_idx in - let v_idx = v_count in - let v = Var.of_int_unsafe v_idx in + (* allocate space *) + (let new_len = cid + 1 in + Vec.ensure_size c_lits ~elt:[||] new_len; + Vec_float.ensure_size c_activity new_len; + Step_vec.ensure_size c_proof new_len; + Bitvec.ensure_size c_attached new_len; + Bitvec.ensure_size c_dead new_len; + Bitvec.ensure_size c_removable new_len; + Bitvec.ensure_size c_marked new_len; - Stat.incr stat_n_atoms; + Bitvec.set c_removable cid removable); - self.v_count <- 1 + v_idx; - Lit_tbl.add v_of_lit form v; - Vec.push v_level (-1); - Vec.push v_heap_idx (-1); - Vec.push v_reason None; - Vec_float.push v_weight 0.; - Bitvec.ensure_size v_seen v_idx; - Bitvec.ensure_size v_default_polarity v_idx; - Bitvec.set v_default_polarity v_idx pol; + Vec.set c_lits cid atoms; + Step_vec.set c_proof cid proof_step; - assert (Vec.size a_form = 2 * (v : var :> int)); - Bitvec.ensure_size a_is_true (2 * (v : var :> int)); - Bitvec.ensure_size a_seen (2 * (v : var :> int)); - Vec.push a_form form; - Vec.push a_watched (CVec.create ~cap:0 ()); - Vec.push a_form (Lit.neg form); - Vec.push a_watched (CVec.create ~cap:0 ()); - assert (Vec.get a_form (Atom.of_var v : atom :> int) == form); + let c = of_int_unsafe cid in + c - v + let make_l store ~removable atoms proof_rule : t = + make_a store ~removable (Array.of_list atoms) proof_rule - (* create new variable *) - let alloc_var (self : t) ?default_pol (lit : Lit.t) : - var * Solver_intf.same_sign = - let lit, same_sign = Lit.norm_sign lit in - try Lit_tbl.find self.v_of_lit lit, same_sign - with Not_found -> - let v = alloc_var_uncached_ ?default_pol self lit in - v, same_sign + let[@inline] n_atoms (store : store) (c : t) : int = + Array.length (Vec.get store.c_store.c_lits (c : t :> int)) - let clear_var (self : t) (v : var) : unit = - Var.unmark self v; - Atom.unmark self (Atom.pa v); - Atom.unmark self (Atom.na v); + let[@inline] iter (store : store) ~f c = + let { c_lits; _ } = store.c_store in + Array.iter f (Vec.get c_lits (c : t :> int)) + + exception Early_exit + + let for_all store ~f c = + try + iter store c ~f:(fun x -> if not (f x) then raise_notrace Early_exit); + true + with Early_exit -> false + + let fold (store : store) ~f acc c = + let { c_lits; _ } = store.c_store in + Array.fold_left f acc (Vec.get c_lits (c : t :> int)) + + let[@inline] marked store c = + Bitvec.get store.c_store.c_marked (c : t :> int) + + let[@inline] set_marked store c b = + Bitvec.set store.c_store.c_marked (c : t :> int) b + + let[@inline] attached store c = + Bitvec.get store.c_store.c_attached (c : t :> int) + + let[@inline] set_attached store c b = + Bitvec.set store.c_store.c_attached (c : t :> int) b + + let[@inline] dead store c = Bitvec.get store.c_store.c_dead (c : t :> int) + + let[@inline] set_dead store c b = + Bitvec.set store.c_store.c_dead (c : t :> int) b + + let[@inline] removable store c = + Bitvec.get store.c_store.c_removable (c : t :> int) + + let[@inline] proof_step store c = + Step_vec.get store.c_store.c_proof (c : t :> int) + + let dealloc store c : unit = + assert (dead store c); + let { + c_lits; + c_recycle_idx; + c_activity; + c_proof = _; + c_dead; + c_removable; + c_attached; + c_marked; + } = + store.c_store + in + + (* clear data *) + let cid = (c : t :> int) in + Bitvec.set c_attached cid false; + Bitvec.set c_dead cid false; + Bitvec.set c_removable cid false; + Bitvec.set c_marked cid false; + Vec.set c_lits cid [||]; + Vec_float.set c_activity cid 0.; + + Veci.push c_recycle_idx cid; + (* recycle idx *) () - let atom_of_var_ v same_sign : atom = - if same_sign then - Atom.pa v - else - Atom.na v + let[@inline] activity store c = + Vec_float.get store.c_store.c_activity (c : t :> int) - let alloc_atom (self : t) ?default_pol lit : atom = - let var, same_sign = alloc_var self ?default_pol lit in - atom_of_var_ var same_sign + let[@inline] set_activity store c f = + Vec_float.set store.c_store.c_activity (c : t :> int) f - let find_atom (self : t) lit : atom option = - let lit, same_sign = Lit.norm_sign lit in - match Lit_tbl.find self.v_of_lit lit with - | v -> Some (atom_of_var_ v same_sign) - | exception Not_found -> None + let[@inline] atoms_a store c : atom array = + Vec.get store.c_store.c_lits (c : t :> int) + + let lits_l store c : Lit.t list = + let arr = atoms_a store c in + Util.array_to_list_map (Atom.lit store) arr + + let lits_a store c : Lit.t array = + let arr = atoms_a store c in + Array.map (Atom.lit store) arr + + let lits_iter store c : Lit.t Iter.t = + let arr = atoms_a store c in + Iter.of_array arr |> Iter.map (Atom.lit store) + + let short_name _store c = Printf.sprintf "cl[%d]" (c : t :> int) + + let pp store fmt c = + Format.fprintf fmt "(cl[%d] : %a" + (c : t :> int) + (Atom.pp_a store) (atoms_a store c) + + let debug store out c = + let atoms = atoms_a store c in + Format.fprintf out "(@[cl[%d]@ {@[%a@]}@])" + (c : t :> int) + (Atom.debug_a store) atoms end + (* allocate new variable *) + let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var = + let { + v_count; + v_of_lit; + v_level; + v_heap_idx; + v_weight; + v_reason; + v_seen; + v_default_polarity; + stat_n_atoms; + a_is_true; + a_seen; + a_watched; + a_form; + c_store = _; + a_proof_lvl0 = _; + } = + self + in + + let v_idx = v_count in + let v = Var.of_int_unsafe v_idx in + + Stat.incr stat_n_atoms; + + self.v_count <- 1 + v_idx; + Lit_tbl.add v_of_lit form v; + Vec.push v_level (-1); + Vec.push v_heap_idx (-1); + Vec.push v_reason None; + Vec_float.push v_weight 0.; + Bitvec.ensure_size v_seen v_idx; + Bitvec.ensure_size v_default_polarity v_idx; + Bitvec.set v_default_polarity v_idx pol; + + assert (Vec.size a_form = 2 * (v : var :> int)); + Bitvec.ensure_size a_is_true (2 * (v : var :> int)); + Bitvec.ensure_size a_seen (2 * (v : var :> int)); + Vec.push a_form form; + Vec.push a_watched (CVec.create ~cap:0 ()); + Vec.push a_form (Lit.neg form); + Vec.push a_watched (CVec.create ~cap:0 ()); + assert (Vec.get a_form (Atom.of_var v : atom :> int) == form); + + v + + (* create new variable *) + let alloc_var (self : t) ?default_pol (lit : Lit.t) : + var * Solver_intf.same_sign = + let lit, same_sign = Lit.norm_sign lit in + try Lit_tbl.find self.v_of_lit lit, same_sign + with Not_found -> + let v = alloc_var_uncached_ ?default_pol self lit in + v, same_sign + + let clear_var (self : t) (v : var) : unit = + Var.unmark self v; + Atom.unmark self (Atom.pa v); + Atom.unmark self (Atom.na v); + () + + let atom_of_var_ v same_sign : atom = + if same_sign then + Atom.pa v + else + Atom.na v + + let alloc_atom (self : t) ?default_pol lit : atom = + let var, same_sign = alloc_var self ?default_pol lit in + atom_of_var_ var same_sign + + let find_atom (self : t) lit : atom option = + let lit, same_sign = Lit.norm_sign lit in + match Lit_tbl.find self.v_of_lit lit with + | v -> Some (atom_of_var_ v same_sign) + | exception Not_found -> None +end + +module Make (Plugin : PLUGIN) = struct + type theory = Plugin.t + type clause = Clause0.t type store = Store.t module Atom = Store.Atom @@ -665,8 +604,6 @@ module Make (Plugin : PLUGIN) = struct let descr = P.descr let add c = Vec.push clauses_ c let iter ~f = Vec.iter ~f clauses_ - let push_level () = () - let pop_levels _ = () let size () = Vec.size clauses_ let needs_gc () = size () > !P.max_size @@ -699,7 +636,6 @@ module Make (Plugin : PLUGIN) = struct end) ()) - let[@inline] cp_descr_ (module P : CLAUSE_POOL) : string = P.descr () let[@inline] cp_size_ (module P : CLAUSE_POOL) : int = P.size () let[@inline] cp_needs_gc_ (module P : CLAUSE_POOL) : bool = P.needs_gc () let[@inline] cp_add_ (module P : CLAUSE_POOL) c : unit = P.add c @@ -718,10 +654,8 @@ module Make (Plugin : PLUGIN) = struct val create : unit -> t val is_empty : t -> bool - val clear : t -> unit val clear_on_backtrack : t -> unit val add_clause_learnt : t -> clause -> unit - val add_clause_pool : t -> clause -> clause_pool -> unit val propagate_atom : t -> atom -> lvl:int -> clause lazy_t -> unit val add_decision : t -> atom -> unit @@ -794,9 +728,6 @@ module Make (Plugin : PLUGIN) = struct && CVec.is_empty clauses_to_add_learnt && Vec.is_empty decisions && Vec.is_empty propagate - let add_clause_pool (self : t) c pool = - Vec.push self.clauses_to_add_in_pool (c, pool) - let add_clause_learnt (self : t) c = CVec.push self.clauses_to_add_learnt c let propagate_atom self p ~lvl c = @@ -1027,13 +958,6 @@ module Make (Plugin : PLUGIN) = struct *) exception Trivial - (* [arr_to_list a i] converts [a.(i), ... a.(length a-1)] into a list *) - let arr_to_list arr i : _ list = - if i >= Array.length arr then - [] - else - Array.to_list (Array.sub arr i (Array.length arr - i)) - (* get/build the proof for [a], which must be an atom true at level 0. This uses a global cache to avoid repeated computations, as many clauses might resolve against a given 0-level atom. *) @@ -1259,35 +1183,6 @@ module Make (Plugin : PLUGIN) = struct Format.fprintf out "(@[unsat-cause@ :false %a@])" (Clause.debug self.store) c - let prove_unsat self (us : clause) : clause = - if Proof_trace.enabled self.proof && Clause.n_atoms self.store us > 0 then ( - (* reduce [c] to an empty clause, all its literals should be false at level 0 *) - Log.debugf 1 (fun k -> - k "(@[sat.prove-unsat@ :from %a@])" (Clause.debug self.store) us); - - (* accumulate proofs of all level-0 lits *) - let pvec = self.temp_step_vec in - assert (Step_vec.is_empty pvec); - Clause.iter self.store us ~f:(fun a -> - assert (Atom.is_false self.store a && Atom.level self.store a = 0); - match Atom.reason self.store a with - | Some (Bcp c | Bcp_lazy (lazy c)) -> - let p = Clause.proof_step self.store c in - Step_vec.push pvec p - | _ -> assert false); - - let p_empty = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause Iter.empty - ~hyps:(Step_vec.to_iter pvec) - in - Step_vec.clear pvec; - let c_empty = Clause.make_l self.store [] ~removable:false p_empty in - - c_empty - ) else - us - (* Unsatisfiability is signaled through an exception, since it can happen in multiple places (adding new clauses, or solving for instance). *) let report_unsat self (us : unsat_cause) : _ = @@ -1836,8 +1731,6 @@ module Make (Plugin : PLUGIN) = struct exception Th_conflict of Clause.t - let[@inline] slice_get st i = AVec.get st.trail i - let acts_add_clause self ?(keep = false) (l : Lit.t list) (p : Proof_step.id) : unit = let atoms = List.rev_map (make_atom_ self) l in @@ -1848,18 +1741,6 @@ module Make (Plugin : PLUGIN) = struct (* will be added later, even if we backtrack *) Delayed_actions.add_clause_learnt self.delayed_actions c - let acts_add_clause_in_pool self ~pool (l : Lit.t list) (p : Proof_step.id) : - unit = - let atoms = List.rev_map (make_atom_ self) l in - let removable = true in - let c = Clause.make_l self.store ~removable atoms p in - let pool = Vec.get self.clause_pools (pool : Clause_pool_id.t :> int) in - Log.debugf 5 (fun k -> - k "(@[sat.th.add-clause-in-pool@ %a@ :pool %s@])" - (Clause.debug self.store) c (cp_descr_ pool)); - (* will be added later, even if we backtrack *) - Delayed_actions.add_clause_pool self.delayed_actions c pool - let acts_add_decision_lit (self : t) (f : Lit.t) (sign : bool) : unit = let store = self.store in let a = make_atom_ self f in @@ -2328,7 +2209,6 @@ module Make (Plugin : PLUGIN) = struct raise UndecidedLit let[@inline] eval st lit = fst @@ eval_level st lit - let[@inline] unsat_conflict st = st.unsat_at_0 (* fixpoint of propagation and decisions until a model is found, or a conflict is reached *) @@ -2439,8 +2319,6 @@ module Make (Plugin : PLUGIN) = struct pp_all self 99 "SAT"; let t = self.trail in let module M = struct - type lit = Lit.t - let iter_trail f = AVec.iter ~f:(fun a -> f (Atom.lit self.store a)) t let[@inline] eval f = eval self (make_atom_ self f) let[@inline] eval_level f = eval_level self (make_atom_ self f) @@ -2684,4 +2562,4 @@ module Pure_sat = Make (struct let final_check () _ = () let has_theory = false end) -[@@inline] [@@specialise] +[@@specialise] diff --git a/src/sat/dune b/src/sat/dune index 56fdf8e7..7a17aa9b 100644 --- a/src/sat/dune +++ b/src/sat/dune @@ -2,5 +2,6 @@ (name sidekick_sat) (public_name sidekick.sat) (synopsis "Pure OCaml SAT solver implementation for sidekick") + (private_modules heap heap_intf) (libraries iter sidekick.util sidekick.core) (flags :standard -w +32 -open Sidekick_util)) From a9ae790d7febf3d3b847fcafcd932a752b52b2a5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 23:25:48 -0400 Subject: [PATCH 044/174] refactor(cc): split into modules, fully defunctorize --- src/cc/CC.ml | 971 ++++++++++++++ src/cc/CC.mli | 285 +++++ src/cc/Sidekick_cc.ml | 28 +- src/cc/Sidekick_cc.mli | 24 +- src/cc/core_cc.ml | 1136 ----------------- src/cc/dune | 2 +- src/cc/e_node.ml | 50 + src/cc/e_node.mli | 61 + src/cc/expl.ml | 50 + src/cc/expl.mli | 47 + .../sidekick_cc_plugin.ml => plugin.ml} | 23 +- .../sidekick_cc_plugin.mli => plugin.mli} | 8 +- src/cc/resolved_expl.ml | 6 + src/cc/resolved_expl.mli | 17 + src/cc/signature.ml | 53 + src/cc/sigs.ml | 502 -------- src/cc/sigs_plugin.ml | 90 ++ src/cc/types_.ml | 39 + 18 files changed, 1708 insertions(+), 1684 deletions(-) create mode 100644 src/cc/CC.ml create mode 100644 src/cc/CC.mli delete mode 100644 src/cc/core_cc.ml create mode 100644 src/cc/e_node.ml create mode 100644 src/cc/e_node.mli create mode 100644 src/cc/expl.ml create mode 100644 src/cc/expl.mli rename src/cc/{plugin/sidekick_cc_plugin.ml => plugin.ml} (90%) rename src/cc/{plugin/sidekick_cc_plugin.mli => plugin.mli} (76%) create mode 100644 src/cc/resolved_expl.ml create mode 100644 src/cc/resolved_expl.mli create mode 100644 src/cc/signature.ml create mode 100644 src/cc/sigs_plugin.ml create mode 100644 src/cc/types_.ml diff --git a/src/cc/CC.ml b/src/cc/CC.ml new file mode 100644 index 00000000..ba2214be --- /dev/null +++ b/src/cc/CC.ml @@ -0,0 +1,971 @@ +open Types_ + +type view_as_cc = Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t + +open struct + (* proof rules *) + module Rules_ = Proof_core + module P = Proof_trace +end + +type e_node = E_node.t +(** A node of the congruence closure *) + +type repr = E_node.t +(** Node that is currently a representative. *) + +type explanation = Expl.t +type bitfield = Bits.field + +(* non-recursive, inlinable function for [find] *) +let[@inline] find_ (n : e_node) : repr = + let n2 = n.n_root in + assert (E_node.is_root n2); + n2 + +let[@inline] same_class (n1 : e_node) (n2 : e_node) : bool = + E_node.equal (find_ n1) (find_ n2) + +let[@inline] find _ n = find_ n + +module Sig_tbl = CCHashtbl.Make (Signature) +module T_tbl = Term.Tbl + +type propagation_reason = unit -> Lit.t list * Proof_term.step_id + +module Handler_action = struct + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of Lit.t * propagation_reason + + type conflict = Conflict of Expl.t [@@unboxed] + type or_conflict = (t list, conflict) result +end + +module Result_action = struct + type t = Act_propagate of { lit: Lit.t; reason: propagation_reason } + type conflict = Conflict of Lit.t list * Proof_term.step_id + type or_conflict = (t list, conflict) result +end + +type combine_task = + | CT_merge of e_node * e_node * explanation + | CT_act of Handler_action.t + +type t = { + view_as_cc: view_as_cc; + tst: Term.store; + proof: Proof_trace.t; + tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) + signatures_tbl: e_node Sig_tbl.t; + (* map a signature to the corresponding e_node in some equivalence class. + A signature is a [term_cell] in which every immediate subterm + that participates in the congruence/evaluation relation + is normalized (i.e. is its own representative). + The critical property is that all members of an equivalence class + that have the same "shape" (including head symbol) + have the same signature *) + pending: e_node Vec.t; + combine: combine_task Vec.t; + undo: (unit -> unit) Backtrack_stack.t; + bitgen: Bits.bitfield_gen; + field_marked_explain: Bits.field; + (* used to mark traversed nodes when looking for a common ancestor *) + true_: e_node lazy_t; + false_: e_node lazy_t; + mutable in_loop: bool; (* currently being modified? *) + res_acts: Result_action.t Vec.t; (* to return *) + on_pre_merge: + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; + on_pre_merge2: + ( t * E_node.t * E_node.t * Expl.t, + Handler_action.or_conflict ) + Event.Emitter.t; + on_post_merge: + (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; + on_new_term: (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; + on_conflict: (ev_on_conflict, unit) Event.Emitter.t; + on_propagate: + (t * Lit.t * propagation_reason, Handler_action.t list) Event.Emitter.t; + on_is_subterm: (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; + count_conflict: int Stat.counter; + count_props: int Stat.counter; + count_merge: int Stat.counter; +} +(* TODO: an additional union-find to keep track, for each term, + of the terms they are known to be equal to, according + to the current explanation. That allows not to prove some equality + several times. + See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) + +and ev_on_conflict = { cc: t; th: bool; c: Lit.t list } + +let[@inline] size_ (r : repr) = r.n_size +let[@inline] n_true self = Lazy.force self.true_ +let[@inline] n_false self = Lazy.force self.false_ + +let n_bool self b = + if b then + n_true self + else + n_false self + +let[@inline] term_store self = self.tst +let[@inline] proof self = self.proof + +let allocate_bitfield self ~descr : bitfield = + Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); + Bits.mk_field self.bitgen + +let[@inline] on_backtrack self f : unit = + Backtrack_stack.push_if_nonzero_level self.undo f + +let[@inline] set_bitfield_ f b t = t.n_bits <- Bits.set f b t.n_bits +let[@inline] get_bitfield_ field n = Bits.get field n.n_bits +let[@inline] get_bitfield _cc field n = get_bitfield_ field n + +let set_bitfield self field b n = + let old = get_bitfield self field n in + if old <> b then ( + on_backtrack self (fun () -> set_bitfield_ field old n); + set_bitfield_ field b n + ) + +(* check if [t] is in the congruence closure. + Invariant: [in_cc t ∧ do_cc t => forall u subterm t, in_cc u] *) +let[@inline] mem (self : t) (t : Term.t) : bool = T_tbl.mem self.tbl t + +module Debug_ = struct + (* print full state *) + let pp out (self : t) : unit = + let pp_next out n = Fmt.fprintf out "@ :next %a" E_node.pp n.n_next in + let pp_root out n = + if E_node.is_root n then + Fmt.string out " :is-root" + else + Fmt.fprintf out "@ :root %a" E_node.pp n.n_root + in + let pp_expl out n = + match n.n_expl with + | FL_none -> () + | FL_some e -> + Fmt.fprintf out " (@[:forest %a :expl %a@])" E_node.pp e.next Expl.pp + e.expl + in + let pp_n out n = + Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp_debug n.n_term pp_root n pp_next + n pp_expl n + and pp_sig_e out (s, n) = + Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s E_node.pp n pp_root + n + in + Fmt.fprintf out + "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ %a@])@])" + (Util.pp_iter ~sep:" " pp_n) + (T_tbl.values self.tbl) + (Util.pp_iter ~sep:" " pp_sig_e) + (Sig_tbl.to_iter self.signatures_tbl) +end + +(* compute up-to-date signature *) +let update_sig (s : signature) : Signature.t = + View.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) + +(* find whether the given (parent) term corresponds to some signature + in [signatures_] *) +let[@inline] find_signature cc (s : signature) : repr option = + Sig_tbl.get cc.signatures_tbl s + +(* add to signature table. Assume it's not present already *) +let add_signature self (s : signature) (n : e_node) : unit = + assert (not @@ Sig_tbl.mem self.signatures_tbl s); + Log.debugf 50 (fun k -> + k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s E_node.pp n); + on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); + Sig_tbl.add self.signatures_tbl s n + +let push_pending self t : unit = + Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); + Vec.push self.pending t + +let push_action self (a : Handler_action.t) : unit = + Vec.push self.combine (CT_act a) + +let push_action_l self (l : _ list) : unit = List.iter (push_action self) l + +let merge_classes self t u e : unit = + if t != u && not (same_class t u) then ( + Log.debugf 50 (fun k -> + k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" E_node.pp t E_node.pp + u Expl.pp e); + Vec.push self.combine @@ CT_merge (t, u, e) + ) + +(* re-root the explanation tree of the equivalence class of [n] + so that it points to [n]. + postcondition: [n.n_expl = None] *) +let[@unroll 2] rec reroot_expl (self : t) (n : e_node) : unit = + match n.n_expl with + | FL_none -> () (* already root *) + | FL_some { next = u; expl = e_n_u } -> + (* reroot to [u], then invert link between [u] and [n] *) + reroot_expl self u; + u.n_expl <- FL_some { next = n; expl = e_n_u }; + n.n_expl <- FL_none + +exception E_confl of Result_action.conflict + +let raise_conflict_ (cc : t) ~th (e : Lit.t list) (p : Proof_term.step_id) : _ = + Profile.instant "cc.conflict"; + (* clear tasks queue *) + Vec.clear cc.pending; + Vec.clear cc.combine; + Event.emit cc.on_conflict { cc; th; c = e }; + Stat.incr cc.count_conflict; + raise (E_confl (Conflict (e, p))) + +let[@inline] all_classes self : repr Iter.t = + T_tbl.values self.tbl |> Iter.filter E_node.is_root + +(* find the closest common ancestor of [a] and [b] in the proof forest. + + Precond: + - [a] and [b] are in the same class + - no e_node has the flag [field_marked_explain] on + Invariants: + - if [n] is marked, then all the predecessors of [n] + from [a] or [b] are marked too. +*) +let find_common_ancestor self (a : e_node) (b : e_node) : e_node = + (* catch up to the other e_node *) + let rec find1 a = + if get_bitfield_ self.field_marked_explain a then + a + else ( + match a.n_expl with + | FL_none -> assert false + | FL_some r -> find1 r.next + ) + in + let rec find2 a b = + if E_node.equal a b then + a + else if get_bitfield_ self.field_marked_explain a then + a + else if get_bitfield_ self.field_marked_explain b then + b + else ( + set_bitfield_ self.field_marked_explain true a; + set_bitfield_ self.field_marked_explain true b; + match a.n_expl, b.n_expl with + | FL_some r1, FL_some r2 -> find2 r1.next r2.next + | FL_some r, FL_none -> find1 r.next + | FL_none, FL_some r -> find1 r.next + | FL_none, FL_none -> assert false + (* no common ancestor *) + ) + in + + (* cleanup tags on nodes traversed in [find2] *) + let rec cleanup_ n = + if get_bitfield_ self.field_marked_explain n then ( + set_bitfield_ self.field_marked_explain false n; + match n.n_expl with + | FL_none -> () + | FL_some { next; _ } -> cleanup_ next + ) + in + let n = find2 a b in + cleanup_ a; + cleanup_ b; + n + +module Expl_state = struct + type t = { + mutable lits: Lit.t list; + mutable th_lemmas: + (Lit.t * (Lit.t * Lit.t list) list * Proof_term.step_id) list; + } + + let create () : t = { lits = []; th_lemmas = [] } + let[@inline] copy self : t = { self with lits = self.lits } + let[@inline] add_lit (self : t) lit = self.lits <- lit :: self.lits + + let[@inline] add_th (self : t) lit hyps pr : unit = + self.th_lemmas <- (lit, hyps, pr) :: self.th_lemmas + + let merge self other = + let { lits = o_lits; th_lemmas = o_lemmas } = other in + self.lits <- List.rev_append o_lits self.lits; + self.th_lemmas <- List.rev_append o_lemmas self.th_lemmas; + () + + (* proof of [\/_i ¬lits[i]] *) + let proof_of_th_lemmas (self : t) (proof : Proof_trace.t) : Proof_term.step_id + = + let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in + let p_lits2 = + Iter.of_list self.th_lemmas + |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) + in + let p_cc = + P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) + in + let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = + (* pr_th: [sub_proofs |- t=u]. + now resolve away [sub_proofs] to get literals that were + asserted in the congruence closure *) + let pr_th = + List.fold_left + (fun pr_th (lit_i, hyps_i) -> + (* [hyps_i |- lit_i] *) + let lemma_i = + P.add_step proof + @@ Rules_.lemma_cc + Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) + in + (* resolve [lit_i] away. *) + P.add_step proof + @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) + pr_th sub_proofs + in + P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr + in + (* resolve with theory proofs responsible for some merges, if any. *) + List.fold_left resolve_with_th_proof p_cc self.th_lemmas + + let to_resolved_expl (self : t) : Resolved_expl.t = + (* FIXME: package the th lemmas too *) + let { lits; th_lemmas = _ } = self in + let s2 = copy self in + let pr proof = proof_of_th_lemmas s2 proof in + { Resolved_expl.lits; pr } +end + +(* decompose explanation [e] into a list of literals added to [acc] *) +let rec explain_decompose_expl self (st : Expl_state.t) (e : explanation) : unit + = + Log.debugf 5 (fun k -> k "(@[cc.decompose_expl@ %a@])" Expl.pp e); + match e with + | E_trivial -> () + | E_congruence (n1, n2) -> + (match n1.n_sig0, n2.n_sig0 with + | Some (App_fun (f1, a1)), Some (App_fun (f2, a2)) -> + assert (Const.equal f1 f2); + assert (List.length a1 = List.length a2); + List.iter2 (explain_equal_rec_ self st) a1 a2 + | Some (App_ho (f1, a1)), Some (App_ho (f2, a2)) -> + explain_equal_rec_ self st f1 f2; + explain_equal_rec_ self st a1 a2 + | Some (If (a1, b1, c1)), Some (If (a2, b2, c2)) -> + explain_equal_rec_ self st a1 a2; + explain_equal_rec_ self st b1 b2; + explain_equal_rec_ self st c1 c2 + | _ -> assert false) + | E_lit lit -> Expl_state.add_lit st lit + | E_theory (t, u, expl_sets, pr) -> + let sub_proofs = + List.map + (fun (t_i, u_i, expls_i) -> + let lit_i = Lit.make_eq self.tst t_i u_i in + (* use a separate call to [explain_expls] for each set *) + let sub = explain_expls self expls_i in + Expl_state.merge st sub; + lit_i, sub.lits) + expl_sets + in + let lit_t_u = Lit.make_eq self.tst t u in + Expl_state.add_th st lit_t_u sub_proofs pr + | E_merge (a, b) -> explain_equal_rec_ self st a b + | E_merge_t (a, b) -> + (* find nodes for [a] and [b] on the fly *) + (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with + | a, b -> explain_equal_rec_ self st a b + | exception Not_found -> + Error.errorf "expl: cannot find e_node(s) for %a, %a" Term.pp_debug a + Term.pp_debug b) + | E_and (a, b) -> + explain_decompose_expl self st a; + explain_decompose_expl self st b + +and explain_expls self (es : explanation list) : Expl_state.t = + let st = Expl_state.create () in + List.iter (explain_decompose_expl self st) es; + st + +and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) : + unit = + Log.debugf 5 (fun k -> + k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); + assert (E_node.equal (find_ a) (find_ b)); + let ancestor = find_common_ancestor cc a b in + explain_along_path cc st a ancestor; + explain_along_path cc st b ancestor + +(* explain why [a = parent_a], where [a -> ... -> target] in the + proof forest *) +and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) : + unit = + let rec aux n = + if n == target then + () + else ( + match n.n_expl with + | FL_none -> assert false + | FL_some { next = next_n; expl } -> + explain_decompose_expl self st expl; + (* now prove [next_n = target] *) + aux next_n + ) + in + aux a + +(* add a term *) +let[@inline] rec add_term_rec_ self t : e_node = + match T_tbl.find self.tbl t with + | n -> n + | exception Not_found -> add_new_term_ self t + +(* add [t] when not present already *) +and add_new_term_ self (t : Term.t) : e_node = + assert (not @@ mem self t); + Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp_debug t); + let n = E_node.Internal_.make t in + (* register sub-terms, add [t] to their parent list, and return the + corresponding initial signature *) + let sig0 = compute_sig0 self n in + n.n_sig0 <- sig0; + (* remove term when we backtrack *) + on_backtrack self (fun () -> + Log.debugf 30 (fun k -> k "(@[cc.remove-term@ %a@])" Term.pp_debug t); + T_tbl.remove self.tbl t); + (* add term to the table *) + T_tbl.add self.tbl t n; + if Option.is_some sig0 then + (* [n] might be merged with other equiv classes *) + push_pending self n; + Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); + n + +(* compute the initial signature of the given e_node *) +and compute_sig0 (self : t) (n : e_node) : Signature.t option = + (* add sub-term to [cc], and register [n] to its parents. + Note that we return the exact sub-term, to get proper + explanations, but we add to the sub-term's root's parent list. *) + let deref_sub (u : Term.t) : e_node = + let sub = add_term_rec_ self u in + (* add [n] to [sub.root]'s parent list *) + (let sub_r = find_ sub in + let old_parents = sub_r.n_parents in + if Bag.is_empty old_parents then + (* first time it has parents: tell watchers that this is a subterm *) + Event.emit_iter self.on_is_subterm (self, sub, u) ~f:(push_action_l self); + on_backtrack self (fun () -> sub_r.n_parents <- old_parents); + sub_r.n_parents <- Bag.cons n sub_r.n_parents); + sub + in + let[@inline] return x = Some x in + match self.view_as_cc n.n_term with + | Bool _ | Opaque _ -> None + | Eq (a, b) -> + let a = deref_sub a in + let b = deref_sub b in + return @@ View.Eq (a, b) + | Not u -> return @@ View.Not (deref_sub u) + | App_fun (f, args) -> + let args = args |> Iter.map deref_sub |> Iter.to_list in + if args <> [] then + return @@ View.App_fun (f, args) + else + None + | App_ho (f, a) -> + let f = deref_sub f in + let a = deref_sub a in + return @@ View.App_ho (f, a) + | If (a, b, c) -> return @@ View.If (deref_sub a, deref_sub b, deref_sub c) + +let[@inline] add_term self t : e_node = add_term_rec_ self t +let mem_term = mem + +let set_as_lit self (n : e_node) (lit : Lit.t) : unit = + match n.n_as_lit with + | Some _ -> () + | None -> + Log.debugf 15 (fun k -> + k "(@[cc.set-as-lit@ %a@ %a@])" E_node.pp n Lit.pp lit); + on_backtrack self (fun () -> n.n_as_lit <- None); + n.n_as_lit <- Some lit + +(* is [n] true or false? *) +let n_is_bool_value (self : t) n : bool = + E_node.equal n (n_true self) || E_node.equal n (n_false self) + +(* gather a pair [lits, pr], where [lits] is the set of + asserted literals needed in the explanation (which is useful for + the SAT solver), and [pr] is a proof, including sub-proofs for theory + merges. *) +let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : + Lit.t list * Proof_term.step_id = + let { Expl_state.lits; th_lemmas = _ } = st in + let pr = Expl_state.proof_of_th_lemmas st self.proof in + lits, pr + +(* main CC algo: add terms from [pending] to the signature table, + check for collisions *) +let rec update_tasks (self : t) : unit = + while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do + while not @@ Vec.is_empty self.pending do + task_pending_ self (Vec.pop_exn self.pending) + done; + while not @@ Vec.is_empty self.combine do + task_combine_ self (Vec.pop_exn self.combine) + done + done + +and task_pending_ self (n : e_node) : unit = + (* check if some parent collided *) + match n.n_sig0 with + | None -> () (* no-op *) + | Some (Eq (a, b)) -> + (* if [a=b] is now true, merge [(a=b)] and [true] *) + if same_class a b then ( + let expl = Expl.mk_merge a b in + Log.debugf 5 (fun k -> + k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a + E_node.pp b); + merge_classes self n (n_true self) expl + ) + | Some (Not u) -> + (* [u = bool ==> not u = not bool] *) + let r_u = find_ u in + if E_node.equal r_u (n_true self) then ( + let expl = Expl.mk_merge u (n_true self) in + merge_classes self n (n_false self) expl + ) else if E_node.equal r_u (n_false self) then ( + let expl = Expl.mk_merge u (n_false self) in + merge_classes self n (n_true self) expl + ) + | Some s0 -> + (* update the signature by using [find] on each sub-e_node *) + let s = update_sig s0 in + (match find_signature self s with + | None -> + (* add to the signature table [sig(n) --> n] *) + add_signature self s n + | Some u when E_node.equal n u -> () + | Some u -> + (* [t1] and [t2] must be applications of the same symbol to + arguments that are pairwise equal *) + assert (n != u); + let expl = Expl.mk_congruence n u in + merge_classes self n u expl) + +and task_combine_ self = function + | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab + | CT_act (Handler_action.Act_merge (t, u, e)) -> task_merge_ self t u e + | CT_act (Handler_action.Act_propagate (lit, reason)) -> + (* will return this propagation to the caller *) + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }) + +(* main CC algo: merge equivalence classes in [st.combine]. + @raise Exn_unsat if merge fails *) +and task_merge_ self a b e_ab : unit = + let ra = find_ a in + let rb = find_ b in + if not @@ E_node.equal ra rb then ( + assert (E_node.is_root ra); + assert (E_node.is_root rb); + Stat.incr self.count_merge; + (* check we're not merging [true] and [false] *) + if + (E_node.equal ra (n_true self) && E_node.equal rb (n_false self)) + || (E_node.equal rb (n_true self) && E_node.equal ra (n_false self)) + then ( + Log.debugf 5 (fun k -> + k + "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ + %a@ :t2 %a@]@ :e_ab %a@])" + E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); + let th = ref false in + (* TODO: + C1: P.true_neq_false + C2: lemma [lits |- true=false] (and resolve on theory proofs) + C3: r1 C1 C2 + *) + let expl_st = Expl_state.create () in + explain_decompose_expl self expl_st e_ab; + explain_equal_rec_ self expl_st a ra; + explain_equal_rec_ self expl_st b rb; + + (* regular conflict *) + let lits, pr = lits_and_proof_of_expl self expl_st in + raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr + ); + (* We will merge [r_from] into [r_into]. + we try to ensure that [size ra <= size rb] in general, but always + keep values as representative *) + let r_from, r_into = + if n_is_bool_value self ra then + rb, ra + else if n_is_bool_value self rb then + ra, rb + else if size_ ra > size_ rb then + rb, ra + else + ra, rb + in + (* when merging terms with [true] or [false], possibly propagate them to SAT *) + let merge_bool r1 t1 r2 t2 = + if E_node.equal r1 (n_true self) then + propagate_bools self r2 t2 r1 t1 e_ab true + else if E_node.equal r1 (n_false self) then + propagate_bools self r2 t2 r1 t1 e_ab false + in + + merge_bool ra a rb b; + merge_bool rb b ra a; + + (* perform [union r_from r_into] *) + Log.debugf 15 (fun k -> + k "(@[cc.merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp r_into); + + (* call [on_pre_merge] functions, and merge theory data items *) + (* explanation is [a=ra & e_ab & b=rb] *) + (let expl = Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] in + + let handle_act = function + | Ok l -> push_action_l self l + | Error (Handler_action.Conflict expl) -> + raise_conflict_from_expl self expl + in + + Event.emit_iter self.on_pre_merge + (self, r_into, r_from, expl) + ~f:handle_act; + Event.emit_iter self.on_pre_merge2 + (self, r_into, r_from, expl) + ~f:handle_act); + + (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, + so they have a chance of observing pre-merge plugin data *) + ((* parents might have a different signature, check for collisions *) + E_node.iter_parents r_from (fun parent -> push_pending self parent); + (* for each e_node in [r_from]'s class, make it point to [r_into] *) + E_node.iter_class r_from (fun u -> + assert (u.n_root == r_from); + u.n_root <- r_into); + (* capture current state *) + let r_into_old_next = r_into.n_next in + let r_from_old_next = r_from.n_next in + let r_into_old_parents = r_into.n_parents in + let r_into_old_bits = r_into.n_bits in + (* swap [into.next] and [from.next], merging the classes *) + r_into.n_next <- r_from_old_next; + r_from.n_next <- r_into_old_next; + r_into.n_parents <- Bag.append r_into.n_parents r_from.n_parents; + r_into.n_size <- r_into.n_size + r_from.n_size; + r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; + (* on backtrack, unmerge classes and restore the pointers to [r_from] *) + on_backtrack self (fun () -> + Log.debugf 30 (fun k -> + k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from + E_node.pp r_into); + r_into.n_bits <- r_into_old_bits; + r_into.n_next <- r_into_old_next; + r_from.n_next <- r_from_old_next; + r_into.n_parents <- r_into_old_parents; + (* NOTE: this must come after the restoration of [next] pointers, + otherwise we'd iterate on too big a class *) + E_node.Internal_.iter_class_ r_from (fun u -> u.n_root <- r_from); + r_into.n_size <- r_into.n_size - r_from.n_size)); + + (* update explanations (a -> b), arbitrarily. + Note that here we merge the classes by adding a bridge between [a] + and [b], not their roots. *) + reroot_expl self a; + assert (a.n_expl = FL_none); + (* on backtracking, link may be inverted, but we delete the one + that bridges between [a] and [b] *) + on_backtrack self (fun () -> + match a.n_expl, b.n_expl with + | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none + | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none + | _ -> assert false); + a.n_expl <- FL_some { next = b; expl = e_ab }; + (* call [on_post_merge] *) + Event.emit_iter self.on_post_merge (self, r_into, r_from) + ~f:(push_action_l self) + ) + +(* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] + in the equiv class of [r1] that is a known literal back to the SAT solver + and which is not the one initially merged. + We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) +and propagate_bools self r1 t1 r2 t2 (e_12 : explanation) sign : unit = + (* explanation for [t1 =e= t2 = r2] *) + let half_expl_and_pr = + lazy + (let st = Expl_state.create () in + explain_decompose_expl self st e_12; + explain_equal_rec_ self st r2 t2; + st) + in + (* TODO: flag per class, `or`-ed on merge, to indicate if the class + contains at least one lit *) + E_node.iter_class r1 (fun u1 -> + (* propagate if: + - [u1] is a proper literal + - [t2 != r2], because that can only happen + after an explicit merge (no way to obtain that by propagation) + *) + match E_node.as_lit u1 with + | Some lit when not (E_node.equal r2 t2) -> + let lit = + if sign then + lit + else + Lit.neg lit + in + (* apply sign *) + Log.debugf 5 (fun k -> k "(@[cc.bool_propagate@ %a@])" Lit.pp lit); + (* complete explanation with the [u1=t1] chunk *) + let (lazy st) = half_expl_and_pr in + let st = Expl_state.copy st in + (* do not modify shared st *) + explain_equal_rec_ self st u1 t1; + + (* propagate only if this doesn't depend on some semantic values *) + let reason () = + (* true literals explaining why t1=t2 *) + let guard = st.lits in + (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) + Expl_state.add_lit st (Lit.neg lit); + let _, pr = lits_and_proof_of_expl self st in + guard, pr + in + Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }); + Event.emit_iter self.on_propagate (self, lit, reason) + ~f:(push_action_l self); + Stat.incr self.count_props + | _ -> ()) + +(* raise a conflict from an explanation, typically from an event handler. + Raises E_confl with a result conflict. *) +and raise_conflict_from_expl self (expl : Expl.t) : 'a = + Log.debugf 5 (fun k -> + k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); + let st = Expl_state.create () in + explain_decompose_expl self st expl; + let lits, pr = lits_and_proof_of_expl self st in + let c = List.rev_map Lit.neg lits in + let th = st.th_lemmas <> [] in + raise_conflict_ self ~th c pr + +let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) + +let push_level (self : t) : unit = + assert (not self.in_loop); + Backtrack_stack.push_level self.undo + +let pop_levels (self : t) n : unit = + assert (not self.in_loop); + Vec.clear self.pending; + Vec.clear self.combine; + Log.debugf 15 (fun k -> + k "(@[cc.pop-levels %d@ :n-lvls %d@])" n + (Backtrack_stack.n_levels self.undo)); + Backtrack_stack.pop_levels self.undo n ~f:(fun f -> f ()); + () + +let assert_eq self t u expl : unit = + assert (not self.in_loop); + let t = add_term self t in + let u = add_term self u in + (* merge [a] and [b] *) + merge_classes self t u expl + +(* assert that this boolean literal holds. + if a lit is [= a b], merge [a] and [b]; + otherwise merge the atom with true/false *) +let assert_lit self lit : unit = + assert (not self.in_loop); + let t = Lit.term lit in + Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); + let sign = Lit.sign lit in + match self.view_as_cc t with + | Eq (a, b) when sign -> assert_eq self a b (Expl.mk_lit lit) + | _ -> + (* equate t and true/false *) + let rhs = n_bool self sign in + let n = add_term self t in + (* TODO: ensure that this is O(1). + basically, just have [n] point to true/false and thus acquire + the corresponding value, so its superterms (like [ite]) can evaluate + properly *) + (* TODO: use oriented merge (force direction [n -> rhs]) *) + merge_classes self n rhs (Expl.mk_lit lit) + +let[@inline] assert_lits self lits : unit = + assert (not self.in_loop); + Iter.iter (assert_lit self) lits + +let merge self n1 n2 expl = + assert (not self.in_loop); + Log.debugf 5 (fun k -> + k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" E_node.pp n1 E_node.pp + n2 Expl.pp expl); + assert (Term.equal (Term.ty n1.n_term) (Term.ty n2.n_term)); + merge_classes self n1 n2 expl + +let merge_t self t1 t2 expl = + merge self (add_term self t1) (add_term self t2) expl + +let explain_eq self n1 n2 : Resolved_expl.t = + let st = Expl_state.create () in + explain_equal_rec_ self st n1 n2; + (* FIXME: also need to return the proof? *) + Expl_state.to_resolved_expl st + +let explain_expl (self : t) expl : Resolved_expl.t = + let expl_st = Expl_state.create () in + explain_decompose_expl self expl_st expl; + Expl_state.to_resolved_expl expl_st + +let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge +let[@inline] on_pre_merge2 self = Event.of_emitter self.on_pre_merge2 +let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge +let[@inline] on_new_term self = Event.of_emitter self.on_new_term +let[@inline] on_conflict self = Event.of_emitter self.on_conflict +let[@inline] on_propagate self = Event.of_emitter self.on_propagate +let[@inline] on_is_subterm self = Event.of_emitter self.on_is_subterm + +let create_ ?(stat = Stat.global) ?(size = `Big) (tst : Term.store) + (proof : Proof_trace.t) ~view_as_cc : t = + let size = + match size with + | `Small -> 128 + | `Big -> 2048 + in + let bitgen = Bits.mk_gen () in + let field_marked_explain = Bits.mk_field bitgen in + let rec cc = + { + view_as_cc; + tst; + proof; + tbl = T_tbl.create size; + signatures_tbl = Sig_tbl.create size; + bitgen; + on_pre_merge = Event.Emitter.create (); + on_pre_merge2 = Event.Emitter.create (); + on_post_merge = Event.Emitter.create (); + on_new_term = Event.Emitter.create (); + on_conflict = Event.Emitter.create (); + on_propagate = Event.Emitter.create (); + on_is_subterm = Event.Emitter.create (); + pending = Vec.create (); + combine = Vec.create (); + undo = Backtrack_stack.create (); + true_; + false_; + in_loop = false; + res_acts = Vec.create (); + field_marked_explain; + count_conflict = Stat.mk_int stat "cc.conflicts"; + count_props = Stat.mk_int stat "cc.propagations"; + count_merge = Stat.mk_int stat "cc.merges"; + } + and true_ = lazy (add_term cc (Term.true_ tst)) + and false_ = lazy (add_term cc (Term.false_ tst)) in + ignore (Lazy.force true_ : e_node); + ignore (Lazy.force false_ : e_node); + cc + +let[@inline] find_t self t : repr = + let n = T_tbl.find self.tbl t in + find_ n + +let pop_acts_ self = + let rec loop acc = + match Vec.pop self.res_acts with + | None -> acc + | Some x -> loop (x :: acc) + in + loop [] + +let check self : Result_action.or_conflict = + Log.debug 5 "(cc.check)"; + self.in_loop <- true; + let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in + try + update_tasks self; + let l = pop_acts_ self in + Ok l + with E_confl c -> Error c + +let check_inv_enabled_ = true (* XXX NUDGE *) + +(* check some internal invariants *) +let check_inv_ (self : t) : unit = + if check_inv_enabled_ then ( + Log.debug 2 "(cc.check-invariants)"; + all_classes self + |> Iter.flat_map E_node.iter_class + |> Iter.iter (fun n -> + match n.n_sig0 with + | None -> () + | Some s -> + let s' = update_sig s in + let ok = + match find_signature self s' with + | None -> false + | Some r -> E_node.equal r n.n_root + in + if not ok then + Log.debugf 0 (fun k -> + k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" + E_node.pp n Signature.pp s Signature.pp s')) + ) + +(* model: return all the classes *) +let get_model (self : t) : repr Iter.t Iter.t = + check_inv_ self; + all_classes self |> Iter.map E_node.iter_class + +(** Arguments to a congruence closure's implementation *) +module type ARG = sig + val view_as_cc : view_as_cc + (** View the Term.t through the lens of the congruence closure *) +end + +module type BUILD = sig + val create : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. + *) +end + +module Make (A : ARG) : BUILD = struct + let create ?stat ?size tst proof : t = + create_ ?stat ?size tst proof ~view_as_cc:A.view_as_cc +end + +module Default = struct + include Make (struct + let view_as_cc (t : Term.t) : _ View.t = + let f, args = Term.unfold_app t in + match Term.view f, args with + | _, [ _; t; u ] when Term.is_eq f -> View.Eq (t, u) + | _ -> + (match Term.view t with + | Term.E_app (f, a) -> View.App_ho (f, a) + | Term.E_const c -> View.App_fun (c, Iter.empty) + | _ -> View.Opaque t) + end) +end diff --git a/src/cc/CC.mli b/src/cc/CC.mli new file mode 100644 index 00000000..117a56e2 --- /dev/null +++ b/src/cc/CC.mli @@ -0,0 +1,285 @@ +open Sidekick_core + +type e_node = E_node.t +(** A node of the congruence closure *) + +type repr = E_node.t +(** Node that is currently a representative. *) + +type explanation = Expl.t + +type bitfield = Bits.field +(** A field in the bitfield of this node. This should only be + allocated when a theory is initialized. + + Bitfields are accessed using preallocated keys. + See {!allocate_bitfield}. + + All fields are initially 0, are backtracked automatically, + and are merged automatically when classes are merged. *) + +(** Main congruence closure signature. + + The congruence closure handles the theory QF_UF (uninterpreted + function symbols). + It is also responsible for {i theory combination}, and provides + a general framework for equality reasoning that other + theories piggyback on. + + For example, the theory of datatypes relies on the congruence closure + to do most of the work, and "only" adds injectivity/disjointness/acyclicity + lemmas when needed. + + Similarly, a theory of arrays would hook into the congruence closure and + assert (dis)equalities as needed. +*) + +type t +(** The congruence closure object. + It contains a fair amount of state and is mutable + and backtrackable. *) + +(** {3 Accessors} *) + +val term_store : t -> Term.store +val proof : t -> Proof_trace.t + +val find : t -> e_node -> repr +(** Current representative *) + +val add_term : t -> Term.t -> e_node +(** Add the Term.t to the congruence closure, if not present already. + Will be backtracked. *) + +val mem_term : t -> Term.t -> bool +(** Returns [true] if the Term.t is explicitly present in the congruence closure *) + +val allocate_bitfield : t -> descr:string -> bitfield +(** Allocate a new e_node field (see {!E_node.bitfield}). + + This field descriptor is henceforth reserved for all nodes + in this congruence closure, and can be set using {!set_bitfield} + for each class_ individually. + This can be used to efficiently store some metadata on nodes + (e.g. "is there a numeric value in the class" + or "is there a constructor Term.t in the class"). + + There may be restrictions on how many distinct fields are allocated + for a given congruence closure (e.g. at most {!Sys.int_size} fields). + *) + +val get_bitfield : t -> bitfield -> E_node.t -> bool +(** Access the bit field of the given e_node *) + +val set_bitfield : t -> bitfield -> bool -> E_node.t -> unit +(** Set the bitfield for the e_node. This will be backtracked. + See {!E_node.bitfield}. *) + +type propagation_reason = unit -> Lit.t list * Proof_term.step_id + +(** Handler Actions + + Actions that can be scheduled by event handlers. *) +module Handler_action : sig + type t = + | Act_merge of E_node.t * E_node.t * Expl.t + | Act_propagate of Lit.t * propagation_reason + + (* TODO: + - an action to modify data associated with a class + *) + + type conflict = Conflict of Expl.t [@@unboxed] + + type or_conflict = (t list, conflict) result + (** Actions or conflict scheduled by an event handler. + + - [Ok acts] is a list of merges and propagations + - [Error confl] is a conflict to resolve. + *) +end + +(** Result Actions. + + + Actions returned by the congruence closure after calling {!check}. *) +module Result_action : sig + type t = + | Act_propagate of { lit: Lit.t; reason: propagation_reason } + (** [propagate (Lit.t, reason)] declares that [reason() => Lit.t] + is a tautology. + + - [reason()] should return a list of literals that are currently true, + as well as a proof. + - [Lit.t] should be a literal of interest (see {!S.set_as_lit}). + + This function might never be called, a congruence closure has the right + to not propagate and only trigger conflicts. *) + + type conflict = + | Conflict of Lit.t list * Proof_term.step_id + (** [raise_conflict (c,pr)] declares that [c] is a tautology of + the theory of congruence. + @param pr the proof of [c] being a tautology *) + + type or_conflict = (t list, conflict) result +end + +(** {3 Events} + + Events triggered by the congruence closure, to which + other plugins can subscribe. *) + +(** Events emitted by the congruence closure when something changes. *) +val on_pre_merge : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t +(** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] + and [n2] are merged with explanation [expl]. *) + +val on_pre_merge2 : + t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t +(** Second phase of "on pre merge". This runs after {!on_pre_merge} + and is used by Plugins. {b NOTE}: Plugin state might be observed as already + changed in these handlers. *) + +val on_post_merge : + t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t +(** [ev_on_post_merge acts n1 n2] is emitted right after [n1] + and [n2] were merged. [find cc n1] and [find cc n2] will return + the same E_node.t. *) + +val on_new_term : t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t +(** [ev_on_new_term n t] is emitted whenever a new Term.t [t] + is added to the congruence closure. Its E_node.t is [n]. *) + +type ev_on_conflict = { cc: t; th: bool; c: Lit.t list } +(** Event emitted when a conflict occurs in the CC. + + [th] is true if the explanation for this conflict involves + at least one "theory" explanation; i.e. some of the equations + participating in the conflict are purely syntactic theories + like injectivity of constructors. *) + +val on_conflict : t -> (ev_on_conflict, unit) Event.t +(** [ev_on_conflict {th; c}] is emitted when the congruence + closure triggers a conflict by asserting the tautology [c]. *) + +val on_propagate : + t -> + ( t * Lit.t * (unit -> Lit.t list * Proof_term.step_id), + Handler_action.t list ) + Event.t +(** [ev_on_propagate Lit.t reason] is emitted whenever [reason() => Lit.t] + is a propagated lemma. See {!CC_ACTIONS.propagate}. *) + +val on_is_subterm : t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t +(** [ev_on_is_subterm n t] is emitted when [n] is a subterm of + another E_node.t for the first time. [t] is the Term.t corresponding to + the E_node.t [n]. This can be useful for theory combination. *) + +(** {3 Misc} *) + +val n_true : t -> E_node.t +(** Node for [true] *) + +val n_false : t -> E_node.t +(** Node for [false] *) + +val n_bool : t -> bool -> E_node.t +(** Node for either true or false *) + +val set_as_lit : t -> E_node.t -> Lit.t -> unit +(** map the given e_node to a literal. *) + +val find_t : t -> Term.t -> repr +(** Current representative of the Term.t. + @raise E_node.t_found if the Term.t is not already {!add}-ed. *) + +val add_iter : t -> Term.t Iter.t -> unit +(** Add a sequence of terms to the congruence closure *) + +val all_classes : t -> repr Iter.t +(** All current classes. This is costly, only use if there is no other solution *) + +val explain_eq : t -> E_node.t -> E_node.t -> Resolved_expl.t +(** Explain why the two nodes are equal. + Fails if they are not, in an unspecified way. *) + +val explain_expl : t -> Expl.t -> Resolved_expl.t +(** Transform explanation into an actionable conflict clause *) + +(* FIXME: remove + val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a + (** Raise a conflict with the given explanation. + It must be a theory tautology that [expl ==> absurd]. + To be used in theories. + + This fails in an unspecified way if the explanation, once resolved, + satisfies {!Resolved_expl.is_semantic}. *) +*) + +val merge : t -> E_node.t -> E_node.t -> Expl.t -> unit +(** Merge these two nodes given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + +val merge_t : t -> Term.t -> Term.t -> Expl.t -> unit +(** Shortcut for adding + merging *) + +(** {3 Main API *) + +val assert_eq : t -> Term.t -> Term.t -> Expl.t -> unit +(** Assert that two terms are equal, using the given explanation. *) + +val assert_lit : t -> Lit.t -> unit +(** Given a literal, assume it in the congruence closure and propagate + its consequences. Will be backtracked. + + Useful for the theory combination or the SAT solver's functor *) + +val assert_lits : t -> Lit.t Iter.t -> unit +(** Addition of many literals *) + +val check : t -> Result_action.or_conflict +(** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. + Will use the {!actions} to propagate literals, declare conflicts, etc. *) + +val push_level : t -> unit +(** Push backtracking level *) + +val pop_levels : t -> int -> unit +(** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) + +val get_model : t -> E_node.t Iter.t Iter.t +(** get all the equivalence classes so they can be merged in the model *) + +type view_as_cc = Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t + +(** Arguments to a congruence closure's implementation *) +module type ARG = sig + val view_as_cc : view_as_cc + (** View the Term.t through the lens of the congruence closure *) +end + +module type BUILD = sig + val create : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t + (** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. + *) +end + +module Make (_ : ARG) : BUILD +module Default : BUILD + +(**/**) + +module Debug_ : sig + val pp : t Fmt.printer + (** Print the whole CC *) +end + +(**/**) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 9b272403..ad7dc973 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,22 +1,14 @@ open Sidekick_core module View = View +module E_node = E_node +module Expl = Expl +module Signature = Signature +module Resolved_expl = Resolved_expl +module Plugin = Plugin +module CC = CC -module type ARG = Sigs.ARG -module type S = Sigs.S -module type DYN_MONOID_PLUGIN = Sigs.DYN_MONOID_PLUGIN -module type MONOID_PLUGIN_ARG = Sigs.MONOID_PLUGIN_ARG -module type MONOID_PLUGIN_BUILDER = Sigs.MONOID_PLUGIN_BUILDER +module type DYN_MONOID_PLUGIN = Sigs_plugin.DYN_MONOID_PLUGIN +module type MONOID_PLUGIN_ARG = Sigs_plugin.MONOID_PLUGIN_ARG +module type MONOID_PLUGIN_BUILDER = Sigs_plugin.MONOID_PLUGIN_BUILDER -module Make (A : ARG) : S = Core_cc.Make (A) - -module Base : S = Make (struct - let view_as_cc (t : Term.t) : _ View.t = - let f, args = Term.unfold_app t in - match Term.view f, args with - | _, [ _; t; u ] when Term.is_eq f -> View.Eq (t, u) - | _ -> - (match Term.view t with - | Term.E_app (f, a) -> View.App_ho (f, a) - | Term.E_const c -> View.App_fun (c, Iter.empty) - | _ -> View.Opaque t) -end) +include CC diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 9c7da989..0facab95 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -1,15 +1,19 @@ (** Congruence Closure Implementation *) open Sidekick_core + +module type DYN_MONOID_PLUGIN = Sigs_plugin.DYN_MONOID_PLUGIN +module type MONOID_PLUGIN_ARG = Sigs_plugin.MONOID_PLUGIN_ARG +module type MONOID_PLUGIN_BUILDER = Sigs_plugin.MONOID_PLUGIN_BUILDER + module View = View +module E_node = E_node +module Expl = Expl +module Signature = Signature +module Resolved_expl = Resolved_expl +module Plugin = Plugin +module CC = CC -module type ARG = Sigs.ARG -module type S = Sigs.S -module type DYN_MONOID_PLUGIN = Sigs.DYN_MONOID_PLUGIN -module type MONOID_PLUGIN_ARG = Sigs.MONOID_PLUGIN_ARG -module type MONOID_PLUGIN_BUILDER = Sigs.MONOID_PLUGIN_BUILDER - -module Make (_ : ARG) : S - -module Base : S -(** Basic implementation following terms' shape *) +include module type of struct + include CC +end diff --git a/src/cc/core_cc.ml b/src/cc/core_cc.ml deleted file mode 100644 index 0df1b40a..00000000 --- a/src/cc/core_cc.ml +++ /dev/null @@ -1,1136 +0,0 @@ -(* actual implementation *) - -open Sidekick_core -open View - -module type ARG = Sigs.ARG - -module Make (A : ARG) : Sigs.S = struct - open struct - (* proof rules *) - module Rules_ = Proof_core - module P = Proof_trace - end - - type e_node = { - n_term: Term.t; - mutable n_sig0: signature option; (* initial signature *) - mutable n_bits: Bits.t; (* bitfield for various properties *) - mutable n_parents: e_node Bag.t; (* parent terms of this node *) - mutable n_root: e_node; - (* representative of congruence class (itself if a representative) *) - mutable n_next: e_node; (* pointer to next element of congruence class *) - mutable n_size: int; (* size of the class *) - mutable n_as_lit: Lit.t option; - (* TODO: put into payload? and only in root? *) - mutable n_expl: explanation_forest_link; - (* the rooted forest for explanations *) - } - (** A node of the congruence closure. - An equivalence class is represented by its "root" element, - the representative. *) - - and signature = (Const.t, e_node, e_node list) View.t - - and explanation_forest_link = - | FL_none - | FL_some of { next: e_node; expl: explanation } - - (* atomic explanation in the congruence closure *) - and explanation = - | E_trivial (* by pure reduction, tautologically equal *) - | E_lit of Lit.t (* because of this literal *) - | E_merge of e_node * e_node - | E_merge_t of Term.t * Term.t - | E_congruence of e_node * e_node (* caused by normal congruence *) - | E_and of explanation * explanation - | E_theory of - Term.t - * Term.t - * (Term.t * Term.t * explanation list) list - * Proof_term.step_id - - type repr = e_node - - module E_node = struct - type t = e_node - - let[@inline] equal (n1 : t) n2 = n1 == n2 - let[@inline] hash n = Term.hash n.n_term - let[@inline] term n = n.n_term - let[@inline] pp out n = Term.pp_debug out n.n_term - let[@inline] as_lit n = n.n_as_lit - - let make (t : Term.t) : t = - let rec n = - { - n_term = t; - n_sig0 = None; - n_bits = Bits.empty; - n_parents = Bag.empty; - n_as_lit = None; - (* TODO: provide a method to do it *) - n_root = n; - n_expl = FL_none; - n_next = n; - n_size = 1; - } - in - n - - let[@inline] is_root (n : e_node) : bool = n.n_root == n - - (* traverse the equivalence class of [n] *) - let iter_class_ (n : e_node) : e_node Iter.t = - fun yield -> - let rec aux u = - yield u; - if u.n_next != n then aux u.n_next - in - aux n - - let[@inline] iter_class n = - assert (is_root n); - iter_class_ n - - let[@inline] iter_parents (n : e_node) : e_node Iter.t = - assert (is_root n); - Bag.to_iter n.n_parents - - type bitfield = Bits.field - - let[@inline] get_field f t = Bits.get f t.n_bits - let[@inline] set_field f b t = t.n_bits <- Bits.set f b t.n_bits - end - - (* non-recursive, inlinable function for [find] *) - let[@inline] find_ (n : e_node) : repr = - let n2 = n.n_root in - assert (E_node.is_root n2); - n2 - - let[@inline] same_class (n1 : e_node) (n2 : e_node) : bool = - E_node.equal (find_ n1) (find_ n2) - - let[@inline] find _ n = find_ n - - module Expl = struct - type t = explanation - - let rec pp out (e : explanation) = - match e with - | E_trivial -> Fmt.string out "reduction" - | E_lit lit -> Lit.pp out lit - | E_congruence (n1, n2) -> - Fmt.fprintf out "(@[congruence@ %a@ %a@])" E_node.pp n1 E_node.pp n2 - | E_merge (a, b) -> - Fmt.fprintf out "(@[merge@ %a@ %a@])" E_node.pp a E_node.pp b - | E_merge_t (a, b) -> - Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp_debug - a Term.pp_debug b - | E_theory (t, u, es, _) -> - Fmt.fprintf out "(@[th@ :t `%a`@ :u `%a`@ :expl_sets %a@])" - Term.pp_debug t Term.pp_debug u - (Util.pp_list - @@ Fmt.Dump.triple Term.pp_debug Term.pp_debug (Fmt.Dump.list pp)) - es - | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b - - let mk_trivial : t = E_trivial - let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) - - let[@inline] mk_merge a b : t = - if E_node.equal a b then - mk_trivial - else - E_merge (a, b) - - let[@inline] mk_merge_t a b : t = - if Term.equal a b then - mk_trivial - else - E_merge_t (a, b) - - let[@inline] mk_lit l : t = E_lit l - let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) - - let rec mk_list l = - match l with - | [] -> mk_trivial - | [ x ] -> x - | E_trivial :: tl -> mk_list tl - | x :: y -> - (match mk_list y with - | E_trivial -> x - | y' -> E_and (x, y')) - end - - module Resolved_expl = struct - type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } - - let pp out (self : t) = - Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits - end - - (** A signature is a shallow term shape where immediate subterms - are representative *) - module Signature = struct - type t = signature - - let equal (s1 : t) s2 : bool = - match s1, s2 with - | Bool b1, Bool b2 -> b1 = b2 - | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 - | App_fun (f1, l1), App_fun (f2, l2) -> - Const.equal f1 f2 && CCList.equal E_node.equal l1 l2 - | App_ho (f1, a1), App_ho (f2, a2) -> - E_node.equal f1 f2 && E_node.equal a1 a2 - | Not a, Not b -> E_node.equal a b - | If (a1, b1, c1), If (a2, b2, c2) -> - E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 - | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 - | Opaque u1, Opaque u2 -> E_node.equal u1 u2 - | Bool _, _ - | App_fun _, _ - | App_ho _, _ - | If _, _ - | Eq _, _ - | Opaque _, _ - | Not _, _ -> - false - - let hash (s : t) : int = - let module H = CCHash in - match s with - | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list E_node.hash l) - | App_ho (f, a) -> H.combine3 30 (E_node.hash f) (E_node.hash a) - | Eq (a, b) -> H.combine3 40 (E_node.hash a) (E_node.hash b) - | Opaque u -> H.combine2 50 (E_node.hash u) - | If (a, b, c) -> - H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) - | Not u -> H.combine2 70 (E_node.hash u) - - let pp out = function - | Bool b -> Fmt.bool out b - | App_fun (f, []) -> Const.pp out f - | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list E_node.pp) l - | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" E_node.pp f E_node.pp a - | Opaque t -> E_node.pp out t - | Not u -> Fmt.fprintf out "(@[not@ %a@])" E_node.pp u - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" E_node.pp a E_node.pp b - | If (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" E_node.pp a E_node.pp b - E_node.pp c - end - - module Sig_tbl = CCHashtbl.Make (Signature) - module T_tbl = CCHashtbl.Make (Term) - - type propagation_reason = unit -> Lit.t list * Proof_term.step_id - - module Handler_action = struct - type t = - | Act_merge of E_node.t * E_node.t * Expl.t - | Act_propagate of Lit.t * propagation_reason - - type conflict = Conflict of Expl.t [@@unboxed] - type or_conflict = (t list, conflict) result - end - - module Result_action = struct - type t = Act_propagate of { lit: Lit.t; reason: propagation_reason } - type conflict = Conflict of Lit.t list * Proof_term.step_id - type or_conflict = (t list, conflict) result - end - - type combine_task = - | CT_merge of e_node * e_node * explanation - | CT_act of Handler_action.t - - type t = { - tst: Term.store; - proof: Proof_trace.t; - tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) - signatures_tbl: e_node Sig_tbl.t; - (* map a signature to the corresponding e_node in some equivalence class. - A signature is a [term_cell] in which every immediate subterm - that participates in the congruence/evaluation relation - is normalized (i.e. is its own representative). - The critical property is that all members of an equivalence class - that have the same "shape" (including head symbol) - have the same signature *) - pending: e_node Vec.t; - combine: combine_task Vec.t; - undo: (unit -> unit) Backtrack_stack.t; - bitgen: Bits.bitfield_gen; - field_marked_explain: Bits.field; - (* used to mark traversed nodes when looking for a common ancestor *) - true_: e_node lazy_t; - false_: e_node lazy_t; - mutable in_loop: bool; (* currently being modified? *) - res_acts: Result_action.t Vec.t; (* to return *) - on_pre_merge: - ( t * E_node.t * E_node.t * Expl.t, - Handler_action.or_conflict ) - Event.Emitter.t; - on_pre_merge2: - ( t * E_node.t * E_node.t * Expl.t, - Handler_action.or_conflict ) - Event.Emitter.t; - on_post_merge: - (t * E_node.t * E_node.t, Handler_action.t list) Event.Emitter.t; - on_new_term: (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; - on_conflict: (ev_on_conflict, unit) Event.Emitter.t; - on_propagate: - (t * Lit.t * propagation_reason, Handler_action.t list) Event.Emitter.t; - on_is_subterm: - (t * E_node.t * Term.t, Handler_action.t list) Event.Emitter.t; - count_conflict: int Stat.counter; - count_props: int Stat.counter; - count_merge: int Stat.counter; - } - (* TODO: an additional union-find to keep track, for each term, - of the terms they are known to be equal to, according - to the current explanation. That allows not to prove some equality - several times. - See "fast congruence closure and extensions", Nieuwenhuis&al, page 14 *) - - and ev_on_conflict = { cc: t; th: bool; c: Lit.t list } - - let[@inline] size_ (r : repr) = r.n_size - let[@inline] n_true self = Lazy.force self.true_ - let[@inline] n_false self = Lazy.force self.false_ - - let n_bool self b = - if b then - n_true self - else - n_false self - - let[@inline] term_store self = self.tst - let[@inline] proof self = self.proof - - let allocate_bitfield self ~descr = - Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); - Bits.mk_field self.bitgen - - let[@inline] on_backtrack self f : unit = - Backtrack_stack.push_if_nonzero_level self.undo f - - let[@inline] get_bitfield _cc field n = E_node.get_field field n - - let set_bitfield self field b n = - let old = E_node.get_field field n in - if old <> b then ( - on_backtrack self (fun () -> E_node.set_field field old n); - E_node.set_field field b n - ) - - (* check if [t] is in the congruence closure. - Invariant: [in_cc t ∧ do_cc t => forall u subterm t, in_cc u] *) - let[@inline] mem (self : t) (t : Term.t) : bool = T_tbl.mem self.tbl t - - module Debug_ = struct - (* print full state *) - let pp out (self : t) : unit = - let pp_next out n = Fmt.fprintf out "@ :next %a" E_node.pp n.n_next in - let pp_root out n = - if E_node.is_root n then - Fmt.string out " :is-root" - else - Fmt.fprintf out "@ :root %a" E_node.pp n.n_root - in - let pp_expl out n = - match n.n_expl with - | FL_none -> () - | FL_some e -> - Fmt.fprintf out " (@[:forest %a :expl %a@])" E_node.pp e.next Expl.pp - e.expl - in - let pp_n out n = - Fmt.fprintf out "(@[%a%a%a%a@])" Term.pp_debug n.n_term pp_root n - pp_next n pp_expl n - and pp_sig_e out (s, n) = - Fmt.fprintf out "(@[<1>%a@ ~~> %a%a@])" Signature.pp s E_node.pp n - pp_root n - in - Fmt.fprintf out - "(@[@{cc.state@}@ (@[:nodes@ %a@])@ (@[:sig-tbl@ \ - %a@])@])" - (Util.pp_iter ~sep:" " pp_n) - (T_tbl.values self.tbl) - (Util.pp_iter ~sep:" " pp_sig_e) - (Sig_tbl.to_iter self.signatures_tbl) - end - - (* compute up-to-date signature *) - let update_sig (s : signature) : Signature.t = - View.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) - - (* find whether the given (parent) term corresponds to some signature - in [signatures_] *) - let[@inline] find_signature cc (s : signature) : repr option = - Sig_tbl.get cc.signatures_tbl s - - (* add to signature table. Assume it's not present already *) - let add_signature self (s : signature) (n : e_node) : unit = - assert (not @@ Sig_tbl.mem self.signatures_tbl s); - Log.debugf 50 (fun k -> - k "(@[cc.add-sig@ %a@ ~~> %a@])" Signature.pp s E_node.pp n); - on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); - Sig_tbl.add self.signatures_tbl s n - - let push_pending self t : unit = - Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); - Vec.push self.pending t - - let push_action self (a : Handler_action.t) : unit = - Vec.push self.combine (CT_act a) - - let push_action_l self (l : _ list) : unit = List.iter (push_action self) l - - let merge_classes self t u e : unit = - if t != u && not (same_class t u) then ( - Log.debugf 50 (fun k -> - k "(@[cc.push-combine@ %a ~@ %a@ :expl %a@])" E_node.pp t - E_node.pp u Expl.pp e); - Vec.push self.combine @@ CT_merge (t, u, e) - ) - - (* re-root the explanation tree of the equivalence class of [n] - so that it points to [n]. - postcondition: [n.n_expl = None] *) - let[@unroll 2] rec reroot_expl (self : t) (n : e_node) : unit = - match n.n_expl with - | FL_none -> () (* already root *) - | FL_some { next = u; expl = e_n_u } -> - (* reroot to [u], then invert link between [u] and [n] *) - reroot_expl self u; - u.n_expl <- FL_some { next = n; expl = e_n_u }; - n.n_expl <- FL_none - - exception E_confl of Result_action.conflict - - let raise_conflict_ (cc : t) ~th (e : Lit.t list) (p : Proof_term.step_id) : _ - = - Profile.instant "cc.conflict"; - (* clear tasks queue *) - Vec.clear cc.pending; - Vec.clear cc.combine; - Event.emit cc.on_conflict { cc; th; c = e }; - Stat.incr cc.count_conflict; - raise (E_confl (Conflict (e, p))) - - let[@inline] all_classes self : repr Iter.t = - T_tbl.values self.tbl |> Iter.filter E_node.is_root - - (* find the closest common ancestor of [a] and [b] in the proof forest. - - Precond: - - [a] and [b] are in the same class - - no e_node has the flag [field_marked_explain] on - Invariants: - - if [n] is marked, then all the predecessors of [n] - from [a] or [b] are marked too. - *) - let find_common_ancestor self (a : e_node) (b : e_node) : e_node = - (* catch up to the other e_node *) - let rec find1 a = - if E_node.get_field self.field_marked_explain a then - a - else ( - match a.n_expl with - | FL_none -> assert false - | FL_some r -> find1 r.next - ) - in - let rec find2 a b = - if E_node.equal a b then - a - else if E_node.get_field self.field_marked_explain a then - a - else if E_node.get_field self.field_marked_explain b then - b - else ( - E_node.set_field self.field_marked_explain true a; - E_node.set_field self.field_marked_explain true b; - match a.n_expl, b.n_expl with - | FL_some r1, FL_some r2 -> find2 r1.next r2.next - | FL_some r, FL_none -> find1 r.next - | FL_none, FL_some r -> find1 r.next - | FL_none, FL_none -> assert false - (* no common ancestor *) - ) - in - - (* cleanup tags on nodes traversed in [find2] *) - let rec cleanup_ n = - if E_node.get_field self.field_marked_explain n then ( - E_node.set_field self.field_marked_explain false n; - match n.n_expl with - | FL_none -> () - | FL_some { next; _ } -> cleanup_ next - ) - in - let n = find2 a b in - cleanup_ a; - cleanup_ b; - n - - module Expl_state = struct - type t = { - mutable lits: Lit.t list; - mutable th_lemmas: - (Lit.t * (Lit.t * Lit.t list) list * Proof_term.step_id) list; - } - - let create () : t = { lits = []; th_lemmas = [] } - let[@inline] copy self : t = { self with lits = self.lits } - let[@inline] add_lit (self : t) lit = self.lits <- lit :: self.lits - - let[@inline] add_th (self : t) lit hyps pr : unit = - self.th_lemmas <- (lit, hyps, pr) :: self.th_lemmas - - let merge self other = - let { lits = o_lits; th_lemmas = o_lemmas } = other in - self.lits <- List.rev_append o_lits self.lits; - self.th_lemmas <- List.rev_append o_lemmas self.th_lemmas; - () - - (* proof of [\/_i ¬lits[i]] *) - let proof_of_th_lemmas (self : t) (proof : Proof_trace.t) : - Proof_term.step_id = - let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in - let p_lits2 = - Iter.of_list self.th_lemmas - |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) - in - let p_cc = - P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) - in - let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = - (* pr_th: [sub_proofs |- t=u]. - now resolve away [sub_proofs] to get literals that were - asserted in the congruence closure *) - let pr_th = - List.fold_left - (fun pr_th (lit_i, hyps_i) -> - (* [hyps_i |- lit_i] *) - let lemma_i = - P.add_step proof - @@ Rules_.lemma_cc - Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) - in - (* resolve [lit_i] away. *) - P.add_step proof - @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) - pr_th sub_proofs - in - P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr - in - (* resolve with theory proofs responsible for some merges, if any. *) - List.fold_left resolve_with_th_proof p_cc self.th_lemmas - - let to_resolved_expl (self : t) : Resolved_expl.t = - (* FIXME: package the th lemmas too *) - let { lits; th_lemmas = _ } = self in - let s2 = copy self in - let pr proof = proof_of_th_lemmas s2 proof in - { Resolved_expl.lits; pr } - end - - (* decompose explanation [e] into a list of literals added to [acc] *) - let rec explain_decompose_expl self (st : Expl_state.t) (e : explanation) : - unit = - Log.debugf 5 (fun k -> k "(@[cc.decompose_expl@ %a@])" Expl.pp e); - match e with - | E_trivial -> () - | E_congruence (n1, n2) -> - (match n1.n_sig0, n2.n_sig0 with - | Some (App_fun (f1, a1)), Some (App_fun (f2, a2)) -> - assert (Const.equal f1 f2); - assert (List.length a1 = List.length a2); - List.iter2 (explain_equal_rec_ self st) a1 a2 - | Some (App_ho (f1, a1)), Some (App_ho (f2, a2)) -> - explain_equal_rec_ self st f1 f2; - explain_equal_rec_ self st a1 a2 - | Some (If (a1, b1, c1)), Some (If (a2, b2, c2)) -> - explain_equal_rec_ self st a1 a2; - explain_equal_rec_ self st b1 b2; - explain_equal_rec_ self st c1 c2 - | _ -> assert false) - | E_lit lit -> Expl_state.add_lit st lit - | E_theory (t, u, expl_sets, pr) -> - let sub_proofs = - List.map - (fun (t_i, u_i, expls_i) -> - let lit_i = Lit.make_eq self.tst t_i u_i in - (* use a separate call to [explain_expls] for each set *) - let sub = explain_expls self expls_i in - Expl_state.merge st sub; - lit_i, sub.lits) - expl_sets - in - let lit_t_u = Lit.make_eq self.tst t u in - Expl_state.add_th st lit_t_u sub_proofs pr - | E_merge (a, b) -> explain_equal_rec_ self st a b - | E_merge_t (a, b) -> - (* find nodes for [a] and [b] on the fly *) - (match T_tbl.find self.tbl a, T_tbl.find self.tbl b with - | a, b -> explain_equal_rec_ self st a b - | exception Not_found -> - Error.errorf "expl: cannot find e_node(s) for %a, %a" Term.pp_debug a - Term.pp_debug b) - | E_and (a, b) -> - explain_decompose_expl self st a; - explain_decompose_expl self st b - - and explain_expls self (es : explanation list) : Expl_state.t = - let st = Expl_state.create () in - List.iter (explain_decompose_expl self st) es; - st - - and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) - : unit = - Log.debugf 5 (fun k -> - k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); - assert (E_node.equal (find_ a) (find_ b)); - let ancestor = find_common_ancestor cc a b in - explain_along_path cc st a ancestor; - explain_along_path cc st b ancestor - - (* explain why [a = parent_a], where [a -> ... -> target] in the - proof forest *) - and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) - : unit = - let rec aux n = - if n == target then - () - else ( - match n.n_expl with - | FL_none -> assert false - | FL_some { next = next_n; expl } -> - explain_decompose_expl self st expl; - (* now prove [next_n = target] *) - aux next_n - ) - in - aux a - - (* add a term *) - let[@inline] rec add_term_rec_ self t : e_node = - match T_tbl.find self.tbl t with - | n -> n - | exception Not_found -> add_new_term_ self t - - (* add [t] when not present already *) - and add_new_term_ self (t : Term.t) : e_node = - assert (not @@ mem self t); - Log.debugf 15 (fun k -> k "(@[cc.add-term@ %a@])" Term.pp_debug t); - let n = E_node.make t in - (* register sub-terms, add [t] to their parent list, and return the - corresponding initial signature *) - let sig0 = compute_sig0 self n in - n.n_sig0 <- sig0; - (* remove term when we backtrack *) - on_backtrack self (fun () -> - Log.debugf 30 (fun k -> k "(@[cc.remove-term@ %a@])" Term.pp_debug t); - T_tbl.remove self.tbl t); - (* add term to the table *) - T_tbl.add self.tbl t n; - if Option.is_some sig0 then - (* [n] might be merged with other equiv classes *) - push_pending self n; - Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); - n - - (* compute the initial signature of the given e_node *) - and compute_sig0 (self : t) (n : e_node) : Signature.t option = - (* add sub-term to [cc], and register [n] to its parents. - Note that we return the exact sub-term, to get proper - explanations, but we add to the sub-term's root's parent list. *) - let deref_sub (u : Term.t) : e_node = - let sub = add_term_rec_ self u in - (* add [n] to [sub.root]'s parent list *) - (let sub_r = find_ sub in - let old_parents = sub_r.n_parents in - if Bag.is_empty old_parents then - (* first time it has parents: tell watchers that this is a subterm *) - Event.emit_iter self.on_is_subterm (self, sub, u) - ~f:(push_action_l self); - on_backtrack self (fun () -> sub_r.n_parents <- old_parents); - sub_r.n_parents <- Bag.cons n sub_r.n_parents); - sub - in - let[@inline] return x = Some x in - match A.view_as_cc n.n_term with - | Bool _ | Opaque _ -> None - | Eq (a, b) -> - let a = deref_sub a in - let b = deref_sub b in - return @@ Eq (a, b) - | Not u -> return @@ Not (deref_sub u) - | App_fun (f, args) -> - let args = args |> Iter.map deref_sub |> Iter.to_list in - if args <> [] then - return @@ App_fun (f, args) - else - None - | App_ho (f, a) -> - let f = deref_sub f in - let a = deref_sub a in - return @@ App_ho (f, a) - | If (a, b, c) -> return @@ If (deref_sub a, deref_sub b, deref_sub c) - - let[@inline] add_term self t : e_node = add_term_rec_ self t - let mem_term = mem - - let set_as_lit self (n : e_node) (lit : Lit.t) : unit = - match n.n_as_lit with - | Some _ -> () - | None -> - Log.debugf 15 (fun k -> - k "(@[cc.set-as-lit@ %a@ %a@])" E_node.pp n Lit.pp lit); - on_backtrack self (fun () -> n.n_as_lit <- None); - n.n_as_lit <- Some lit - - (* is [n] true or false? *) - let n_is_bool_value (self : t) n : bool = - E_node.equal n (n_true self) || E_node.equal n (n_false self) - - (* gather a pair [lits, pr], where [lits] is the set of - asserted literals needed in the explanation (which is useful for - the SAT solver), and [pr] is a proof, including sub-proofs for theory - merges. *) - let lits_and_proof_of_expl (self : t) (st : Expl_state.t) : - Lit.t list * Proof_term.step_id = - let { Expl_state.lits; th_lemmas = _ } = st in - let pr = Expl_state.proof_of_th_lemmas st self.proof in - lits, pr - - (* main CC algo: add terms from [pending] to the signature table, - check for collisions *) - let rec update_tasks (self : t) : unit = - while not (Vec.is_empty self.pending && Vec.is_empty self.combine) do - while not @@ Vec.is_empty self.pending do - task_pending_ self (Vec.pop_exn self.pending) - done; - while not @@ Vec.is_empty self.combine do - task_combine_ self (Vec.pop_exn self.combine) - done - done - - and task_pending_ self (n : e_node) : unit = - (* check if some parent collided *) - match n.n_sig0 with - | None -> () (* no-op *) - | Some (Eq (a, b)) -> - (* if [a=b] is now true, merge [(a=b)] and [true] *) - if same_class a b then ( - let expl = Expl.mk_merge a b in - Log.debugf 5 (fun k -> - k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a - E_node.pp b); - merge_classes self n (n_true self) expl - ) - | Some (Not u) -> - (* [u = bool ==> not u = not bool] *) - let r_u = find_ u in - if E_node.equal r_u (n_true self) then ( - let expl = Expl.mk_merge u (n_true self) in - merge_classes self n (n_false self) expl - ) else if E_node.equal r_u (n_false self) then ( - let expl = Expl.mk_merge u (n_false self) in - merge_classes self n (n_true self) expl - ) - | Some s0 -> - (* update the signature by using [find] on each sub-e_node *) - let s = update_sig s0 in - (match find_signature self s with - | None -> - (* add to the signature table [sig(n) --> n] *) - add_signature self s n - | Some u when E_node.equal n u -> () - | Some u -> - (* [t1] and [t2] must be applications of the same symbol to - arguments that are pairwise equal *) - assert (n != u); - let expl = Expl.mk_congruence n u in - merge_classes self n u expl) - - and task_combine_ self = function - | CT_merge (a, b, e_ab) -> task_merge_ self a b e_ab - | CT_act (Handler_action.Act_merge (t, u, e)) -> task_merge_ self t u e - | CT_act (Handler_action.Act_propagate (lit, reason)) -> - (* will return this propagation to the caller *) - Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }) - - (* main CC algo: merge equivalence classes in [st.combine]. - @raise Exn_unsat if merge fails *) - and task_merge_ self a b e_ab : unit = - let ra = find_ a in - let rb = find_ b in - if not @@ E_node.equal ra rb then ( - assert (E_node.is_root ra); - assert (E_node.is_root rb); - Stat.incr self.count_merge; - (* check we're not merging [true] and [false] *) - if - (E_node.equal ra (n_true self) && E_node.equal rb (n_false self)) - || (E_node.equal rb (n_true self) && E_node.equal ra (n_false self)) - then ( - Log.debugf 5 (fun k -> - k - "(@[cc.merge.true_false_conflict@ @[:r1 %a@ :t1 %a@]@ @[:r2 \ - %a@ :t2 %a@]@ :e_ab %a@])" - E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); - let th = ref false in - (* TODO: - C1: P.true_neq_false - C2: lemma [lits |- true=false] (and resolve on theory proofs) - C3: r1 C1 C2 - *) - let expl_st = Expl_state.create () in - explain_decompose_expl self expl_st e_ab; - explain_equal_rec_ self expl_st a ra; - explain_equal_rec_ self expl_st b rb; - - (* regular conflict *) - let lits, pr = lits_and_proof_of_expl self expl_st in - raise_conflict_ self ~th:!th (List.rev_map Lit.neg lits) pr - ); - (* We will merge [r_from] into [r_into]. - we try to ensure that [size ra <= size rb] in general, but always - keep values as representative *) - let r_from, r_into = - if n_is_bool_value self ra then - rb, ra - else if n_is_bool_value self rb then - ra, rb - else if size_ ra > size_ rb then - rb, ra - else - ra, rb - in - (* when merging terms with [true] or [false], possibly propagate them to SAT *) - let merge_bool r1 t1 r2 t2 = - if E_node.equal r1 (n_true self) then - propagate_bools self r2 t2 r1 t1 e_ab true - else if E_node.equal r1 (n_false self) then - propagate_bools self r2 t2 r1 t1 e_ab false - in - - merge_bool ra a rb b; - merge_bool rb b ra a; - - (* perform [union r_from r_into] *) - Log.debugf 15 (fun k -> - k "(@[cc.merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp - r_into); - - (* call [on_pre_merge] functions, and merge theory data items *) - (* explanation is [a=ra & e_ab & b=rb] *) - (let expl = - Expl.mk_list [ e_ab; Expl.mk_merge a ra; Expl.mk_merge b rb ] - in - - let handle_act = function - | Ok l -> push_action_l self l - | Error (Handler_action.Conflict expl) -> - raise_conflict_from_expl self expl - in - - Event.emit_iter self.on_pre_merge - (self, r_into, r_from, expl) - ~f:handle_act; - Event.emit_iter self.on_pre_merge2 - (self, r_into, r_from, expl) - ~f:handle_act); - - (* TODO: merge plugin data here, _after_ the pre-merge hooks are called, - so they have a chance of observing pre-merge plugin data *) - ((* parents might have a different signature, check for collisions *) - E_node.iter_parents r_from (fun parent -> push_pending self parent); - (* for each e_node in [r_from]'s class, make it point to [r_into] *) - E_node.iter_class r_from (fun u -> - assert (u.n_root == r_from); - u.n_root <- r_into); - (* capture current state *) - let r_into_old_next = r_into.n_next in - let r_from_old_next = r_from.n_next in - let r_into_old_parents = r_into.n_parents in - let r_into_old_bits = r_into.n_bits in - (* swap [into.next] and [from.next], merging the classes *) - r_into.n_next <- r_from_old_next; - r_from.n_next <- r_into_old_next; - r_into.n_parents <- Bag.append r_into.n_parents r_from.n_parents; - r_into.n_size <- r_into.n_size + r_from.n_size; - r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; - (* on backtrack, unmerge classes and restore the pointers to [r_from] *) - on_backtrack self (fun () -> - Log.debugf 30 (fun k -> - k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from - E_node.pp r_into); - r_into.n_bits <- r_into_old_bits; - r_into.n_next <- r_into_old_next; - r_from.n_next <- r_from_old_next; - r_into.n_parents <- r_into_old_parents; - (* NOTE: this must come after the restoration of [next] pointers, - otherwise we'd iterate on too big a class *) - E_node.iter_class_ r_from (fun u -> u.n_root <- r_from); - r_into.n_size <- r_into.n_size - r_from.n_size)); - - (* update explanations (a -> b), arbitrarily. - Note that here we merge the classes by adding a bridge between [a] - and [b], not their roots. *) - reroot_expl self a; - assert (a.n_expl = FL_none); - (* on backtracking, link may be inverted, but we delete the one - that bridges between [a] and [b] *) - on_backtrack self (fun () -> - match a.n_expl, b.n_expl with - | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none - | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none - | _ -> assert false); - a.n_expl <- FL_some { next = b; expl = e_ab }; - (* call [on_post_merge] *) - Event.emit_iter self.on_post_merge (self, r_into, r_from) - ~f:(push_action_l self) - ) - - (* we are merging [r1] with [r2==Bool(sign)], so propagate each term [u1] - in the equiv class of [r1] that is a known literal back to the SAT solver - and which is not the one initially merged. - We can explain the propagation with [u1 = t1 =e= t2 = r2==bool] *) - and propagate_bools self r1 t1 r2 t2 (e_12 : explanation) sign : unit = - (* explanation for [t1 =e= t2 = r2] *) - let half_expl_and_pr = - lazy - (let st = Expl_state.create () in - explain_decompose_expl self st e_12; - explain_equal_rec_ self st r2 t2; - st) - in - (* TODO: flag per class, `or`-ed on merge, to indicate if the class - contains at least one lit *) - E_node.iter_class r1 (fun u1 -> - (* propagate if: - - [u1] is a proper literal - - [t2 != r2], because that can only happen - after an explicit merge (no way to obtain that by propagation) - *) - match E_node.as_lit u1 with - | Some lit when not (E_node.equal r2 t2) -> - let lit = - if sign then - lit - else - Lit.neg lit - in - (* apply sign *) - Log.debugf 5 (fun k -> k "(@[cc.bool_propagate@ %a@])" Lit.pp lit); - (* complete explanation with the [u1=t1] chunk *) - let (lazy st) = half_expl_and_pr in - let st = Expl_state.copy st in - (* do not modify shared st *) - explain_equal_rec_ self st u1 t1; - - (* propagate only if this doesn't depend on some semantic values *) - let reason () = - (* true literals explaining why t1=t2 *) - let guard = st.lits in - (* get a proof of [guard /\ ¬lit] being absurd, to propagate [lit] *) - Expl_state.add_lit st (Lit.neg lit); - let _, pr = lits_and_proof_of_expl self st in - guard, pr - in - Vec.push self.res_acts (Result_action.Act_propagate { lit; reason }); - Event.emit_iter self.on_propagate (self, lit, reason) - ~f:(push_action_l self); - Stat.incr self.count_props - | _ -> ()) - - (* raise a conflict from an explanation, typically from an event handler. - Raises E_confl with a result conflict. *) - and raise_conflict_from_expl self (expl : Expl.t) : 'a = - Log.debugf 5 (fun k -> - k "(@[cc.theory.raise-conflict@ :expl %a@])" Expl.pp expl); - let st = Expl_state.create () in - explain_decompose_expl self st expl; - let lits, pr = lits_and_proof_of_expl self st in - let c = List.rev_map Lit.neg lits in - let th = st.th_lemmas <> [] in - raise_conflict_ self ~th c pr - - let add_iter self it : unit = it (fun t -> ignore @@ add_term_rec_ self t) - - let push_level (self : t) : unit = - assert (not self.in_loop); - Backtrack_stack.push_level self.undo - - let pop_levels (self : t) n : unit = - assert (not self.in_loop); - Vec.clear self.pending; - Vec.clear self.combine; - Log.debugf 15 (fun k -> - k "(@[cc.pop-levels %d@ :n-lvls %d@])" n - (Backtrack_stack.n_levels self.undo)); - Backtrack_stack.pop_levels self.undo n ~f:(fun f -> f ()); - () - - let assert_eq self t u expl : unit = - assert (not self.in_loop); - let t = add_term self t in - let u = add_term self u in - (* merge [a] and [b] *) - merge_classes self t u expl - - (* assert that this boolean literal holds. - if a lit is [= a b], merge [a] and [b]; - otherwise merge the atom with true/false *) - let assert_lit self lit : unit = - assert (not self.in_loop); - let t = Lit.term lit in - Log.debugf 15 (fun k -> k "(@[cc.assert-lit@ %a@])" Lit.pp lit); - let sign = Lit.sign lit in - match A.view_as_cc t with - | Eq (a, b) when sign -> assert_eq self a b (Expl.mk_lit lit) - | _ -> - (* equate t and true/false *) - let rhs = n_bool self sign in - let n = add_term self t in - (* TODO: ensure that this is O(1). - basically, just have [n] point to true/false and thus acquire - the corresponding value, so its superterms (like [ite]) can evaluate - properly *) - (* TODO: use oriented merge (force direction [n -> rhs]) *) - merge_classes self n rhs (Expl.mk_lit lit) - - let[@inline] assert_lits self lits : unit = - assert (not self.in_loop); - Iter.iter (assert_lit self) lits - - let merge self n1 n2 expl = - assert (not self.in_loop); - Log.debugf 5 (fun k -> - k "(@[cc.theory.merge@ :n1 %a@ :n2 %a@ :expl %a@])" E_node.pp n1 - E_node.pp n2 Expl.pp expl); - assert (Term.equal (Term.ty n1.n_term) (Term.ty n2.n_term)); - merge_classes self n1 n2 expl - - let merge_t self t1 t2 expl = - merge self (add_term self t1) (add_term self t2) expl - - let explain_eq self n1 n2 : Resolved_expl.t = - let st = Expl_state.create () in - explain_equal_rec_ self st n1 n2; - (* FIXME: also need to return the proof? *) - Expl_state.to_resolved_expl st - - let explain_expl (self : t) expl : Resolved_expl.t = - let expl_st = Expl_state.create () in - explain_decompose_expl self expl_st expl; - Expl_state.to_resolved_expl expl_st - - let[@inline] on_pre_merge self = Event.of_emitter self.on_pre_merge - let[@inline] on_pre_merge2 self = Event.of_emitter self.on_pre_merge2 - let[@inline] on_post_merge self = Event.of_emitter self.on_post_merge - let[@inline] on_new_term self = Event.of_emitter self.on_new_term - let[@inline] on_conflict self = Event.of_emitter self.on_conflict - let[@inline] on_propagate self = Event.of_emitter self.on_propagate - let[@inline] on_is_subterm self = Event.of_emitter self.on_is_subterm - - let create ?(stat = Stat.global) ?(size = `Big) (tst : Term.store) - (proof : Proof_trace.t) : t = - let size = - match size with - | `Small -> 128 - | `Big -> 2048 - in - let bitgen = Bits.mk_gen () in - let field_marked_explain = Bits.mk_field bitgen in - let rec cc = - { - tst; - proof; - tbl = T_tbl.create size; - signatures_tbl = Sig_tbl.create size; - bitgen; - on_pre_merge = Event.Emitter.create (); - on_pre_merge2 = Event.Emitter.create (); - on_post_merge = Event.Emitter.create (); - on_new_term = Event.Emitter.create (); - on_conflict = Event.Emitter.create (); - on_propagate = Event.Emitter.create (); - on_is_subterm = Event.Emitter.create (); - pending = Vec.create (); - combine = Vec.create (); - undo = Backtrack_stack.create (); - true_; - false_; - in_loop = false; - res_acts = Vec.create (); - field_marked_explain; - count_conflict = Stat.mk_int stat "cc.conflicts"; - count_props = Stat.mk_int stat "cc.propagations"; - count_merge = Stat.mk_int stat "cc.merges"; - } - and true_ = lazy (add_term cc (Term.true_ tst)) - and false_ = lazy (add_term cc (Term.false_ tst)) in - ignore (Lazy.force true_ : e_node); - ignore (Lazy.force false_ : e_node); - cc - - let[@inline] find_t self t : repr = - let n = T_tbl.find self.tbl t in - find_ n - - let pop_acts_ self = - let rec loop acc = - match Vec.pop self.res_acts with - | None -> acc - | Some x -> loop (x :: acc) - in - loop [] - - let check self : Result_action.or_conflict = - Log.debug 5 "(cc.check)"; - self.in_loop <- true; - let@ () = Stdlib.Fun.protect ~finally:(fun () -> self.in_loop <- false) in - try - update_tasks self; - let l = pop_acts_ self in - Ok l - with E_confl c -> Error c - - let check_inv_enabled_ = true (* XXX NUDGE *) - - (* check some internal invariants *) - let check_inv_ (self : t) : unit = - if check_inv_enabled_ then ( - Log.debug 2 "(cc.check-invariants)"; - all_classes self - |> Iter.flat_map E_node.iter_class - |> Iter.iter (fun n -> - match n.n_sig0 with - | None -> () - | Some s -> - let s' = update_sig s in - let ok = - match find_signature self s' with - | None -> false - | Some r -> E_node.equal r n.n_root - in - if not ok then - Log.debugf 0 (fun k -> - k "(@[cc.check.fail@ :n %a@ :sig %a@ :actual-sig %a@])" - E_node.pp n Signature.pp s Signature.pp s')) - ) - - (* model: return all the classes *) - let get_model (self : t) : repr Iter.t Iter.t = - check_inv_ self; - all_classes self |> Iter.map E_node.iter_class -end diff --git a/src/cc/dune b/src/cc/dune index d249010d..5994f7ba 100644 --- a/src/cc/dune +++ b/src/cc/dune @@ -2,6 +2,6 @@ (name Sidekick_cc) (public_name sidekick.cc) (synopsis "main congruence closure implementation") - (private_modules core_cc) + (private_modules types_ signature) (libraries containers iter sidekick.sigs sidekick.core sidekick.util) (flags :standard -open Sidekick_util)) diff --git a/src/cc/e_node.ml b/src/cc/e_node.ml new file mode 100644 index 00000000..2eb3fb01 --- /dev/null +++ b/src/cc/e_node.ml @@ -0,0 +1,50 @@ +open Types_ + +type t = e_node + +let[@inline] equal (n1 : t) n2 = n1 == n2 +let[@inline] hash n = Term.hash n.n_term +let[@inline] term n = n.n_term +let[@inline] pp out n = Term.pp_debug out n.n_term +let[@inline] as_lit n = n.n_as_lit + +let make (t : Term.t) : t = + let rec n = + { + n_term = t; + n_sig0 = None; + n_bits = Bits.empty; + n_parents = Bag.empty; + n_as_lit = None; + (* TODO: provide a method to do it *) + n_root = n; + n_expl = FL_none; + n_next = n; + n_size = 1; + } + in + n + +let[@inline] is_root (n : e_node) : bool = n.n_root == n + +(* traverse the equivalence class of [n] *) +let iter_class_ (n : e_node) : e_node Iter.t = + fun yield -> + let rec aux u = + yield u; + if u.n_next != n then aux u.n_next + in + aux n + +let[@inline] iter_class n = + assert (is_root n); + iter_class_ n + +let[@inline] iter_parents (n : e_node) : e_node Iter.t = + assert (is_root n); + Bag.to_iter n.n_parents + +module Internal_ = struct + let iter_class_ = iter_class_ + let make = make +end diff --git a/src/cc/e_node.mli b/src/cc/e_node.mli new file mode 100644 index 00000000..6486c74d --- /dev/null +++ b/src/cc/e_node.mli @@ -0,0 +1,61 @@ +(** E-node. + + An e-node is a node in the congruence closure that is contained + in some equivalence classe). + An equivalence class is a set of terms that are currently equal + in the partial model built by the solver. + The class is represented by a collection of nodes, one of which is + distinguished and is called the "representative". + + All information pertaining to the whole equivalence class is stored + in its representative's {!E_node.t}. + + When two classes become equal (are "merged"), one of the two + representatives is picked as the representative of the new class. + The new class contains the union of the two old classes' nodes. + + We also allow theories to store additional information in the + representative. This information can be used when two classes are + merged, to detect conflicts and solve equations à la Shostak. + *) + +open Types_ + +type t = Types_.e_node +(** An E-node. + + A value of type [t] points to a particular Term.t, but see + {!find} to get the representative of the class. *) + +include Sidekick_sigs.PRINT with type t := t + +val term : t -> Term.t +(** Term contained in this equivalence class. + If [is_root n], then [Term.t n] is the class' representative Term.t. *) + +val equal : t -> t -> bool +(** Are two classes {b physically} equal? To check for + logical equality, use [CC.E_node.equal (CC.find cc n1) (CC.find cc n2)] + which checks for equality of representatives. *) + +val hash : t -> int +(** An opaque hash of this E_node.t. *) + +val is_root : t -> bool +(** Is the E_node.t a root (ie the representative of its class)? + See {!find} to get the root. *) + +val iter_class : t -> t Iter.t +(** Traverse the congruence class. + Precondition: [is_root n] (see {!find} below) *) + +val iter_parents : t -> t Iter.t +(** Traverse the parents of the class. + Precondition: [is_root n] (see {!find} below) *) + +val as_lit : t -> Lit.t option + +module Internal_ : sig + val iter_class_ : t -> t Iter.t + val make : Term.t -> t +end diff --git a/src/cc/expl.ml b/src/cc/expl.ml new file mode 100644 index 00000000..534b36a7 --- /dev/null +++ b/src/cc/expl.ml @@ -0,0 +1,50 @@ +open Types_ + +type t = explanation + +let rec pp out (e : explanation) = + match e with + | E_trivial -> Fmt.string out "reduction" + | E_lit lit -> Lit.pp out lit + | E_congruence (n1, n2) -> + Fmt.fprintf out "(@[congruence@ %a@ %a@])" E_node.pp n1 E_node.pp n2 + | E_merge (a, b) -> + Fmt.fprintf out "(@[merge@ %a@ %a@])" E_node.pp a E_node.pp b + | E_merge_t (a, b) -> + Fmt.fprintf out "(@[merge@ @[:n1 %a@]@ @[:n2 %a@]@])" Term.pp_debug a + Term.pp_debug b + | E_theory (t, u, es, _) -> + Fmt.fprintf out "(@[th@ :t `%a`@ :u `%a`@ :expl_sets %a@])" Term.pp_debug t + Term.pp_debug u + (Util.pp_list + @@ Fmt.Dump.triple Term.pp_debug Term.pp_debug (Fmt.Dump.list pp)) + es + | E_and (a, b) -> Format.fprintf out "(@[and@ %a@ %a@])" pp a pp b + +let mk_trivial : t = E_trivial +let[@inline] mk_congruence n1 n2 : t = E_congruence (n1, n2) + +let[@inline] mk_merge a b : t = + if E_node.equal a b then + mk_trivial + else + E_merge (a, b) + +let[@inline] mk_merge_t a b : t = + if Term.equal a b then + mk_trivial + else + E_merge_t (a, b) + +let[@inline] mk_lit l : t = E_lit l +let[@inline] mk_theory t u es pr = E_theory (t, u, es, pr) + +let rec mk_list l = + match l with + | [] -> mk_trivial + | [ x ] -> x + | E_trivial :: tl -> mk_list tl + | x :: y -> + (match mk_list y with + | E_trivial -> x + | y' -> E_and (x, y')) diff --git a/src/cc/expl.mli b/src/cc/expl.mli new file mode 100644 index 00000000..24618076 --- /dev/null +++ b/src/cc/expl.mli @@ -0,0 +1,47 @@ +(** Explanations + + Explanations are specialized proofs, created by the congruence closure + when asked to justify why two terms are equal. *) + +open Types_ + +type t = Types_.explanation + +include Sidekick_sigs.PRINT with type t := t + +val mk_merge : E_node.t -> E_node.t -> t +(** Explanation: the nodes were explicitly merged *) + +val mk_merge_t : Term.t -> Term.t -> t +(** Explanation: the terms were explicitly merged *) + +val mk_lit : Lit.t -> t +(** Explanation: we merged [t] and [u] because of literal [t=u], + or we merged [t] and [true] because of literal [t], + or [t] and [false] because of literal [¬t] *) + +val mk_list : t list -> t +(** Conjunction of explanations *) + +val mk_congruence : E_node.t -> E_node.t -> t + +val mk_theory : + Term.t -> Term.t -> (Term.t * Term.t * t list) list -> Proof_term.step_id -> t +(** [mk_theory t u expl_sets pr] builds a theory explanation for + why [|- t=u]. It depends on sub-explanations [expl_sets] which + are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are + explanations that justify [t_i = u_i] in the current congruence closure. + + The proof [pr] is the theory lemma, of the form + [ (t_i = u_i)_i |- t=u ]. + It is resolved against each [expls_i |- t_i=u_i] obtained from + [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] + where [Gamma] is a subset of the literals asserted into the congruence + closure. + + For example for the lemma [a=b] deduced by injectivity + from [Some a=Some b] in the theory of datatypes, + the arguments would be + [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] + where [pr] is the injectivity lemma [Some a=Some b |- a=b]. + *) diff --git a/src/cc/plugin/sidekick_cc_plugin.ml b/src/cc/plugin.ml similarity index 90% rename from src/cc/plugin/sidekick_cc_plugin.ml rename to src/cc/plugin.ml index 39327e1e..8c25c203 100644 --- a/src/cc/plugin/sidekick_cc_plugin.ml +++ b/src/cc/plugin.ml @@ -1,16 +1,16 @@ -open Sidekick_core -open Sidekick_cc +open Types_ +open Sigs_plugin module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER - val mem : t -> M.CC.E_node.t -> bool - (** Does the CC E_node.t have a monoid value? *) + val mem : t -> E_node.t -> bool + (** Does the CC.E_node.t have a monoid value? *) - val get : t -> M.CC.E_node.t -> M.t option - (** Get monoid value for this CC E_node.t, if any *) + val get : t -> E_node.t -> M.t option + (** Get monoid value for this CC.E_node.t, if any *) - val iter_all : t -> (M.CC.repr * M.t) Iter.t + val iter_all : t -> (CC.repr * M.t) Iter.t include Sidekick_sigs.BACKTRACKABLE0 with type t := t include Sidekick_sigs.PRINT with type t := t @@ -19,10 +19,7 @@ end module Make (M : MONOID_PLUGIN_ARG) : EXTENDED_PLUGIN_BUILDER with module M = M = struct module M = M - module CC = M.CC - module E_node = CC.E_node module Cls_tbl = Backtrackable_tbl.Make (E_node) - module Expl = CC.Expl module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M @@ -40,7 +37,7 @@ module Make (M : MONOID_PLUGIN_ARG) : let values : M.t Cls_tbl.t = Cls_tbl.create ?size () (* bit in CC to filter out quickly classes without value *) - let field_has_value : CC.E_node.bitfield = + let field_has_value : CC.bitfield = CC.allocate_bitfield ~descr:("monoid." ^ M.name ^ ".has-value") cc let push_level () = Cls_tbl.push_level values @@ -91,7 +88,7 @@ module Make (M : MONOID_PLUGIN_ARG) : | Error (CC.Handler_action.Conflict expl) -> Error.errorf "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" - E_node.pp n_u M.pp m_u M.pp m_u' CC.Expl.pp expl + E_node.pp n_u M.pp m_u M.pp m_u' Expl.pp expl | Ok (m_u_merged, merge_acts) -> acts := List.rev_append merge_acts !acts; Log.debugf 20 (fun k -> @@ -111,7 +108,7 @@ module Make (M : MONOID_PLUGIN_ARG) : let iter_all : _ Iter.t = Cls_tbl.to_iter values let on_pre_merge cc n1 n2 e_n1_n2 : CC.Handler_action.or_conflict = - let exception E of M.CC.Handler_action.conflict in + let exception E of CC.Handler_action.conflict in let acts = ref [] in try (match get n1, get n2 with diff --git a/src/cc/plugin/sidekick_cc_plugin.mli b/src/cc/plugin.mli similarity index 76% rename from src/cc/plugin/sidekick_cc_plugin.mli rename to src/cc/plugin.mli index 413d8408..687e1d26 100644 --- a/src/cc/plugin/sidekick_cc_plugin.mli +++ b/src/cc/plugin.mli @@ -1,17 +1,17 @@ (** Congruence Closure Plugin *) -open Sidekick_cc +open Sigs_plugin module type EXTENDED_PLUGIN_BUILDER = sig include MONOID_PLUGIN_BUILDER - val mem : t -> M.CC.E_node.t -> bool + val mem : t -> E_node.t -> bool (** Does the CC.E_node.t have a monoid value? *) - val get : t -> M.CC.E_node.t -> M.t option + val get : t -> E_node.t -> M.t option (** Get monoid value for this CC.E_node.t, if any *) - val iter_all : t -> (M.CC.repr * M.t) Iter.t + val iter_all : t -> (CC.repr * M.t) Iter.t include Sidekick_sigs.BACKTRACKABLE0 with type t := t include Sidekick_sigs.PRINT with type t := t diff --git a/src/cc/resolved_expl.ml b/src/cc/resolved_expl.ml new file mode 100644 index 00000000..c16c1edd --- /dev/null +++ b/src/cc/resolved_expl.ml @@ -0,0 +1,6 @@ +open Types_ + +type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } + +let pp out (self : t) = + Fmt.fprintf out "(@[resolved-expl@ %a@])" (Util.pp_list Lit.pp) self.lits diff --git a/src/cc/resolved_expl.mli b/src/cc/resolved_expl.mli new file mode 100644 index 00000000..537a11be --- /dev/null +++ b/src/cc/resolved_expl.mli @@ -0,0 +1,17 @@ +(** Resolved explanations. + + The congruence closure keeps explanations for why terms are in the same + class. However these are represented in a compact, cheap form. + To use these explanations we need to {b resolve} them into a + resolved explanation, typically a list of + literals that are true in the current trail and are responsible for + merges. + + However, we can also have merged classes because they have the same value + in the current model. *) + +open Types_ + +type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } + +include Sidekick_sigs.PRINT with type t := t diff --git a/src/cc/signature.ml b/src/cc/signature.ml new file mode 100644 index 00000000..8fdc5ee7 --- /dev/null +++ b/src/cc/signature.ml @@ -0,0 +1,53 @@ +(** A signature is a shallow term shape where immediate subterms + are representative *) + +open View +open Types_ + +type t = signature + +let equal (s1 : t) s2 : bool = + let open View in + match s1, s2 with + | Bool b1, Bool b2 -> b1 = b2 + | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 + | App_fun (f1, l1), App_fun (f2, l2) -> + Const.equal f1 f2 && CCList.equal E_node.equal l1 l2 + | App_ho (f1, a1), App_ho (f2, a2) -> E_node.equal f1 f2 && E_node.equal a1 a2 + | Not a, Not b -> E_node.equal a b + | If (a1, b1, c1), If (a2, b2, c2) -> + E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 + | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 + | Opaque u1, Opaque u2 -> E_node.equal u1 u2 + | Bool _, _ + | App_fun _, _ + | App_ho _, _ + | If _, _ + | Eq _, _ + | Opaque _, _ + | Not _, _ -> + false + +let hash (s : t) : int = + let module H = CCHash in + match s with + | Bool b -> H.combine2 10 (H.bool b) + | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list E_node.hash l) + | App_ho (f, a) -> H.combine3 30 (E_node.hash f) (E_node.hash a) + | Eq (a, b) -> H.combine3 40 (E_node.hash a) (E_node.hash b) + | Opaque u -> H.combine2 50 (E_node.hash u) + | If (a, b, c) -> + H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) + | Not u -> H.combine2 70 (E_node.hash u) + +let pp out = function + | Bool b -> Fmt.bool out b + | App_fun (f, []) -> Const.pp out f + | App_fun (f, l) -> + Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list E_node.pp) l + | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" E_node.pp f E_node.pp a + | Opaque t -> E_node.pp out t + | Not u -> Fmt.fprintf out "(@[not@ %a@])" E_node.pp u + | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" E_node.pp a E_node.pp b + | If (a, b, c) -> + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" E_node.pp a E_node.pp b E_node.pp c diff --git a/src/cc/sigs.ml b/src/cc/sigs.ml index 20541c45..fd0fbed3 100644 --- a/src/cc/sigs.ml +++ b/src/cc/sigs.ml @@ -2,505 +2,3 @@ open Sidekick_core module View = View - -(** Arguments to a congruence closure's implementation *) -module type ARG = sig - val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t - (** View the Term.t through the lens of the congruence closure *) -end - -(** Collection of input types, and types defined by the congruence closure *) -module type ARGS_CLASSES_EXPL_EVENT = sig - (** E-node. - - An e-node is a node in the congruence closure that is contained - in some equivalence classe). - An equivalence class is a set of terms that are currently equal - in the partial model built by the solver. - The class is represented by a collection of nodes, one of which is - distinguished and is called the "representative". - - All information pertaining to the whole equivalence class is stored - in its representative's {!E_node.t}. - - When two classes become equal (are "merged"), one of the two - representatives is picked as the representative of the new class. - The new class contains the union of the two old classes' nodes. - - We also allow theories to store additional information in the - representative. This information can be used when two classes are - merged, to detect conflicts and solve equations à la Shostak. - *) - module E_node : sig - type t - (** An E-node. - - A value of type [t] points to a particular Term.t, but see - {!find} to get the representative of the class. *) - - include Sidekick_sigs.PRINT with type t := t - - val term : t -> Term.t - (** Term contained in this equivalence class. - If [is_root n], then [Term.t n] is the class' representative Term.t. *) - - val equal : t -> t -> bool - (** Are two classes {b physically} equal? To check for - logical equality, use [CC.E_node.equal (CC.find cc n1) (CC.find cc n2)] - which checks for equality of representatives. *) - - val hash : t -> int - (** An opaque hash of this E_node.t. *) - - val is_root : t -> bool - (** Is the E_node.t a root (ie the representative of its class)? - See {!find} to get the root. *) - - val iter_class : t -> t Iter.t - (** Traverse the congruence class. - Precondition: [is_root n] (see {!find} below) *) - - val iter_parents : t -> t Iter.t - (** Traverse the parents of the class. - Precondition: [is_root n] (see {!find} below) *) - - (* FIXME: - [@@alert refactor "this should be replaced with a Per_class concept"] - *) - - type bitfield - (** A field in the bitfield of this node. This should only be - allocated when a theory is initialized. - - Bitfields are accessed using preallocated keys. - See {!CC_S.allocate_bitfield}. - - All fields are initially 0, are backtracked automatically, - and are merged automatically when classes are merged. *) - end - - (** Explanations - - Explanations are specialized proofs, created by the congruence closure - when asked to justify why two terms are equal. *) - module Expl : sig - type t - - include Sidekick_sigs.PRINT with type t := t - - val mk_merge : E_node.t -> E_node.t -> t - (** Explanation: the nodes were explicitly merged *) - - val mk_merge_t : Term.t -> Term.t -> t - (** Explanation: the terms were explicitly merged *) - - val mk_lit : Lit.t -> t - (** Explanation: we merged [t] and [u] because of literal [t=u], - or we merged [t] and [true] because of literal [t], - or [t] and [false] because of literal [¬t] *) - - val mk_list : t list -> t - (** Conjunction of explanations *) - - val mk_theory : - Term.t -> - Term.t -> - (Term.t * Term.t * t list) list -> - Proof_term.step_id -> - t - (** [mk_theory t u expl_sets pr] builds a theory explanation for - why [|- t=u]. It depends on sub-explanations [expl_sets] which - are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are - explanations that justify [t_i = u_i] in the current congruence closure. - - The proof [pr] is the theory lemma, of the form - [ (t_i = u_i)_i |- t=u ]. - It is resolved against each [expls_i |- t_i=u_i] obtained from - [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] - where [Gamma] is a subset of the literals asserted into the congruence - closure. - - For example for the lemma [a=b] deduced by injectivity - from [Some a=Some b] in the theory of datatypes, - the arguments would be - [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] - where [pr] is the injectivity lemma [Some a=Some b |- a=b]. - *) - end - - (** Resolved explanations. - - The congruence closure keeps explanations for why terms are in the same - class. However these are represented in a compact, cheap form. - To use these explanations we need to {b resolve} them into a - resolved explanation, typically a list of - literals that are true in the current trail and are responsible for - merges. - - However, we can also have merged classes because they have the same value - in the current model. *) - module Resolved_expl : sig - type t = { lits: Lit.t list; pr: Proof_trace.t -> Proof_term.step_id } - - include Sidekick_sigs.PRINT with type t := t - end - - (** Per-node data *) - - type e_node = E_node.t - (** A node of the congruence closure *) - - type repr = E_node.t - (** Node that is currently a representative. *) - - type explanation = Expl.t -end - -(** Main congruence closure signature. - - The congruence closure handles the theory QF_UF (uninterpreted - function symbols). - It is also responsible for {i theory combination}, and provides - a general framework for equality reasoning that other - theories piggyback on. - - For example, the theory of datatypes relies on the congruence closure - to do most of the work, and "only" adds injectivity/disjointness/acyclicity - lemmas when needed. - - Similarly, a theory of arrays would hook into the congruence closure and - assert (dis)equalities as needed. -*) -module type S = sig - include ARGS_CLASSES_EXPL_EVENT - - type t - (** The congruence closure object. - It contains a fair amount of state and is mutable - and backtrackable. *) - - (** {3 Accessors} *) - - val term_store : t -> Term.store - val proof : t -> Proof_trace.t - - val find : t -> e_node -> repr - (** Current representative *) - - val add_term : t -> Term.t -> e_node - (** Add the Term.t to the congruence closure, if not present already. - Will be backtracked. *) - - val mem_term : t -> Term.t -> bool - (** Returns [true] if the Term.t is explicitly present in the congruence closure *) - - val allocate_bitfield : t -> descr:string -> E_node.bitfield - (** Allocate a new e_node field (see {!E_node.bitfield}). - - This field descriptor is henceforth reserved for all nodes - in this congruence closure, and can be set using {!set_bitfield} - for each class_ individually. - This can be used to efficiently store some metadata on nodes - (e.g. "is there a numeric value in the class" - or "is there a constructor Term.t in the class"). - - There may be restrictions on how many distinct fields are allocated - for a given congruence closure (e.g. at most {!Sys.int_size} fields). - *) - - val get_bitfield : t -> E_node.bitfield -> E_node.t -> bool - (** Access the bit field of the given e_node *) - - val set_bitfield : t -> E_node.bitfield -> bool -> E_node.t -> unit - (** Set the bitfield for the e_node. This will be backtracked. - See {!E_node.bitfield}. *) - - type propagation_reason = unit -> Lit.t list * Proof_term.step_id - - (** Handler Actions - - Actions that can be scheduled by event handlers. *) - module Handler_action : sig - type t = - | Act_merge of E_node.t * E_node.t * Expl.t - | Act_propagate of Lit.t * propagation_reason - - (* TODO: - - an action to modify data associated with a class - *) - - type conflict = Conflict of Expl.t [@@unboxed] - - type or_conflict = (t list, conflict) result - (** Actions or conflict scheduled by an event handler. - - - [Ok acts] is a list of merges and propagations - - [Error confl] is a conflict to resolve. - *) - end - - (** Result Actions. - - - Actions returned by the congruence closure after calling {!check}. *) - module Result_action : sig - type t = - | Act_propagate of { lit: Lit.t; reason: propagation_reason } - (** [propagate (Lit.t, reason)] declares that [reason() => Lit.t] - is a tautology. - - - [reason()] should return a list of literals that are currently true, - as well as a proof. - - [Lit.t] should be a literal of interest (see {!S.set_as_lit}). - - This function might never be called, a congruence closure has the right - to not propagate and only trigger conflicts. *) - - type conflict = - | Conflict of Lit.t list * Proof_term.step_id - (** [raise_conflict (c,pr)] declares that [c] is a tautology of - the theory of congruence. - @param pr the proof of [c] being a tautology *) - - type or_conflict = (t list, conflict) result - end - - (** {3 Events} - - Events triggered by the congruence closure, to which - other plugins can subscribe. *) - - (** Events emitted by the congruence closure when something changes. *) - val on_pre_merge : - t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t - (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] - and [n2] are merged with explanation [expl]. *) - - val on_pre_merge2 : - t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t - (** Second phase of "on pre merge". This runs after {!on_pre_merge} - and is used by Plugins. {b NOTE}: Plugin state might be observed as already - changed in these handlers. *) - - val on_post_merge : - t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t - (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] - and [n2] were merged. [find cc n1] and [find cc n2] will return - the same E_node.t. *) - - val on_new_term : t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t - (** [ev_on_new_term n t] is emitted whenever a new Term.t [t] - is added to the congruence closure. Its E_node.t is [n]. *) - - type ev_on_conflict = { cc: t; th: bool; c: Lit.t list } - (** Event emitted when a conflict occurs in the CC. - - [th] is true if the explanation for this conflict involves - at least one "theory" explanation; i.e. some of the equations - participating in the conflict are purely syntactic theories - like injectivity of constructors. *) - - val on_conflict : t -> (ev_on_conflict, unit) Event.t - (** [ev_on_conflict {th; c}] is emitted when the congruence - closure triggers a conflict by asserting the tautology [c]. *) - - val on_propagate : - t -> - ( t * Lit.t * (unit -> Lit.t list * Proof_term.step_id), - Handler_action.t list ) - Event.t - (** [ev_on_propagate Lit.t reason] is emitted whenever [reason() => Lit.t] - is a propagated lemma. See {!CC_ACTIONS.propagate}. *) - - val on_is_subterm : - t -> (t * E_node.t * Term.t, Handler_action.t list) Event.t - (** [ev_on_is_subterm n t] is emitted when [n] is a subterm of - another E_node.t for the first time. [t] is the Term.t corresponding to - the E_node.t [n]. This can be useful for theory combination. *) - - (** {3 Misc} *) - - val n_true : t -> E_node.t - (** Node for [true] *) - - val n_false : t -> E_node.t - (** Node for [false] *) - - val n_bool : t -> bool -> E_node.t - (** Node for either true or false *) - - val set_as_lit : t -> E_node.t -> Lit.t -> unit - (** map the given e_node to a literal. *) - - val find_t : t -> Term.t -> repr - (** Current representative of the Term.t. - @raise E_node.t_found if the Term.t is not already {!add}-ed. *) - - val add_iter : t -> Term.t Iter.t -> unit - (** Add a sequence of terms to the congruence closure *) - - val all_classes : t -> repr Iter.t - (** All current classes. This is costly, only use if there is no other solution *) - - val explain_eq : t -> E_node.t -> E_node.t -> Resolved_expl.t - (** Explain why the two nodes are equal. - Fails if they are not, in an unspecified way. *) - - val explain_expl : t -> Expl.t -> Resolved_expl.t - (** Transform explanation into an actionable conflict clause *) - - (* FIXME: remove - val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a - (** Raise a conflict with the given explanation. - It must be a theory tautology that [expl ==> absurd]. - To be used in theories. - - This fails in an unspecified way if the explanation, once resolved, - satisfies {!Resolved_expl.is_semantic}. *) - *) - - val merge : t -> E_node.t -> E_node.t -> Expl.t -> unit - (** Merge these two nodes given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val merge_t : t -> Term.t -> Term.t -> Expl.t -> unit - (** Shortcut for adding + merging *) - - (** {3 Main API *) - - val assert_eq : t -> Term.t -> Term.t -> Expl.t -> unit - (** Assert that two terms are equal, using the given explanation. *) - - val assert_lit : t -> Lit.t -> unit - (** Given a literal, assume it in the congruence closure and propagate - its consequences. Will be backtracked. - - Useful for the theory combination or the SAT solver's functor *) - - val assert_lits : t -> Lit.t Iter.t -> unit - (** Addition of many literals *) - - val check : t -> Result_action.or_conflict - (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. - Will use the {!actions} to propagate literals, declare conflicts, etc. *) - - val push_level : t -> unit - (** Push backtracking level *) - - val pop_levels : t -> int -> unit - (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) - - val get_model : t -> E_node.t Iter.t Iter.t - (** get all the equivalence classes so they can be merged in the model *) - - val create : - ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t - (** Create a new congruence closure. - - @param term_store used to be able to create new terms. All terms - interacting with this congruence closure must belong in this term state - as well. - *) - - (**/**) - - module Debug_ : sig - val pp : t Fmt.printer - (** Print the whole CC *) - end - - (**/**) -end - -(* TODO: full EGG, also have a function to update the value when - the subterms (produced in [of_term]) are updated *) - -(** Data attached to the congruence closure classes. - - This helps theories keeping track of some state for each class. - The state of a class is the monoidal combination of the state for each - Term.t in the class (for example, the set of terms in the - class whose head symbol is a datatype constructor). *) -module type MONOID_PLUGIN_ARG = sig - module CC : S - - type t - (** Some type with a monoid structure *) - - include Sidekick_sigs.PRINT with type t := t - - val name : string - (** name of the monoid structure (short) *) - - (* FIXME: for subs, return list of e_nodes, and assume of_term already - returned data for them. *) - val of_term : - CC.t -> CC.E_node.t -> Term.t -> t option * (CC.E_node.t * t) list - (** [of_term n t], where [t] is the Term.t annotating node [n], - must return [maybe_m, l], where: - - - [maybe_m = Some m] if [t] has monoid value [m]; - otherwise [maybe_m=None] - - [l] is a list of [(u, m_u)] where each [u]'s Term.t - is a direct subterm of [t] - and [m_u] is the monoid value attached to [u]. - - *) - - val merge : - CC.t -> - CC.E_node.t -> - t -> - CC.E_node.t -> - t -> - CC.Expl.t -> - (t * CC.Handler_action.t list, CC.Handler_action.conflict) result - (** Monoidal combination of two values. - - [merge cc n1 mon1 n2 mon2 expl] returns the result of merging - monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) - when [n1] and [n2] are merged with explanation [expl]. - - @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; - or [Error expl'] if the merge is unsatisfiable. [expl'] can then be - used to trigger a conflict and undo the merge. - *) -end - -(** Stateful plugin holding a per-equivalence-class monoid. - - Helps keep track of monoid state per equivalence class. - A theory might use one or more instance(s) of this to - aggregate some theory-specific state over all terms, with - the information of what terms are already known to be equal - potentially saving work for the theory. *) -module type DYN_MONOID_PLUGIN = sig - module M : MONOID_PLUGIN_ARG - include Sidekick_sigs.DYN_BACKTRACKABLE - - val pp : unit Fmt.printer - - val mem : M.CC.E_node.t -> bool - (** Does the CC E_node.t have a monoid value? *) - - val get : M.CC.E_node.t -> M.t option - (** Get monoid value for this CC E_node.t, if any *) - - val iter_all : (M.CC.repr * M.t) Iter.t -end - -(** Builder for a plugin. - - The builder takes a congruence closure, and instantiate the - plugin on it. *) -module type MONOID_PLUGIN_BUILDER = sig - module M : MONOID_PLUGIN_ARG - - module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M - - type t = (module DYN_PL_FOR_M) - - val create_and_setup : ?size:int -> M.CC.t -> t - (** Create a new monoid state *) -end diff --git a/src/cc/sigs_plugin.ml b/src/cc/sigs_plugin.ml new file mode 100644 index 00000000..a1f0fe18 --- /dev/null +++ b/src/cc/sigs_plugin.ml @@ -0,0 +1,90 @@ +open Types_ + +(* TODO: full EGG, also have a function to update the value when + the subterms (produced in [of_term]) are updated *) + +(** Data attached to the congruence closure classes. + + This helps theories keeping track of some state for each class. + The state of a class is the monoidal combination of the state for each + Term.t in the class (for example, the set of terms in the + class whose head symbol is a datatype constructor). *) +module type MONOID_PLUGIN_ARG = sig + type t + (** Some type with a monoid structure *) + + include Sidekick_sigs.PRINT with type t := t + + val name : string + (** name of the monoid structure (short) *) + + (* FIXME: for subs, return list of e_nodes, and assume of_term already + returned data for them. *) + val of_term : CC.t -> E_node.t -> Term.t -> t option * (E_node.t * t) list + (** [of_term n t], where [t] is the Term.t annotating node [n], + must return [maybe_m, l], where: + + - [maybe_m = Some m] if [t] has monoid value [m]; + otherwise [maybe_m=None] + - [l] is a list of [(u, m_u)] where each [u]'s Term.t + is a direct subterm of [t] + and [m_u] is the monoid value attached to [u]. + + *) + + val merge : + CC.t -> + E_node.t -> + t -> + E_node.t -> + t -> + Expl.t -> + (t * CC.Handler_action.t list, CC.Handler_action.conflict) result + (** Monoidal combination of two values. + + [merge cc n1 mon1 n2 mon2 expl] returns the result of merging + monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) + when [n1] and [n2] are merged with explanation [expl]. + + @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; + or [Error expl'] if the merge is unsatisfiable. [expl'] can then be + used to trigger a conflict and undo the merge. + *) +end + +(** Stateful plugin holding a per-equivalence-class monoid. + + Helps keep track of monoid state per equivalence class. + A theory might use one or more instance(s) of this to + aggregate some theory-specific state over all terms, with + the information of what terms are already known to be equal + potentially saving work for the theory. *) +module type DYN_MONOID_PLUGIN = sig + module M : MONOID_PLUGIN_ARG + include Sidekick_sigs.DYN_BACKTRACKABLE + + val pp : unit Fmt.printer + + val mem : E_node.t -> bool + (** Does the CC E_node.t have a monoid value? *) + + val get : E_node.t -> M.t option + (** Get monoid value for this CC E_node.t, if any *) + + val iter_all : (CC.repr * M.t) Iter.t +end + +(** Builder for a plugin. + + The builder takes a congruence closure, and instantiate the + plugin on it. *) +module type MONOID_PLUGIN_BUILDER = sig + module M : MONOID_PLUGIN_ARG + + module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M + + type t = (module DYN_PL_FOR_M) + + val create_and_setup : ?size:int -> CC.t -> t + (** Create a new monoid state *) +end diff --git a/src/cc/types_.ml b/src/cc/types_.ml new file mode 100644 index 00000000..c1e1bae1 --- /dev/null +++ b/src/cc/types_.ml @@ -0,0 +1,39 @@ +include Sidekick_core + +type e_node = { + n_term: Term.t; + mutable n_sig0: signature option; (* initial signature *) + mutable n_bits: Bits.t; (* bitfield for various properties *) + mutable n_parents: e_node Bag.t; (* parent terms of this node *) + mutable n_root: e_node; + (* representative of congruence class (itself if a representative) *) + mutable n_next: e_node; (* pointer to next element of congruence class *) + mutable n_size: int; (* size of the class *) + mutable n_as_lit: Lit.t option; + (* TODO: put into payload? and only in root? *) + mutable n_expl: explanation_forest_link; + (* the rooted forest for explanations *) +} +(** A node of the congruence closure. + An equivalence class is represented by its "root" element, + the representative. *) + +and signature = (Const.t, e_node, e_node list) View.t + +and explanation_forest_link = + | FL_none + | FL_some of { next: e_node; expl: explanation } + +(* atomic explanation in the congruence closure *) +and explanation = + | E_trivial (* by pure reduction, tautologically equal *) + | E_lit of Lit.t (* because of this literal *) + | E_merge of e_node * e_node + | E_merge_t of Term.t * Term.t + | E_congruence of e_node * e_node (* caused by normal congruence *) + | E_and of explanation * explanation + | E_theory of + Term.t + * Term.t + * (Term.t * Term.t * explanation list) list + * Proof_term.step_id From 7595f66e590fa5745f2b66d712f6956bac06e757 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 29 Jul 2022 23:27:04 -0400 Subject: [PATCH 045/174] refactor(core): add Proof_step --- src/core/Sidekick_core.ml | 1 + src/core/proof_step.ml | 3 +++ src/core/proof_term.ml | 2 +- src/core/proof_term.mli | 2 +- src/core/proof_trace.ml | 2 +- src/core/proof_trace.mli | 2 +- 6 files changed, 8 insertions(+), 4 deletions(-) create mode 100644 src/core/proof_step.ml diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index fa8d7b4c..8e78ae4c 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -25,6 +25,7 @@ end module Bvar = Sidekick_core_logic.Bvar module Lit = Lit +module Proof_step = Proof_step module Proof_core = Proof_core module Proof_sat = Proof_sat module Proof_trace = Proof_trace diff --git a/src/core/proof_step.ml b/src/core/proof_step.ml new file mode 100644 index 00000000..f814bcaf --- /dev/null +++ b/src/core/proof_step.ml @@ -0,0 +1,3 @@ +type id = int32 + +let pp = Fmt.int32 diff --git a/src/core/proof_term.ml b/src/core/proof_term.ml index d8ec7882..0600a51a 100644 --- a/src/core/proof_term.ml +++ b/src/core/proof_term.ml @@ -1,6 +1,6 @@ open Sidekick_core_logic -type step_id = int32 +type step_id = Proof_step.id type lit = Lit.t type t = { diff --git a/src/core/proof_term.mli b/src/core/proof_term.mli index 9b56cb97..81ef09c3 100644 --- a/src/core/proof_term.mli +++ b/src/core/proof_term.mli @@ -4,7 +4,7 @@ open Sidekick_core_logic -type step_id = int32 +type step_id = Proof_step.id type lit = Lit.t type t = { diff --git a/src/core/proof_trace.ml b/src/core/proof_trace.ml index 50aac799..ea51bf3d 100644 --- a/src/core/proof_trace.ml +++ b/src/core/proof_trace.ml @@ -1,5 +1,5 @@ type lit = Lit.t -type step_id = int32 +type step_id = Proof_step.id type proof_term = Proof_term.t module Step_vec = struct diff --git a/src/core/proof_trace.mli b/src/core/proof_trace.mli index 19cf533e..0a3c563b 100644 --- a/src/core/proof_trace.mli +++ b/src/core/proof_trace.mli @@ -10,7 +10,7 @@ open Sidekick_core_logic type lit = Lit.t -type step_id = Proof_term.step_id +type step_id = Proof_step.id (** Identifier for a tracing step (like a unique ID for a clause previously added/proved) *) From b97582daa26e875e31e7e72f9a10c8d3d7fb8bf4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 00:19:29 -0400 Subject: [PATCH 046/174] wip: refactor(smt): remove layers of functors, split into modules --- src/smt/Sidekick_smt_solver.ml | 14 + src/smt/dune | 7 + src/smt/model.ml | 24 ++ src/smt/registry.ml | 37 ++ src/smt/registry.mli | 14 + src/smt/sigs.ml | 48 +++ src/smt/simplify.ml | 81 +++++ src/smt/simplify.mli | 39 +++ src/smt/solver.ml | 261 ++++++++++++++ src/smt/solver.mli | 189 ++++++++++ src/smt/solver_internal.ml | 608 +++++++++++++++++++++++++++++++++ src/smt/solver_internal.mli | 256 ++++++++++++++ src/smt/th_key.ml.bak | 145 ++++++++ src/smt/theory.ml | 44 +++ 14 files changed, 1767 insertions(+) create mode 100644 src/smt/Sidekick_smt_solver.ml create mode 100644 src/smt/dune create mode 100644 src/smt/model.ml create mode 100644 src/smt/registry.ml create mode 100644 src/smt/registry.mli create mode 100644 src/smt/sigs.ml create mode 100644 src/smt/simplify.ml create mode 100644 src/smt/simplify.mli create mode 100644 src/smt/solver.ml create mode 100644 src/smt/solver.mli create mode 100644 src/smt/solver_internal.ml create mode 100644 src/smt/solver_internal.mli create mode 100644 src/smt/th_key.ml.bak create mode 100644 src/smt/theory.ml diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml new file mode 100644 index 00000000..9ab1530d --- /dev/null +++ b/src/smt/Sidekick_smt_solver.ml @@ -0,0 +1,14 @@ +(** Core of the SMT solver using Sidekick_sat + + Sidekick_sat (in src/sat/) is a modular SAT solver in + pure OCaml. + + This builds a SMT solver on top of it. +*) + +module Sigs = Sigs +module Model = Model +module Registry = Registry +module Simplify = Simplify +module Solver_internal = Solver_internal +module Solver = Solver diff --git a/src/smt/dune b/src/smt/dune new file mode 100644 index 00000000..0e86c9da --- /dev/null +++ b/src/smt/dune @@ -0,0 +1,7 @@ +(library + (name Sidekick_smt_solver) + (public_name sidekick.smt-solver) + (synopsis "main SMT solver") + (libraries containers iter sidekick.core sidekick.util sidekick.cc + sidekick.sat) + (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/smt/model.ml b/src/smt/model.ml new file mode 100644 index 00000000..34cba314 --- /dev/null +++ b/src/smt/model.ml @@ -0,0 +1,24 @@ +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) diff --git a/src/smt/registry.ml b/src/smt/registry.ml new file mode 100644 index 00000000..f2450d1b --- /dev/null +++ b/src/smt/registry.ml @@ -0,0 +1,37 @@ + + (* registry keys *) + module type KEY = sig + type elt + + val id : int + + exception E of elt + end + + type 'a key = (module KEY with type elt = 'a) + type t = { tbl: exn Util.Int_tbl.t } [@@unboxed] + + let create () : t = { tbl = Util.Int_tbl.create 8 } + let n_ = ref 0 + + let create_key (type a) () : a key = + let id = !n_ in + incr n_; + let module K = struct + type elt = a + + exception E of a + + let id = id + end in + (module K) + + let get (type a) (self : t) (k : a key) : _ option = + let (module K : KEY with type elt = a) = k in + match Util.Int_tbl.get self.tbl K.id with + | Some (K.E x) -> Some x + | _ -> None + + let set (type a) (self : t) (k : a key) (v : a) : unit = + let (module K) = k in + Util.Int_tbl.replace self.tbl K.id (K.E v) diff --git a/src/smt/registry.mli b/src/smt/registry.mli new file mode 100644 index 00000000..0e41bcac --- /dev/null +++ b/src/smt/registry.mli @@ -0,0 +1,14 @@ + + +(** Registry to extract values *) + + type t + type 'a key + + val create_key : unit -> 'a key + (** Call this statically, typically at program initialization, for + each distinct key. *) + + val create : unit -> t + val get : t -> 'a key -> 'a option + val set : t -> 'a key -> 'a -> unit diff --git a/src/smt/sigs.ml b/src/smt/sigs.ml new file mode 100644 index 00000000..fb0ba9b6 --- /dev/null +++ b/src/smt/sigs.ml @@ -0,0 +1,48 @@ +(** Signature for the main SMT solver types. + + Theories and concrete solvers rely on an environment that defines + several important types: + + - sorts + - terms (to represent logic expressions and formulas) + - a congruence closure instance + - a bridge to some SAT solver + + In this module we collect signatures defined elsewhere and define + the module types for the main SMT solver. +*) + +include Sidekick_core +module CC = Sidekick_cc.CC +module E_node = Sidekick_cc.E_node +module CC_expl = Sidekick_cc.Expl + +type term = Term.t +type ty = term +type value = Term.t +type lit = Lit.t +type term_store = Term.store +type proof_trace = Proof_trace.t +type step_id = Proof_step.id + +(* actions from the sat solver *) +type sat_acts = Sidekick_sat.acts + +type th_combination_conflict = { + lits: lit list; + semantic: (bool * term * term) list; + (* set of semantic eqns/diseqns (ie true only in current model) *) +} +(** Conflict obtained during theory combination. It involves equalities + merged because of the current model so it's not a "true" conflict + and doesn't need to kill the current trail. *) + +(** Argument to pass to the functor {!Make} in order to create a + new Msat-based SMT solver. *) +module type ARG = sig + val view_as_cc : Sidekick_cc.view_as_cc + + val is_valid_literal : Term.t -> bool + (** Is this a valid boolean literal? (e.g. is it a closed term, not inside + a quantifier) *) +end diff --git a/src/smt/simplify.ml b/src/smt/simplify.ml new file mode 100644 index 00000000..2bbd3da8 --- /dev/null +++ b/src/smt/simplify.ml @@ -0,0 +1,81 @@ +open Sidekick_core +open Sigs + +open struct + module P = Proof_trace + module Rule_ = Proof_core +end + +type t = { + tst: term_store; + proof: proof_trace; + mutable hooks: hook list; + (* store [t --> u by step_ids] in the cache. + We use a bag for the proof steps because it gives us structural + sharing of subproofs. *) + cache: (Term.t * step_id Bag.t) Term.Tbl.t; +} + +and hook = t -> term -> (term * step_id Iter.t) option + +let create tst ~proof : t = + { tst; proof; hooks = []; cache = Term.Tbl.create 32 } + +let[@inline] tst self = self.tst +let[@inline] proof self = self.proof +let add_hook self f = self.hooks <- f :: self.hooks +let clear self = Term.Tbl.clear self.cache + +let normalize (self : t) (t : Term.t) : (Term.t * step_id) option = + (* compute and cache normal form of [t] *) + let rec loop t : Term.t * _ Bag.t = + match Term.Tbl.find self.cache t with + | res -> res + | exception Not_found -> + let steps_u = ref Bag.empty in + let u = aux_rec ~steps:steps_u t self.hooks in + Term.Tbl.add self.cache t (u, !steps_u); + u, !steps_u + and loop_add ~steps t = + let u, pr_u = loop t in + steps := Bag.append !steps pr_u; + u + (* try each function in [hooks] successively, and rewrite subterms *) + and aux_rec ~steps t hooks : Term.t = + match hooks with + | [] -> + let u = + Term.map_shallow self.tst ~f:(fun _inb u -> loop_add ~steps u) t + in + if Term.equal t u then + t + else + loop_add ~steps u + | h :: hooks_tl -> + (match h self t with + | None -> aux_rec ~steps t hooks_tl + | Some (u, _) when Term.equal t u -> aux_rec ~steps t hooks_tl + | Some (u, pr_u) -> + let bag_u = Bag.of_iter pr_u in + steps := Bag.append !steps bag_u; + let v, pr_v = loop u in + (* fixpoint *) + steps := Bag.append !steps pr_v; + v) + in + let u, pr_u = loop t in + if Term.equal t u then + None + else ( + (* proof: [sub_proofs |- t=u] by CC + subproof *) + let step = + P.add_step self.proof + @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) + in + Some (u, step) + ) + +let normalize_t self t = + match normalize self t with + | Some (u, pr_u) -> u, Some pr_u + | None -> t, None diff --git a/src/smt/simplify.mli b/src/smt/simplify.mli new file mode 100644 index 00000000..4ecccd29 --- /dev/null +++ b/src/smt/simplify.mli @@ -0,0 +1,39 @@ +(** Term simplifier *) + +open Sidekick_core +open Sigs + +type t + +val tst : t -> term_store + +val clear : t -> unit +(** Reset internal cache, etc. *) + +val proof : t -> proof_trace +(** Access proof *) + +type hook = t -> term -> (term * step_id Iter.t) option +(** Given a term, try to simplify it. Return [None] if it didn't change. + + A simple example could be a hook that takes a term [t], + and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, + returns [Some (const (x+y))], and [None] otherwise. + + The simplifier will take care of simplifying the resulting term further, + caching (so that work is not duplicated in subterms), etc. + *) + +val add_hook : t -> hook -> unit + +val normalize : t -> term -> (term * step_id) option +(** Normalize a term using all the hooks. This performs + a fixpoint, i.e. it only stops when no hook applies anywhere inside + the term. *) + +val normalize_t : t -> term -> term * step_id option +(** Normalize a term using all the hooks, along with a proof that the + simplification is correct. + returns [t, ø] if no simplification occurred. *) + +val create : Term.store -> proof:Proof_trace.t -> t diff --git a/src/smt/solver.ml b/src/smt/solver.ml new file mode 100644 index 00000000..f4741fb8 --- /dev/null +++ b/src/smt/solver.ml @@ -0,0 +1,261 @@ +open Sigs + +open struct + module P = Proof_trace + module Rule_ = Proof_core +end + +(* TODO + let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = + let (module A) = a in + + (module struct + module T = T + module Lit = Lit + + type nonrec lit = lit + type nonrec term = term + type nonrec proof_trace = Proof_trace.t + type nonrec step_id = step_id + + let proof_trace () = pr + let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr + + let[@inline] raise_semantic_conflict lits semantic = + raise (Semantic_conflict { lits; semantic }) + + let[@inline] propagate lit ~reason = + let reason = Sidekick_sat.Consequence reason in + A.propagate lit reason + end) +*) + +module Sat_solver = Sidekick_sat.Make_cdcl_t (Solver_internal) +(** the parametrized SAT Solver *) + +(** {2 Result} *) + +module Unknown = struct + type t = U_timeout | U_max_depth | U_incomplete | U_asked_to_stop + + let pp out = function + | U_timeout -> Fmt.string out {|"timeout"|} + | U_max_depth -> Fmt.string out {|"max depth reached"|} + | U_incomplete -> Fmt.string out {|"incomplete fragment"|} + | U_asked_to_stop -> Fmt.string out {|"asked to stop by callback"|} +end +[@@ocaml.warning "-37"] + +type res = + | Sat of Model.t + | Unsat of { + unsat_core: unit -> lit Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_step_id: unit -> step_id option; + (** Proof step for the empty clause *) + } + | Unknown of Unknown.t + (** Result of solving for the current set of clauses *) + +(* main solver state *) +type t = { + si: Solver_internal.t; + solver: Sat_solver.t; + mutable last_res: res option; + stat: Stat.t; + proof: P.t; + count_clause: int Stat.counter; + count_solve: int Stat.counter; (* config: Config.t *) +} + +type solver = t + +(** {2 Main} *) + +type theory = Theory.t + +let mk_theory = Theory.make + +let add_theory_p (type a) (self : t) (th : a Theory.p) : a = + let (module Th) = th in + Log.debugf 2 (fun k -> k "(@[smt-solver.add-theory@ :name %S@])" Th.name); + let st = Th.create_and_setup self.si in + (* add push/pop to the internal solver *) + Solver_internal.add_theory_state self.si ~st ~push_level:Th.push_level + ~pop_levels:Th.pop_levels; + st + +let add_theory (self : t) (th : theory) : unit = + let (module Th) = th in + ignore (add_theory_p self (module Th)) + +let add_theory_l self = List.iter (add_theory self) + +(* create a new solver *) +let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = + Log.debug 5 "smt-solver.create"; + let si = Solver_internal.create arg ~stat ~proof tst () in + let self = + { + si; + proof; + last_res = None; + solver = Sat_solver.create ~proof ?size ~stat si; + stat; + count_clause = Stat.mk_int stat "solver.add-clause"; + count_solve = Stat.mk_int stat "solver.solve"; + } + in + add_theory_l self theories; + (* assert [true] and [not false] *) + (let tst = Solver_internal.tst self.si in + let t_true = Term.true_ tst in + Sat_solver.add_clause self.solver + [ Lit.atom t_true ] + (P.add_step self.proof @@ Rule_.lemma_true t_true)); + self + +let[@inline] solver self = self.solver +let[@inline] cc self = Solver_internal.cc self.si +let[@inline] stats self = self.stat +let[@inline] tst self = Solver_internal.tst self.si +let[@inline] proof self = self.proof +let[@inline] last_res self = self.last_res +let[@inline] registry self = Solver_internal.registry self.si +let reset_last_res_ self = self.last_res <- None + +(* preprocess clause, return new proof *) +let preprocess_clause_ (self : t) (c : lit array) (pr : step_id) : + lit array * step_id = + Solver_internal.preprocess_clause_iarray_ self.si c pr + +let mk_lit_t (self : t) ?sign (t : term) : lit = + let lit = Lit.atom ?sign t in + let lit, _ = Solver_internal.simplify_and_preproc_lit_ self.si lit in + lit + +(** {2 Main} *) + +let pp_stats out (self : t) : unit = Stat.pp_all out (Stat.all @@ stats self) + +(* add [c], without preprocessing its literals *) +let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit = + Stat.incr self.count_clause; + reset_last_res_ self; + Log.debugf 50 (fun k -> + k "(@[solver.add-clause@ %a@])" (Util.pp_array Lit.pp) c); + let pb = Profile.begin_ "add-clause" in + Sat_solver.add_clause_a self.solver (c :> lit array) proof; + Profile.exit pb + +let add_clause_nopreproc_l_ self c p = + add_clause_nopreproc_ self (CCArray.of_list c) p + +module Perform_delayed_ = Solver_internal.Perform_delayed (struct + type nonrec t = t + + let add_clause _si solver ~keep:_ c pr : unit = + add_clause_nopreproc_l_ solver c pr + + let add_lit _si solver ?default_pol lit : unit = + Sat_solver.add_lit solver.solver ?default_pol lit +end) + +let add_clause (self : t) (c : lit array) (proof : step_id) : unit = + let c, proof = preprocess_clause_ self c proof in + add_clause_nopreproc_ self c proof; + Perform_delayed_.top self.si self; + (* finish preproc *) + () + +let add_clause_l self c p = add_clause self (CCArray.of_list c) p + +let assert_terms self c = + let c = CCList.map (fun t -> Lit.atom (tst self) t) c in + let pr_c = + P.add_step self.proof @@ A.Rule_sat.sat_input_clause (Iter.of_list c) + in + add_clause_l self c pr_c + +let assert_term self t = assert_terms self [ t ] + +exception Resource_exhausted = Sidekick_sat.Resource_exhausted + +let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) + ?(should_stop = fun _ _ -> false) ~assumptions (self : t) : res = + Profile.with_ "smt-solver.solve" @@ fun () -> + let do_on_exit () = List.iter (fun f -> f ()) on_exit in + + let on_progress = + let resource_counter = ref 0 in + fun () -> + incr resource_counter; + on_progress self; + if should_stop self !resource_counter then + raise_notrace Resource_exhausted + in + self.si.on_progress <- on_progress; + + let res = + match + Stat.incr self.count_solve; + Sat_solver.solve ~on_progress ~assumptions (solver self) + with + | Sat_solver.Sat _ when not self.si.complete -> + Log.debugf 1 (fun k -> + k + "(@[sidekick.smt-solver: SAT@ actual: UNKNOWN@ :reason \ + incomplete-fragment@])"); + Unknown Unknown.U_incomplete + | Sat_solver.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 N.pp) + (N.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 self.si.last_model with + | Some m -> m + | None -> assert false + in + (* TODO: check model *) + let _ = check in + + do_on_exit (); + Sat m + | Sat_solver.Unsat (module UNSAT) -> + let unsat_core () = UNSAT.unsat_assumptions () in + let unsat_step_id () = Some (UNSAT.unsat_proof ()) in + do_on_exit (); + Unsat { unsat_core; unsat_step_id } + | exception Resource_exhausted -> Unknown Unknown.U_asked_to_stop + in + self.last_res <- Some res; + res + +let push_assumption self a = + reset_last_res_ self; + Sat_solver.push_assumption self.solver a + +let pop_assumptions self n = + reset_last_res_ self; + Sat_solver.pop_assumptions self.solver n + +type propagation_result = + | PR_sat + | PR_conflict of { backtracked: int } + | PR_unsat of { unsat_core: unit -> lit Iter.t } + +let check_sat_propagations_only ~assumptions self : propagation_result = + reset_last_res_ self; + match Sat_solver.check_sat_propagations_only ~assumptions self.solver with + | Sat_solver.PR_sat -> PR_sat + | Sat_solver.PR_conflict { backtracked } -> PR_conflict { backtracked } + | Sat_solver.PR_unsat (module UNSAT) -> + let unsat_core () = UNSAT.unsat_assumptions () in + PR_unsat { unsat_core } diff --git a/src/smt/solver.mli b/src/smt/solver.mli new file mode 100644 index 00000000..b645adb6 --- /dev/null +++ b/src/smt/solver.mli @@ -0,0 +1,189 @@ +(** Main solver type, user facing. + + This is the solver a user of sidekick can see, after instantiating + everything. The user can add some theories, clauses, etc. and asks + the solver to check satisfiability. + + Theory implementors will mostly interact with {!SOLVER_INTERNAL}. *) + +open Sigs + +type t +(** The solver's state. *) + +val registry : t -> Registry.t +(** A solver contains a registry so that theories can share data *) + +type theory = Theory.t +type 'a theory_p = 'a Theory.p + +val mk_theory : + name:string -> + create_and_setup:(Solver_internal.t -> 'th) -> + ?push_level:('th -> unit) -> + ?pop_levels:('th -> int -> unit) -> + unit -> + theory +(** Helper to create a theory. *) + +(** Models + + A model can be produced when the solver is found to be in a + satisfiable state after a call to {!solve}. *) +module Model : sig + 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 +end + +(* TODO *) +module Unknown : sig + type t + + val pp : t CCFormat.printer + + (* + type unknown = + | U_timeout + | U_incomplete + *) +end + +(** {3 Main API} *) + +val stats : t -> Stat.t +val tst : t -> Term.store +val proof : t -> proof_trace + +val create : + (module ARG) -> + ?stat:Stat.t -> + ?size:[ `Big | `Tiny | `Small ] -> + (* TODO? ?config:Config.t -> *) + proof:proof_trace -> + theories:theory list -> + Term.store -> + unit -> + t +(** Create a new solver. + + It needs a term state and a type state to manipulate terms and types. + All terms and types interacting with this solver will need to come + from these exact states. + + @param store_proof if true, proofs from the SAT solver and theories + are retained and potentially accessible after {!solve} + returns UNSAT. + @param size influences the size of initial allocations. + @param theories theories to load from the start. Other theories + can be added using {!add_theory}. *) + +val add_theory : t -> theory -> unit +(** Add a theory to the solver. This should be called before + any call to {!solve} or to {!add_clause} and the likes (otherwise + the theory will have a partial view of the problem). *) + +val add_theory_p : t -> 'a theory_p -> 'a +(** Add the given theory and obtain its state *) + +val add_theory_l : t -> theory list -> unit + +val mk_lit_t : t -> ?sign:bool -> term -> lit +(** [mk_lit_t _ ~sign t] returns [lit'], + where [lit'] is [preprocess(lit)] and [lit] is + an internal representation of [± t]. + + The proof of [|- lit = lit'] is directly added to the solver's proof. *) + +val add_clause : t -> lit array -> step_id -> unit +(** [add_clause solver cs] adds a boolean clause to the solver. + Subsequent calls to {!solve} will need to satisfy this clause. *) + +val add_clause_l : t -> lit list -> step_id -> unit +(** Add a clause to the solver, given as a list. *) + +val assert_terms : t -> term list -> unit +(** Helper that turns each term into an atom, before adding the result + to the solver as an assertion *) + +val assert_term : t -> term -> unit +(** Helper that turns the term into an atom, before adding the result + to the solver as a unit clause assertion *) + +(** Result of solving for the current set of clauses *) +type res = + | Sat of Model.t (** Satisfiable *) + | Unsat of { + unsat_core: unit -> lit Iter.t; + (** Unsat core (subset of assumptions), or empty *) + unsat_step_id: unit -> step_id option; + (** Proof step for the empty clause *) + } (** Unsatisfiable *) + | Unknown of Unknown.t + (** Unknown, obtained after a timeout, memory limit, etc. *) + +(* TODO: API to push/pop/clear assumptions, in addition to ~assumptions param *) + +val solve : + ?on_exit:(unit -> unit) list -> + ?check:bool -> + ?on_progress:(t -> unit) -> + ?should_stop:(t -> int -> bool) -> + assumptions:lit list -> + t -> + res +(** [solve s] checks the satisfiability of the clauses added so far to [s]. + @param check if true, the model is checked before returning. + @param on_progress called regularly during solving. + @param assumptions a set of atoms held to be true. The unsat core, + if any, will be a subset of [assumptions]. + @param should_stop a callback regularly called with the solver, + and with a number of "steps" done since last call. The exact notion + of step is not defined, but is guaranteed to increase regularly. + The function should return [true] if it judges solving + must stop (returning [Unknown]), [false] if solving can proceed. + @param on_exit functions to be run before this returns *) + +val last_res : t -> res option +(** Last result, if any. Some operations will erase this (e.g. {!assert_term}). *) + +val push_assumption : t -> lit -> unit +(** Pushes an assumption onto the assumption stack. It will remain + there until it's pop'd by {!pop_assumptions}. *) + +val pop_assumptions : t -> int -> unit +(** [pop_assumptions solver n] removes [n] assumptions from the stack. + It removes the assumptions that were the most + recently added via {!push_assumptions}. + Note that {!check_sat_propagations_only} can call this if it meets + a conflict. *) + +type propagation_result = + | PR_sat + | PR_conflict of { backtracked: int } + | PR_unsat of { unsat_core: unit -> lit Iter.t } + +val check_sat_propagations_only : + assumptions:lit list -> t -> propagation_result +(** [check_sat_propagations_only solver] uses assumptions (including + the [assumptions] parameter, and atoms previously added via {!push_assumptions}) + and boolean+theory propagation to quickly assess satisfiability. + It is not complete; calling {!solve} is required to get an accurate + result. + @returns one of: + + - [PR_sat] if the current state seems satisfiable + - [PR_conflict {backtracked=n}] if a conflict was found and resolved, + leading to backtracking [n] levels of assumptions + - [PR_unsat …] if the assumptions were found to be unsatisfiable, with + the given core. + *) + +(* TODO: allow on_progress to return a bool to know whether to stop? *) + +val pp_stats : t CCFormat.printer +(** Print some statistics. What it prints exactly is unspecified. *) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml new file mode 100644 index 00000000..db0995e1 --- /dev/null +++ b/src/smt/solver_internal.ml @@ -0,0 +1,608 @@ +open Sigs +module Proof_rules = Sidekick_core.Proof_sat +module P_core_rules = Sidekick_core.Proof_core +module N = Sidekick_cc.E_node +module Ty = Term + +open struct + module P = Proof_trace + module Rule_ = Proof_core +end + +type th_states = + | Ths_nil + | Ths_cons : { + st: 'a; + push_level: 'a -> unit; + pop_levels: 'a -> int -> unit; + next: th_states; + } + -> th_states + +(* actions from the sat solver *) +type sat_acts = Sidekick_sat.acts +type theory_actions = sat_acts +type simplify_hook = Simplify.hook + +module type PREPROCESS_ACTS = sig + val proof : proof_trace + val mk_lit : ?sign:bool -> term -> lit + val add_clause : lit list -> step_id -> unit + val add_lit : ?default_pol:bool -> lit -> unit +end + +type preprocess_actions = (module PREPROCESS_ACTS) + +module Registry = Registry + +(* delayed actions. We avoid doing them on the spot because, when + triggered by a theory, they might go back to the theory "too early". *) +type delayed_action = + | DA_add_clause of { c: lit list; pr: step_id; keep: bool } + | DA_add_lit of { default_pol: bool option; lit: lit } + +type t = { + tst: Term.store; (** state for managing terms *) + cc: CC.t; (** congruence closure *) + proof: proof_trace; (** proof logger *) + registry: Registry.t; + mutable on_progress: unit -> unit; + mutable on_partial_check: (t -> theory_actions -> lit Iter.t -> unit) list; + mutable on_final_check: (t -> theory_actions -> lit Iter.t -> unit) list; + mutable on_th_combination: + (t -> theory_actions -> (term * value) Iter.t) list; + mutable preprocess: preprocess_hook list; + mutable model_ask: model_ask_hook list; + mutable model_complete: model_completion_hook list; + simp: Simplify.t; + preprocessed: unit Term.Tbl.t; + delayed_actions: delayed_action Queue.t; + mutable last_model: Model.t option; + mutable th_states: th_states; (** Set of theories *) + mutable level: int; + mutable complete: bool; + stat: Stat.t; + count_axiom: int Stat.counter; + count_preprocess_clause: int Stat.counter; + count_conflict: int Stat.counter; + count_propagate: int Stat.counter; +} + +and preprocess_hook = t -> preprocess_actions -> term -> unit +and model_ask_hook = recurse:(t -> N.t -> term) -> t -> N.t -> term option +and model_completion_hook = t -> add:(term -> term -> unit) -> unit + +type solver = t + +let[@inline] cc (self : t) = self.cc +let[@inline] tst self = self.tst +let[@inline] proof self = self.proof +let stats self = self.stat + +let[@inline] has_delayed_actions self = + not (Queue.is_empty self.delayed_actions) + +let registry self = self.registry +let simplifier self = self.simp +let simplify_t self (t : Term.t) : _ option = Simplify.normalize self.simp t +let simp_t self (t : Term.t) : Term.t * _ = Simplify.normalize_t self.simp t +let add_simplifier (self : t) f : unit = Simplify.add_hook self.simp f + +let on_th_combination self f = + self.on_th_combination <- f :: self.on_th_combination + +let on_preprocess self f = self.preprocess <- f :: self.preprocess + +let on_model ?ask ?complete self = + Option.iter (fun f -> self.model_ask <- f :: self.model_ask) ask; + Option.iter + (fun f -> self.model_complete <- f :: self.model_complete) + complete; + () + +let[@inline] raise_conflict self (acts : theory_actions) c proof : 'a = + let (module A) = acts in + Stat.incr self.count_conflict; + A.raise_conflict c proof + +let[@inline] propagate self (acts : theory_actions) p ~reason : unit = + let (module A) = acts in + Stat.incr self.count_propagate; + A.propagate p (Sidekick_sat.Consequence reason) + +let[@inline] propagate_l self acts p cs proof : unit = + propagate self acts p ~reason:(fun () -> cs, proof) + +let add_sat_clause_ self (acts : theory_actions) ~keep lits (proof : step_id) : + unit = + let (module A) = acts in + Stat.incr self.count_axiom; + A.add_clause ~keep lits proof + +let add_sat_lit_ _self ?default_pol (acts : theory_actions) (lit : Lit.t) : unit + = + let (module A) = acts in + A.add_lit ?default_pol lit + +let delayed_add_lit (self : t) ?default_pol (lit : Lit.t) : unit = + Queue.push (DA_add_lit { default_pol; lit }) self.delayed_actions + +let delayed_add_clause (self : t) ~keep (c : Lit.t list) (pr : step_id) : unit = + Queue.push (DA_add_clause { c; pr; keep }) self.delayed_actions + +let preprocess_term_ (self : t) (t0 : term) : unit = + let module A = struct + let proof = self.proof + let mk_lit ?sign t : Lit.t = Lit.atom ?sign t + let add_lit ?default_pol lit : unit = delayed_add_lit self ?default_pol lit + let add_clause c pr : unit = delayed_add_clause self ~keep:true c pr + end in + let acts = (module A : PREPROCESS_ACTS) in + + (* how to preprocess a term and its subterms *) + let rec preproc_rec_ t = + if not (Term.Tbl.mem self.preprocessed t) then ( + Term.Tbl.add self.preprocessed t (); + + (* process sub-terms first *) + Term.iter_shallow t ~f:(fun _inb u -> preproc_rec_ u); + + Log.debugf 50 (fun k -> k "(@[smt.preprocess@ %a@])" Term.pp_debug t); + + (* signal boolean subterms, so as to decide them + in the SAT solver *) + if Ty.is_bool (Term.ty t) then ( + Log.debugf 5 (fun k -> + k "(@[solver.map-bool-subterm-to-lit@ :subterm %a@])" Term.pp_debug + t); + + (* make a literal *) + let lit = Lit.atom t in + (* ensure that SAT solver has a boolean atom for [u] *) + delayed_add_lit self lit; + + (* also map [sub] to this atom in the congruence closure, for propagation *) + let cc = cc self in + CC.set_as_lit cc (CC.add_term cc t) lit + ); + + List.iter (fun f -> f self acts t) self.preprocess + ) + in + preproc_rec_ t0 + +(* simplify literal, then preprocess the result *) +let simplify_and_preproc_lit_ (self : t) (lit : Lit.t) : Lit.t * step_id option + = + let t = Lit.term lit in + let sign = Lit.sign lit in + let u, pr = + match simplify_t self t with + | None -> t, None + | Some (u, pr_t_u) -> + Log.debugf 30 (fun k -> + k "(@[smt-solver.simplify@ :t %a@ :into %a@])" Term.pp_debug t + Term.pp_debug u); + u, Some pr_t_u + in + preprocess_term_ self u; + Lit.atom ~sign u, pr + +let push_decision (self : t) (acts : theory_actions) (lit : lit) : unit = + let (module A) = acts in + (* make sure the literal is preprocessed *) + let lit, _ = simplify_and_preproc_lit_ self lit in + let sign = Lit.sign lit in + A.add_decision_lit (Lit.abs lit) sign + +module type ARR = sig + type 'a t + + val map : ('a -> 'b) -> 'a t -> 'b t + val to_iter : 'a t -> 'a Iter.t +end + +module Preprocess_clause (A : ARR) = struct + (* preprocess a clause's literals, possibly emitting a proof + for the preprocessing. *) + let top (self : t) (c : lit A.t) (pr_c : step_id) : lit A.t * step_id = + let steps = ref [] in + + (* simplify a literal, then preprocess it *) + let[@inline] simp_lit lit = + let lit, pr = simplify_and_preproc_lit_ self lit in + Option.iter (fun pr -> steps := pr :: !steps) pr; + lit + in + let c' = A.map simp_lit c in + + let pr_c' = + if !steps = [] then + pr_c + else ( + Stat.incr self.count_preprocess_clause; + P.add_step self.proof + @@ Rule_.lemma_rw_clause pr_c ~res:(A.to_iter c') + ~using:(Iter.of_list !steps) + ) + in + c', pr_c' +end +[@@inline] + +module PC_list = Preprocess_clause (CCList) +module PC_arr = Preprocess_clause (CCArray) + +let preprocess_clause_ = PC_list.top +let preprocess_clause_iarray_ = PC_arr.top + +module type PERFORM_ACTS = sig + type t + + val add_clause : solver -> t -> keep:bool -> lit list -> step_id -> unit + val add_lit : solver -> t -> ?default_pol:bool -> lit -> unit +end + +module Perform_delayed (A : PERFORM_ACTS) = struct + (* perform actions that were delayed *) + let top (self : t) (acts : A.t) : unit = + while not (Queue.is_empty self.delayed_actions) do + let act = Queue.pop self.delayed_actions in + match act with + | DA_add_clause { c; pr = pr_c; keep } -> + let c', pr_c' = preprocess_clause_ self c pr_c in + A.add_clause self acts ~keep c' pr_c' + | DA_add_lit { default_pol; lit } -> + preprocess_term_ self (Lit.term lit); + A.add_lit self acts ?default_pol lit + done +end +[@@inline] + +module Perform_delayed_th = Perform_delayed (struct + type t = theory_actions + + let add_clause self acts ~keep c pr : unit = + add_sat_clause_ self acts ~keep c pr + + let add_lit self acts ?default_pol lit : unit = + add_sat_lit_ self acts ?default_pol lit +end) + +let[@inline] add_clause_temp self _acts c (proof : step_id) : unit = + let c, proof = preprocess_clause_ self c proof in + delayed_add_clause self ~keep:false c proof + +let[@inline] add_clause_permanent self _acts c (proof : step_id) : unit = + let c, proof = preprocess_clause_ self c proof in + delayed_add_clause self ~keep:true c proof + +let[@inline] mk_lit _ ?sign t : lit = Lit.atom ?sign t + +let[@inline] add_lit self _acts ?default_pol lit = + delayed_add_lit self ?default_pol lit + +let add_lit_t self _acts ?sign t = + let lit = Lit.atom ?sign t in + let lit, _ = simplify_and_preproc_lit_ self lit in + delayed_add_lit self lit + +let on_final_check self f = self.on_final_check <- f :: self.on_final_check + +let on_partial_check self f = + self.on_partial_check <- f :: self.on_partial_check + +let on_cc_new_term self f = Event.on (CC.on_new_term (cc self)) ~f +let on_cc_pre_merge self f = Event.on (CC.on_pre_merge (cc self)) ~f +let on_cc_post_merge self f = Event.on (CC.on_post_merge (cc self)) ~f +let on_cc_conflict self f = Event.on (CC.on_conflict (cc self)) ~f +let on_cc_propagate self f = Event.on (CC.on_propagate (cc self)) ~f +let on_cc_is_subterm self f = Event.on (CC.on_is_subterm (cc self)) ~f +let cc_add_term self t = CC.add_term (cc self) t +let cc_mem_term self t = CC.mem_term (cc self) t +let cc_find self n = CC.find (cc self) n + +let cc_are_equal self t1 t2 = + let n1 = cc_add_term self t1 in + let n2 = cc_add_term self t2 in + N.equal (cc_find self n1) (cc_find self n2) + +let cc_resolve_expl self e : lit list * _ = + let r = CC.explain_expl (cc self) e in + r.lits, r.pr self.proof + +(* + let cc_merge self _acts n1 n2 e = CC.merge (cc self) n1 n2 e + + let cc_merge_t self acts t1 t2 e = + let cc_acts = mk_cc_acts_ self.proof acts in + cc_merge self cc_acts (cc_add_term self t1) (cc_add_term self t2) e + + let cc_raise_conflict_expl self acts e = + let cc_acts = mk_cc_acts_ self.proof acts in + CC.raise_conflict_from_expl (cc self) cc_acts e + *) + +(** {2 Interface with the SAT solver} *) + +let rec push_lvl_ = function + | Ths_nil -> () + | Ths_cons r -> + r.push_level r.st; + push_lvl_ r.next + +let rec pop_lvls_ n = function + | Ths_nil -> () + | Ths_cons r -> + r.pop_levels r.st n; + pop_lvls_ n r.next + +let push_level (self : t) : unit = + self.level <- 1 + self.level; + CC.push_level (cc self); + push_lvl_ self.th_states + +let pop_levels (self : t) n : unit = + self.last_model <- None; + self.level <- self.level - n; + CC.pop_levels (cc self) n; + pop_lvls_ n self.th_states + +let n_levels self = self.level + +(** {2 Model construction and theory combination} *) + +(* make model from the congruence closure *) +let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = + Log.debug 1 "(smt.solver.mk-model)"; + Profile.with_ "smt-solver.mk-model" @@ fun () -> + let module M = Term.Tbl in + let { cc; tst; model_ask = model_ask_hooks; model_complete; _ } = self in + + let model = M.create 128 in + + (* first, add all literals to the model using the given propositional model + [lits]. *) + lits (fun lit -> + let t, sign = Lit.signed_term lit in + M.replace model t (Term.bool_val tst sign)); + + (* populate with information from the CC *) + (* FIXME + CC.get_model_for_each_class cc (fun (_, ts, v) -> + Iter.iter + (fun n -> + let t = N.term n in + M.replace model t v) + ts); + *) + + (* complete model with theory specific values *) + let complete_with f = + f self ~add:(fun t u -> + if not (M.mem model t) then ( + Log.debugf 20 (fun k -> + k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp_debug t + Term.pp_debug u); + M.replace model t u + )) + in + List.iter complete_with model_complete; + + (* compute a value for [n]. *) + let rec val_for_class (n : N.t) : term = + Log.debugf 5 (fun k -> k "val-for-term %a" N.pp n); + let repr = CC.find cc n in + Log.debugf 5 (fun k -> k "val-for-term.repr %a" N.pp repr); + + (* see if a value is found already (always the case if it's a boolean) *) + match M.get model (N.term repr) with + | Some t_val -> + Log.debugf 5 (fun k -> k "cached val is %a" Term.pp_debug t_val); + t_val + | None -> + (* try each model hook *) + let rec try_hooks_ = function + | [] -> N.term repr + | h :: hooks -> + (match h ~recurse:(fun _ n -> val_for_class n) self repr with + | None -> try_hooks_ hooks + | Some t -> t) + in + + let t_val = + try_hooks_ model_ask_hooks + (* FIXME: the more complete version? + match + (* look for a value in the model for any term in the class *) + N.iter_class repr + |> Iter.find_map (fun n -> M.get model (N.term n)) + with + | Some v -> v + | None -> try_hooks_ model_ask_hooks + *) + in + + M.replace model (N.term repr) t_val; + (* be sure to cache the value *) + Log.debugf 5 (fun k -> k "val is %a" Term.pp_debug t_val); + t_val + in + + (* map terms of each CC class to the value computed for their class. *) + CC.all_classes cc (fun repr -> + let t_val = val_for_class repr in + (* value for this class *) + N.iter_class repr (fun u -> + let t_u = N.term u in + if (not (N.equal u repr)) && not (Term.equal t_u t_val) then + M.replace model t_u t_val)); + Model.Map model + +(* do theory combination using the congruence closure. Each theory + can merge classes, *) +let check_th_combination_ (self : t) (_acts : theory_actions) lits : + (Model.t, th_combination_conflict) result = + (* FIXME + + (* enter model mode, disabling most of congruence closure *) + CC.with_model_mode cc @@ fun () -> + let set_val (t, v) : unit = + Log.debugf 50 (fun k -> + k "(@[solver.th-comb.cc-set-term-value@ %a@ :val %a@])" Term.pp_debug t + Term.pp_debug v); + CC.set_model_value cc t v + in + + (* obtain assignments from the hook, and communicate them to the CC *) + let add_th_values f : unit = + let vals = f self acts in + Iter.iter set_val vals + in + try + List.iter add_th_values self.on_th_combination; + CC.check cc; + let m = mk_model_ self in + Ok m + with Semantic_conflict c -> Error c + *) + let m = mk_model_ self lits in + Ok m + +(* call congruence closure, perform the actions it scheduled *) +let check_cc_with_acts_ (self : t) (acts : theory_actions) = + let (module A) = acts in + let cc = cc self in + match CC.check cc with + | Ok acts -> + List.iter + (function + | CC.Result_action.Act_propagate { lit; reason } -> + let reason = Sidekick_sat.Consequence reason in + A.propagate lit reason) + acts + | Error (CC.Result_action.Conflict (lits, pr)) -> A.raise_conflict lits pr + +(* handle a literal assumed by the SAT solver *) +let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) + : unit = + Log.debugf 2 (fun k -> + k "(@[@{smt-solver.assume_lits@}%s[lvl=%d]@ %a@])" + (if final then + "[final]" + else + "") + self.level + (Util.pp_iter ~sep:"; " Lit.pp) + lits); + (* transmit to CC *) + let cc = cc self in + + if not final then CC.assert_lits cc lits; + (* transmit to theories. *) + check_cc_with_acts_ self acts; + if final then ( + List.iter (fun f -> f self acts lits) self.on_final_check; + check_cc_with_acts_ self acts; + + (match check_th_combination_ self acts lits with + | Ok m -> self.last_model <- Some m + | Error { lits; semantic } -> + (* bad model, we add a clause to remove it *) + Log.debugf 5 (fun k -> + k "(@[solver.th-comb.conflict@ :lits (@[%a@])@ :same-val (@[%a@])@])" + (Util.pp_list Lit.pp) lits + (Util.pp_list @@ Fmt.Dump.(triple bool Term.pp_debug Term.pp_debug)) + semantic); + + let c1 = List.rev_map Lit.neg lits in + let c2 = + semantic + |> List.rev_map (fun (sign, t, u) -> + let eqn = Term.eq self.tst t u in + let lit = Lit.atom ~sign:(not sign) eqn in + (* make sure to consider the new lit *) + add_lit self acts lit; + lit) + in + + let c = List.rev_append c1 c2 in + let pr = P.add_step self.proof @@ Rule_.lemma_cc (Iter.of_list c) in + + Log.debugf 20 (fun k -> + k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" + (Util.pp_list Lit.pp) c); + (* will add a delayed action *) + add_clause_temp self acts c pr); + + Perform_delayed_th.top self acts + ) else ( + List.iter (fun f -> f self acts lits) self.on_partial_check; + Perform_delayed_th.top self acts + ); + () + +let[@inline] iter_atoms_ (acts : theory_actions) : _ Iter.t = + fun f -> + let (module A) = acts in + A.iter_assumptions f + +(* propagation from the bool solver *) +let check_ ~final (self : t) (acts : sat_acts) = + let pb = + if final then + Profile.begin_ "solver.final-check" + else + Profile.null_probe + in + let iter = iter_atoms_ acts in + Log.debugf 5 (fun k -> k "(smt-solver.assume :len %d)" (Iter.length iter)); + self.on_progress (); + assert_lits_ ~final self acts iter; + Profile.exit pb + +(* propagation from the bool solver *) +let[@inline] partial_check (self : t) (acts : Sidekick_sat.acts) : unit = + check_ ~final:false self acts + +(* perform final check of the model *) +let[@inline] final_check (self : t) (acts : Sidekick_sat.acts) : unit = + check_ ~final:true self acts + +let declare_pb_is_incomplete self = + if self.complete then Log.debug 1 "(solver.declare-pb-is-incomplete)"; + self.complete <- false + +let add_theory_state ~st ~push_level ~pop_levels (self : t) = + self.th_states <- + Ths_cons { st; push_level; pop_levels; next = self.th_states } + +let create (module A : ARG) ~stat ~proof (tst : Term.store) () : t = + let self = + { + tst; + cc = CC.create (module A : CC.ARG) ~size:`Big tst proof; + proof; + th_states = Ths_nil; + stat; + simp = Simplify.create tst ~proof; + last_model = None; + on_progress = (fun () -> ()); + preprocess = []; + model_ask = []; + model_complete = []; + registry = Registry.create (); + preprocessed = Term.Tbl.create 32; + delayed_actions = Queue.create (); + count_axiom = Stat.mk_int stat "solver.th-axioms"; + count_preprocess_clause = Stat.mk_int stat "solver.preprocess-clause"; + count_propagate = Stat.mk_int stat "solver.th-propagations"; + count_conflict = Stat.mk_int stat "solver.th-conflicts"; + on_partial_check = []; + on_final_check = []; + on_th_combination = []; + level = 0; + complete = true; + } + in + self diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli new file mode 100644 index 00000000..508df6fc --- /dev/null +++ b/src/smt/solver_internal.mli @@ -0,0 +1,256 @@ +(** A view of the solver from a theory's point of view. + + Theories should interact with the solver via this module, to assert + new lemmas, propagate literals, access the congruence closure, etc. *) + +open Sigs + +type t +(** Main type for the SMT solver *) + +type solver = t + +val tst : t -> term_store +val stats : t -> Stat.t + +val proof : t -> proof_trace +(** Access the proof object *) + +val registry : t -> Registry.t +(** A solver contains a registry so that theories can share data *) + +(** {3 Actions for the theories} *) + +type theory_actions +(** Handle that the theories can use to perform actions. *) + +(** {3 Congruence Closure} *) + +val cc : t -> CC.t +(** Congruence closure for this solver *) + +(** {3 Backtracking} *) + +include Sidekick_sigs.BACKTRACKABLE0 with type t := t + +(** {3 Interface to SAT} *) + +include Sidekick_sat.PLUGIN_CDCL_T with type t := t + +(** {3 Simplifiers} *) + +type simplify_hook = Simplify.hook + +val add_simplifier : t -> Simplify.hook -> unit +(** Add a simplifier hook for preprocessing. *) + +val simplify_t : t -> term -> (term * step_id) option +(** Simplify input term, returns [Some u] if some + simplification occurred. *) + +val simp_t : t -> term -> term * step_id option +(** [simp_t si t] returns [u] even if no simplification occurred + (in which case [t == u] syntactically). + It emits [|- t=u]. + (see {!simplifier}) *) + +(** {3 Preprocessors} + These preprocessors turn mixed, raw literals (possibly simplified) into + literals suitable for reasoning. + Typically some clauses are also added to the solver. *) + +(* TODO: move into its own sig + library *) +module type PREPROCESS_ACTS = sig + val proof : proof_trace + + val mk_lit : ?sign:bool -> term -> lit + (** [mk_lit t] creates a new literal for a boolean term [t]. *) + + val add_clause : lit list -> step_id -> unit + (** pushes a new clause into the SAT solver. *) + + val add_lit : ?default_pol:bool -> lit -> unit + (** Ensure the literal will be decided/handled by the SAT solver. *) +end + +type preprocess_actions = (module PREPROCESS_ACTS) +(** Actions available to the preprocessor *) + +type preprocess_hook = t -> preprocess_actions -> term -> unit +(** Given a term, preprocess it. + + The idea is to add literals and clauses to help define the meaning of + the term, if needed. For example for boolean formulas, clauses + for their Tseitin encoding can be added, with the formula acting + as its own proxy symbol. + + @param preprocess_actions actions available during preprocessing. + *) + +val on_preprocess : t -> preprocess_hook -> unit +(** Add a hook that will be called when terms are preprocessed *) + +(** {3 hooks for the theory} *) + +val raise_conflict : t -> theory_actions -> lit list -> step_id -> 'a +(** Give a conflict clause to the solver *) + +val push_decision : t -> theory_actions -> lit -> unit +(** Ask the SAT solver to decide the given literal in an extension of the + current trail. This is useful for theory combination. + If the SAT solver backtracks, this (potential) decision is removed + and forgotten. *) + +val propagate : + t -> theory_actions -> lit -> reason:(unit -> lit list * step_id) -> unit +(** Propagate a boolean using a unit clause. + [expl => lit] must be a theory lemma, that is, a T-tautology *) + +val propagate_l : t -> theory_actions -> lit -> lit list -> step_id -> unit +(** Propagate a boolean using a unit clause. + [expl => lit] must be a theory lemma, that is, a T-tautology *) + +val add_clause_temp : t -> theory_actions -> lit list -> step_id -> unit +(** Add local clause to the SAT solver. This clause will be + removed when the solver backtracks. *) + +val add_clause_permanent : t -> theory_actions -> lit list -> step_id -> unit +(** Add toplevel clause to the SAT solver. This clause will + not be backtracked. *) + +val mk_lit : t -> ?sign:bool -> term -> lit +(** Create a literal. This automatically preprocesses the term. *) + +val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit +(** Add the given literal to the SAT solver, so it gets assigned + a boolean value. + @param default_pol default polarity for the corresponding atom *) + +val add_lit_t : t -> theory_actions -> ?sign:bool -> term -> unit +(** Add the given (signed) bool term to the SAT solver, so it gets assigned + a boolean value *) + +val cc_find : t -> E_node.t -> E_node.t +(** Find representative of the node *) + +val cc_are_equal : t -> term -> term -> bool +(** Are these two terms equal in the congruence closure? *) + +val cc_resolve_expl : t -> CC_expl.t -> lit list * step_id + +(* + val cc_raise_conflict_expl : t -> theory_actions -> CC_expl.t -> 'a + (** Raise a conflict with the given congruence closure explanation. + it must be a theory tautology that [expl ==> absurd]. + To be used in theories. *) + + val cc_merge : + t -> theory_actions -> E_node.t -> E_node.t -> CC_expl.t -> unit + (** Merge these two nodes in the congruence closure, given this explanation. + It must be a theory tautology that [expl ==> n1 = n2]. + To be used in theories. *) + + val cc_merge_t : t -> theory_actions -> term -> term -> CC_expl.t -> unit + (** Merge these two terms in the congruence closure, given this explanation. + See {!cc_merge} *) + *) + +val cc_add_term : t -> term -> E_node.t +(** Add/retrieve congruence closure node for this term. + To be used in theories *) + +val cc_mem_term : t -> term -> bool +(** Return [true] if the term is explicitly in the congruence closure. + To be used in theories *) + +val on_cc_pre_merge : + t -> + (CC.t * E_node.t * E_node.t * CC_expl.t -> CC.Handler_action.or_conflict) -> + unit +(** Callback for when two classes containing data for this key are merged (called before) *) + +val on_cc_post_merge : + t -> (CC.t * E_node.t * E_node.t -> CC.Handler_action.t list) -> unit +(** Callback for when two classes containing data for this key are merged (called after)*) + +val on_cc_new_term : + t -> (CC.t * E_node.t * term -> CC.Handler_action.t list) -> unit +(** Callback to add data on terms when they are added to the congruence + closure *) + +val on_cc_is_subterm : + t -> (CC.t * E_node.t * term -> CC.Handler_action.t list) -> unit +(** Callback for when a term is a subterm of another term in the + congruence closure *) + +val on_cc_conflict : t -> (CC.ev_on_conflict -> unit) -> unit +(** Callback called on every CC conflict *) + +val on_cc_propagate : + t -> + (CC.t * lit * (unit -> lit list * step_id) -> CC.Handler_action.t list) -> + unit +(** Callback called on every CC propagation *) + +val on_partial_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit +(** Register callbacked to be called with the slice of literals + newly added on the trail. + + This is called very often and should be efficient. It doesn't have + to be complete, only correct. It's given only the slice of + the trail consisting in new literals. *) + +val on_final_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit +(** Register callback to be called during the final check. + + Must be complete (i.e. must raise a conflict if the set of literals is + not satisfiable) and can be expensive. The function + is given the whole trail. + *) + +val on_th_combination : + t -> (t -> theory_actions -> (term * value) Iter.t) -> unit +(** Add a hook called during theory combination. + The hook must return an iterator of pairs [(t, v)] + which mean that term [t] has value [v] in the model. + + Terms with the same value (according to {!Term.equal}) will be + merged in the CC; if two terms with different values are merged, + we get a semantic conflict and must pick another model. *) + +val declare_pb_is_incomplete : t -> unit +(** Declare that, in some theory, the problem is outside the logic fragment + that is decidable (e.g. if we meet proper NIA formulas). + The solver will not reply "SAT" from now on. *) + +(** {3 Model production} *) + +type model_ask_hook = + recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option +(** A model-production hook to query values from a theory. + + It takes the solver, a class, and returns + a term for this class. For example, an arithmetic theory + might detect that a class contains a numeric constant, and return + this constant as a model value. + + If no hook assigns a value to a class, a fake value is created for it. + *) + +type model_completion_hook = t -> add:(term -> term -> unit) -> unit +(** A model production hook, for the theory to add values. + The hook is given a [add] function to add bindings to the model. *) + +val on_model : + ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit +(** Add model production/completion hooks. *) + +val add_theory_state : + st:'a -> + push_level:('a -> unit) -> + pop_levels:('a -> int -> unit) -> + t -> + unit + +val create : + (module ARG) -> stat:Stat.t -> proof:Proof_trace.t -> Term.store -> unit -> t diff --git a/src/smt/th_key.ml.bak b/src/smt/th_key.ml.bak new file mode 100644 index 00000000..cd8c7194 --- /dev/null +++ b/src/smt/th_key.ml.bak @@ -0,0 +1,145 @@ + + +module type S = sig + type ('term,'lit,'a) t + (** An access key for theories which have per-class data ['a] *) + + val create : + ?pp:'a Fmt.printer -> + name:string -> + eq:('a -> 'a -> bool) -> + merge:('a -> 'a -> 'a) -> + unit -> + ('term,'lit,'a) t + (** Generative creation of keys for the given theory data. + + @param eq : Equality. This is used to optimize backtracking info. + + @param merge : + [merge d1 d2] is called when merging classes with data [d1] and [d2] + respectively. The theory should already have checked that the merge + is compatible, and this produces the combined data for terms in the + merged class. + @param name name of the theory which owns this data + @param pp a printer for the data + *) + + val equal : ('t,'lit,_) t -> ('t,'lit,_) t -> bool + (** Checks if two keys are equal (generatively) *) + + val pp : _ t Fmt.printer + (** Prints the name of the key. *) +end + + +(** Custom keys for theory data. + This imitates the classic tricks for heterogeneous maps + https://blog.janestreet.com/a-universal-type/ + + It needs to form a commutative monoid where values are persistent so + they can be restored during backtracking. +*) +module Key = struct + module type KEY_IMPL = sig + type term + type lit + type t + val id : int + val name : string + val pp : t Fmt.printer + val equal : t -> t -> bool + val merge : t -> t -> t + exception Store of t + end + + type ('term,'lit,'a) t = + (module KEY_IMPL with type term = 'term and type lit = 'lit and type t = 'a) + + let n_ = ref 0 + + let create (type term)(type lit)(type d) + ?(pp=fun out _ -> Fmt.string out "") + ~name ~eq ~merge () : (term,lit,d) t = + let module K = struct + type nonrec term = term + type nonrec lit = lit + type t = d + let id = !n_ + let name = name + let pp = pp + let merge = merge + let equal = eq + exception Store of d + end in + incr n_; + (module K) + + let[@inline] id + : type term lit a. (term,lit,a) t -> int + = fun (module K) -> K.id + + let[@inline] equal + : type term lit a b. (term,lit,a) t -> (term,lit,b) t -> bool + = fun (module K1) (module K2) -> K1.id = K2.id + + let pp + : type term lit a. (term,lit,a) t Fmt.printer + = fun out (module K) -> Fmt.string out K.name +end + + + +(* + (** Map for theory data associated with representatives *) + module K_map = struct + type 'a key = (term,lit,'a) Key.t + type pair = Pair : 'a key * exn -> pair + + type t = pair IM.t + + let empty = IM.empty + + let[@inline] mem k t = IM.mem (Key.id k) t + + let find (type a) (k : a key) (self:t) : a option = + let (module K) = k in + match IM.find K.id self with + | Pair (_, K.Store v) -> Some v + | _ -> None + | exception Not_found -> None + + let add (type a) (k : a key) (v:a) (self:t) : t = + let (module K) = k in + IM.add K.id (Pair (k, K.Store v)) self + + let remove (type a) (k: a key) self : t = + let (module K) = k in + IM.remove K.id self + + let equal (m1:t) (m2:t) : bool = + IM.equal + (fun p1 p2 -> + let Pair ((module K1), v1) = p1 in + let Pair ((module K2), v2) = p2 in + assert (K1.id = K2.id); + match v1, v2 with K1.Store v1, K1.Store v2 -> K1.equal v1 v2 | _ -> false) + m1 m2 + + let merge ~f_both (m1:t) (m2:t) : t = + IM.merge + (fun _ p1 p2 -> + match p1, p2 with + | None, None -> None + | Some v, None + | None, Some v -> Some v + | Some (Pair ((module K1) as key1, pair1)), Some (Pair (_, pair2)) -> + match pair1, pair2 with + | K1.Store v1, K1.Store v2 -> + f_both K1.id pair1 pair2; (* callback for checking compat *) + let v12 = K1.merge v1 v2 in (* merge content *) + Some (Pair (key1, K1.Store v12)) + | _ -> assert false + ) + m1 m2 + end + *) diff --git a/src/smt/theory.ml b/src/smt/theory.ml new file mode 100644 index 00000000..7039ecb6 --- /dev/null +++ b/src/smt/theory.ml @@ -0,0 +1,44 @@ +(** Signatures for theory plugins *) + +(** A theory + + Theories are abstracted over the concrete implementation of the solver, + so they can work with any implementation. + + Typically a theory should be a functor taking an argument containing + a [SOLVER_INTERNAL] or even a full [SOLVER], + and some additional views on terms, literals, etc. + that are specific to the theory (e.g. to map terms to linear + expressions). + The theory can then be instantiated on any kind of solver for any + term representation that also satisfies the additional theory-specific + requirements. Instantiated theories (ie values of type {!SOLVER.theory}) + can be added to the solver. + *) +module type S = sig + type t + + val name : string + val create_and_setup : Solver_internal.t -> t + val push_level : t -> unit + val pop_levels : t -> int -> unit +end + +type t = (module S) +(** A theory that can be used for this particular solver. *) + +type 'a p = (module S with type t = 'a) +(** A theory that can be used for this particular solver, with state + of type ['a]. *) + +let make (type st) ~name ~create_and_setup ?(push_level = fun _ -> ()) + ?(pop_levels = fun _ _ -> ()) () : t = + let module Th = struct + type t = st + + let name = name + let create_and_setup = create_and_setup + let push_level = push_level + let pop_levels = pop_levels + end in + (module Th) From 085e37e063e6c5d89cf8534d20255725acf00cde Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 20:27:47 -0400 Subject: [PATCH 047/174] refactor(sat): remove functor, split into modules --- src/sat/CHANGELOG.md | 118 -- src/sat/Sidekick_sat.ml | 33 +- src/sat/Solver.ml | 2565 ------------------------ src/sat/Solver.mli | 5 - src/sat/Solver_intf.ml | 342 ---- src/sat/base_types_.ml | 63 + src/sat/dune | 2 +- src/sat/{Heap.ml => heap.ml} | 0 src/sat/{Heap.mli => heap.mli} | 0 src/sat/{Heap_intf.ml => heap_intf.ml} | 0 src/sat/sigs.ml | 153 ++ src/sat/solver.ml | 2036 +++++++++++++++++++ src/sat/solver.mli | 176 ++ src/sat/store.ml | 408 ++++ src/sat/store.mli | 129 ++ 15 files changed, 2967 insertions(+), 3063 deletions(-) delete mode 100644 src/sat/CHANGELOG.md delete mode 100644 src/sat/Solver.ml delete mode 100644 src/sat/Solver.mli delete mode 100644 src/sat/Solver_intf.ml create mode 100644 src/sat/base_types_.ml rename src/sat/{Heap.ml => heap.ml} (100%) rename src/sat/{Heap.mli => heap.mli} (100%) rename src/sat/{Heap_intf.ml => heap_intf.ml} (100%) create mode 100644 src/sat/sigs.ml create mode 100644 src/sat/solver.ml create mode 100644 src/sat/solver.mli create mode 100644 src/sat/store.ml create mode 100644 src/sat/store.mli diff --git a/src/sat/CHANGELOG.md b/src/sat/CHANGELOG.md deleted file mode 100644 index 0efb4bb4..00000000 --- a/src/sat/CHANGELOG.md +++ /dev/null @@ -1,118 +0,0 @@ -# CHANGES - -## 0.9.1 - -- add `on_conflit` callback -- fix termination issue when using `push_decision_lit` from plugin - -## 0.9 - -- feat: allow the theory to ask for some literals to be decided on -- feat: allow to set the default polarity of variables at creation time - -## 0.8.3 - -- support containers 3.0 - -## 0.8.2 - -- fix opam file -- fix: allow conflicts below decision level in `Make_cdcl_t` - -## 0.8.1 - -- fixes in `Heap` -- package for `msat-bin` -- use `iter` instead of `sequence` in dune and opam files -- more docs - -## 0.8 - -big refactoring, change of API with fewer functions, etc. -see `git log` for more details. - -## 0.6.1 - -- add simple functor for DOT backend -- various bugfixes - -## 0.6 - -### Feature - -- An already instantiated sat solver in the Sat module -- A `full_slice` function for running possibly expensive satisfiability - tests (in SMT) when a propositional model has been found -- Forgetful propagations: propagations whose reason (i.e clause) is not watched - -## 0.5.1 - -### Bug - -- Removed some needless allocations - -### Breaking - -- Better interface for mcsat propagations - -### Feature - -- Allow level 0 semantic propagations - -## 0.5 - -### Bug - -- Grow heap when adding local hyps -- Avoid forgetting some one atom clauses -- Fixed a bug for propagations at level 0 -- Late propagations need to be re-propagated -- Fixed conflict at level 0 -- Avoid forgetting some theory conflict clauses - -### Breaking - -- Changed `if_sat` interface - -## 0.4.1 - -### Bug - -- fix bug in `add_clause` - -## 0.4 - -- performance improvements -- many bugfixes -- more tests - -### Breaking - -- remove push/pop (source of many bugs) -- replaced by solve : assumptions:lit list -> unit -> result - -### Features - -- Accept late conflict clauses -- cleaner API, moving some types outside the client-required interface - -## 0.3 - -### Features - -- Proofs for atoms at level 0 -- Compatibility with ocaml >= 4.00 -- Released some restrictions on dummy sat theories - -## 0.2 - -### Breaking - -- Log argument has been removed from functors -- All the functors now take a dummy last argument to ensure the solver modules are unique - -### Features - -- push/pop operations -- access to decision level when evaluating literals - diff --git a/src/sat/Sidekick_sat.ml b/src/sat/Sidekick_sat.ml index bbbb6089..89987049 100644 --- a/src/sat/Sidekick_sat.ml +++ b/src/sat/Sidekick_sat.ml @@ -1,35 +1,4 @@ (** Main API *) -open Sidekick_core -module Solver_intf = Solver_intf - -module type S = Solver_intf.S -module type LIT = Solver_intf.LIT -module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T - -type lbool = Solver_intf.lbool = L_true | L_false | L_undefined - -module type SAT_STATE = Solver_intf.SAT_STATE - -type sat_state = Solver_intf.sat_state - -type reason = Solver_intf.reason = - | Consequence of (unit -> Lit.t list * Proof_step.id) -[@@unboxed] - -module type ACTS = Solver_intf.ACTS - -type acts = (module ACTS) - -(** Print {!lbool} values *) -let pp_lbool out = function - | L_true -> Format.fprintf out "true" - | L_false -> Format.fprintf out "false" - | L_undefined -> Format.fprintf out "undefined" - -exception No_proof = Solver_intf.No_proof -exception Resource_exhausted = Solver_intf.Resource_exhausted - +include Sigs module Solver = Solver -module Make_cdcl_t = Solver.Make_cdcl_t -module Pure_sat = Solver.Pure_sat diff --git a/src/sat/Solver.ml b/src/sat/Solver.ml deleted file mode 100644 index 891274e2..00000000 --- a/src/sat/Solver.ml +++ /dev/null @@ -1,2565 +0,0 @@ -open Sidekick_core - -module type PLUGIN = sig - val has_theory : bool - (** [true] iff the solver is parametrized by a theory, not just - pure SAT. *) - - include Solver_intf.PLUGIN_CDCL_T -end - -module type S = Solver_intf.S -module type PLUGIN_CDCL_T = Solver_intf.PLUGIN_CDCL_T - -let invalid_argf fmt = - Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt - -(* ### types ### *) - -(* a boolean variable (positive int) *) -module Var0 : sig - include Int_id.S -end = struct - include Int_id.Make () -end - -type var = Var0.t - -(* a signed atom. +v is (v << 1), -v is (v<<1 | 1) *) -module Atom0 : sig - include Int_id.S - - val neg : t -> t - val sign : t -> bool - val of_var : var -> t - val var : t -> var - val pa : var -> t - val na : var -> t - - module AVec : Vec_sig.S with type elt := t - module ATbl : CCHashtbl.S with type key = t -end = struct - include Int_id.Make () - - let[@inline] neg i = i lxor 1 - let[@inline] sign i = i land 1 = 0 - let[@inline] pa v = (v : var :> int) lsl 1 - let of_var = pa - let[@inline] var a = Var0.of_int_unsafe (a lsr 1) - let[@inline] na v = ((v : var :> int) lsl 1) lor 1 - - module AVec = Veci - module ATbl = CCHashtbl.Make (CCInt) -end - -module Clause0 : sig - include Int_id.S - module Tbl : Hashtbl.S with type key = t - module CVec : Vec_sig.S with type elt := t -end = struct - include Int_id.Make () - module Tbl = Util.Int_tbl - module CVec = Veci -end - -module Step_vec = Proof_trace.Step_vec - -type atom = Atom0.t - -type clause = Clause0.t -and reason = Decision | Bcp of clause | Bcp_lazy of clause lazy_t - -module AVec = Atom0.AVec -(** Vector of atoms *) - -module ATbl = Atom0.ATbl -(** Hashtbl of atoms *) - -module CVec = Clause0.CVec -(** Vector of clauses *) - -(* ### stores ### *) - -module Lit_tbl = Hashtbl.Make (Lit) - -(* variable/atom store *) -module Store = struct - type cstore = { - c_lits: atom array Vec.t; (* storage for clause content *) - c_activity: Vec_float.t; - c_recycle_idx: Veci.t; (* recycle clause numbers that were GC'd *) - c_proof: Step_vec.t; (* clause -> proof_rule for its proof *) - c_attached: Bitvec.t; - c_marked: Bitvec.t; - c_removable: Bitvec.t; - c_dead: Bitvec.t; - } - - type t = { - (* variables *) - v_of_lit: var Lit_tbl.t; (* lit -> var *) - v_level: int Vec.t; (* decision/assignment level, or -1 *) - v_heap_idx: int Vec.t; (* index in priority heap *) - v_weight: Vec_float.t; (* heuristic activity *) - v_reason: reason option Vec.t; (* reason for assignment *) - v_seen: Bitvec.t; (* generic temporary marker *) - v_default_polarity: Bitvec.t; (* default polarity in decisions *) - mutable v_count: int; - (* atoms *) - a_is_true: Bitvec.t; - a_seen: Bitvec.t; - a_form: Lit.t Vec.t; - (* TODO: store watches in clauses instead *) - a_watched: Clause0.CVec.t Vec.t; - a_proof_lvl0: Proof_step.id ATbl.t; - (* atom -> proof for it to be true at level 0 *) - stat_n_atoms: int Stat.counter; - (* clauses *) - c_store: cstore; - } - - type store = t - - let create ?(size = `Big) ~stat () : t = - let size_map = - match size with - | `Tiny -> 8 - | `Small -> 16 - | `Big -> 4096 - in - let stat_n_atoms = Stat.mk_int stat "sat.n-atoms" in - { - v_of_lit = Lit_tbl.create size_map; - v_level = Vec.create (); - v_heap_idx = Vec.create (); - v_weight = Vec_float.create (); - v_reason = Vec.create (); - v_seen = Bitvec.create (); - v_default_polarity = Bitvec.create (); - v_count = 0; - a_is_true = Bitvec.create (); - a_form = Vec.create (); - a_watched = Vec.create (); - a_seen = Bitvec.create (); - a_proof_lvl0 = ATbl.create 16; - stat_n_atoms; - c_store = - { - c_lits = Vec.create (); - c_activity = Vec_float.create (); - c_recycle_idx = Veci.create ~cap:0 (); - c_proof = Step_vec.create ~cap:0 (); - c_dead = Bitvec.create (); - c_attached = Bitvec.create (); - c_removable = Bitvec.create (); - c_marked = Bitvec.create (); - }; - } - - (** iterate on variables *) - let iter_vars self f = - Vec.iteri self.v_level ~f:(fun i _ -> f (Var0.of_int_unsafe i)) - - module Var = struct - include Var0 - - let[@inline] level self v = Vec.get self.v_level (v : var :> int) - let[@inline] set_level self v l = Vec.set self.v_level (v : var :> int) l - let[@inline] reason self v = Vec.get self.v_reason (v : var :> int) - let[@inline] set_reason self v r = Vec.set self.v_reason (v : var :> int) r - let[@inline] weight self v = Vec_float.get self.v_weight (v : var :> int) - - let[@inline] set_weight self v w = - Vec_float.set self.v_weight (v : var :> int) w - - let[@inline] mark self v = Bitvec.set self.v_seen (v : var :> int) true - let[@inline] unmark self v = Bitvec.set self.v_seen (v : var :> int) false - let[@inline] marked self v = Bitvec.get self.v_seen (v : var :> int) - - let[@inline] set_default_pol self v b = - Bitvec.set self.v_default_polarity (v : var :> int) b - - let[@inline] default_pol self v = - Bitvec.get self.v_default_polarity (v : var :> int) - - let[@inline] heap_idx self v = Vec.get self.v_heap_idx (v : var :> int) - - let[@inline] set_heap_idx self v i = - Vec.set self.v_heap_idx (v : var :> int) i - end - - module Atom = struct - include Atom0 - - let[@inline] lit self a = Vec.get self.a_form (a : atom :> int) - let lit = lit - let[@inline] mark self a = Bitvec.set self.a_seen (a : atom :> int) true - let[@inline] unmark self a = Bitvec.set self.a_seen (a : atom :> int) false - let[@inline] marked self a = Bitvec.get self.a_seen (a : atom :> int) - let[@inline] watched self a = Vec.get self.a_watched (a : atom :> int) - let[@inline] is_true self a = Bitvec.get self.a_is_true (a : atom :> int) - - let[@inline] set_is_true self a b = - Bitvec.set self.a_is_true (a : atom :> int) b - - let[@inline] is_false self a = is_true self (neg a) - let[@inline] has_value self a = is_true self a || is_false self a - let[@inline] reason self a = Var.reason self (var a) - let[@inline] level self a = Var.level self (var a) - let[@inline] marked_both self a = marked self a && marked self (neg a) - let proof_lvl0 self a = ATbl.get self.a_proof_lvl0 a - let set_proof_lvl0 self a p = ATbl.replace self.a_proof_lvl0 a p - let pp self fmt a = Lit.pp fmt (lit self a) - - let pp_a self fmt v = - if Array.length v = 0 then - Format.fprintf fmt "@<1>∅" - else ( - pp self fmt v.(0); - if Array.length v > 1 then - for i = 1 to Array.length v - 1 do - Format.fprintf fmt " @<1>∨ %a" (pp self) v.(i) - done - ) - - (* Complete debug printing *) - - let[@inline] pp_sign a = - if sign a then - "+" - else - "-" - - (* print level+reason of assignment *) - let debug_reason _self out = function - | n, _ when n < 0 -> Format.fprintf out "%%" - | n, None -> Format.fprintf out "%d" n - | n, Some Decision -> Format.fprintf out "@@%d" n - | n, Some (Bcp c) -> Format.fprintf out "->%d/%d" n (c :> int) - | n, Some (Bcp_lazy _) -> Format.fprintf out "->%d/" n - - let pp_level self out a = - let v = var a in - debug_reason self out (Var.level self v, Var.reason self v) - - let debug_value self out (a : atom) = - if is_true self a then - Format.fprintf out "T%a" (pp_level self) a - else if is_false self a then - Format.fprintf out "F%a" (pp_level self) a - else - () - - let debug self out a = - Format.fprintf out "%s%d[%a][atom:@[%a@]]" (pp_sign a) - (var a : var :> int) - (debug_value self) a Lit.pp (lit self a) - - let debug_a self out vec = - Array.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) vec - end - - module Clause : sig - include module type of Clause0 with type t = Clause0.t - - (** Make a clause with the given atoms *) - - val make_a : store -> removable:bool -> atom array -> Proof_step.id -> t - val make_l : store -> removable:bool -> atom list -> Proof_step.id -> t - val n_atoms : store -> t -> int - val marked : store -> t -> bool - val set_marked : store -> t -> bool -> unit - val attached : store -> t -> bool - val set_attached : store -> t -> bool -> unit - val removable : store -> t -> bool - val dead : store -> t -> bool - val set_dead : store -> t -> bool -> unit - - val dealloc : store -> t -> unit - (** Delete the clause *) - - val proof_step : store -> t -> Proof_step.id - val activity : store -> t -> float - val set_activity : store -> t -> float -> unit - val iter : store -> f:(atom -> unit) -> t -> unit - val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a - val for_all : store -> f:(atom -> bool) -> t -> bool - val atoms_a : store -> t -> atom array - val lits_l : store -> t -> Lit.t list - val lits_a : store -> t -> Lit.t array - val lits_iter : store -> t -> Lit.t Iter.t - val short_name : store -> t -> string - val pp : store -> Format.formatter -> t -> unit - val debug : store -> Format.formatter -> t -> unit - end = struct - include Clause0 - - (* TODO: store watch lists inside clauses *) - - let make_a (store : store) ~removable (atoms : atom array) proof_step : t = - let { - c_recycle_idx; - c_lits; - c_activity; - c_attached; - c_dead; - c_removable; - c_marked; - c_proof; - } = - store.c_store - in - (* allocate new ID *) - let cid = - if Veci.is_empty c_recycle_idx then - Vec.size c_lits - else - Veci.pop c_recycle_idx - in - - (* allocate space *) - (let new_len = cid + 1 in - Vec.ensure_size c_lits ~elt:[||] new_len; - Vec_float.ensure_size c_activity new_len; - Step_vec.ensure_size c_proof new_len; - Bitvec.ensure_size c_attached new_len; - Bitvec.ensure_size c_dead new_len; - Bitvec.ensure_size c_removable new_len; - Bitvec.ensure_size c_marked new_len; - - Bitvec.set c_removable cid removable); - - Vec.set c_lits cid atoms; - Step_vec.set c_proof cid proof_step; - - let c = of_int_unsafe cid in - c - - let make_l store ~removable atoms proof_rule : t = - make_a store ~removable (Array.of_list atoms) proof_rule - - let[@inline] n_atoms (store : store) (c : t) : int = - Array.length (Vec.get store.c_store.c_lits (c : t :> int)) - - let[@inline] iter (store : store) ~f c = - let { c_lits; _ } = store.c_store in - Array.iter f (Vec.get c_lits (c : t :> int)) - - exception Early_exit - - let for_all store ~f c = - try - iter store c ~f:(fun x -> if not (f x) then raise_notrace Early_exit); - true - with Early_exit -> false - - let fold (store : store) ~f acc c = - let { c_lits; _ } = store.c_store in - Array.fold_left f acc (Vec.get c_lits (c : t :> int)) - - let[@inline] marked store c = - Bitvec.get store.c_store.c_marked (c : t :> int) - - let[@inline] set_marked store c b = - Bitvec.set store.c_store.c_marked (c : t :> int) b - - let[@inline] attached store c = - Bitvec.get store.c_store.c_attached (c : t :> int) - - let[@inline] set_attached store c b = - Bitvec.set store.c_store.c_attached (c : t :> int) b - - let[@inline] dead store c = Bitvec.get store.c_store.c_dead (c : t :> int) - - let[@inline] set_dead store c b = - Bitvec.set store.c_store.c_dead (c : t :> int) b - - let[@inline] removable store c = - Bitvec.get store.c_store.c_removable (c : t :> int) - - let[@inline] proof_step store c = - Step_vec.get store.c_store.c_proof (c : t :> int) - - let dealloc store c : unit = - assert (dead store c); - let { - c_lits; - c_recycle_idx; - c_activity; - c_proof = _; - c_dead; - c_removable; - c_attached; - c_marked; - } = - store.c_store - in - - (* clear data *) - let cid = (c : t :> int) in - Bitvec.set c_attached cid false; - Bitvec.set c_dead cid false; - Bitvec.set c_removable cid false; - Bitvec.set c_marked cid false; - Vec.set c_lits cid [||]; - Vec_float.set c_activity cid 0.; - - Veci.push c_recycle_idx cid; - (* recycle idx *) - () - - let[@inline] activity store c = - Vec_float.get store.c_store.c_activity (c : t :> int) - - let[@inline] set_activity store c f = - Vec_float.set store.c_store.c_activity (c : t :> int) f - - let[@inline] atoms_a store c : atom array = - Vec.get store.c_store.c_lits (c : t :> int) - - let lits_l store c : Lit.t list = - let arr = atoms_a store c in - Util.array_to_list_map (Atom.lit store) arr - - let lits_a store c : Lit.t array = - let arr = atoms_a store c in - Array.map (Atom.lit store) arr - - let lits_iter store c : Lit.t Iter.t = - let arr = atoms_a store c in - Iter.of_array arr |> Iter.map (Atom.lit store) - - let short_name _store c = Printf.sprintf "cl[%d]" (c : t :> int) - - let pp store fmt c = - Format.fprintf fmt "(cl[%d] : %a" - (c : t :> int) - (Atom.pp_a store) (atoms_a store c) - - let debug store out c = - let atoms = atoms_a store c in - Format.fprintf out "(@[cl[%d]@ {@[%a@]}@])" - (c : t :> int) - (Atom.debug_a store) atoms - end - - (* allocate new variable *) - let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var = - let { - v_count; - v_of_lit; - v_level; - v_heap_idx; - v_weight; - v_reason; - v_seen; - v_default_polarity; - stat_n_atoms; - a_is_true; - a_seen; - a_watched; - a_form; - c_store = _; - a_proof_lvl0 = _; - } = - self - in - - let v_idx = v_count in - let v = Var.of_int_unsafe v_idx in - - Stat.incr stat_n_atoms; - - self.v_count <- 1 + v_idx; - Lit_tbl.add v_of_lit form v; - Vec.push v_level (-1); - Vec.push v_heap_idx (-1); - Vec.push v_reason None; - Vec_float.push v_weight 0.; - Bitvec.ensure_size v_seen v_idx; - Bitvec.ensure_size v_default_polarity v_idx; - Bitvec.set v_default_polarity v_idx pol; - - assert (Vec.size a_form = 2 * (v : var :> int)); - Bitvec.ensure_size a_is_true (2 * (v : var :> int)); - Bitvec.ensure_size a_seen (2 * (v : var :> int)); - Vec.push a_form form; - Vec.push a_watched (CVec.create ~cap:0 ()); - Vec.push a_form (Lit.neg form); - Vec.push a_watched (CVec.create ~cap:0 ()); - assert (Vec.get a_form (Atom.of_var v : atom :> int) == form); - - v - - (* create new variable *) - let alloc_var (self : t) ?default_pol (lit : Lit.t) : - var * Solver_intf.same_sign = - let lit, same_sign = Lit.norm_sign lit in - try Lit_tbl.find self.v_of_lit lit, same_sign - with Not_found -> - let v = alloc_var_uncached_ ?default_pol self lit in - v, same_sign - - let clear_var (self : t) (v : var) : unit = - Var.unmark self v; - Atom.unmark self (Atom.pa v); - Atom.unmark self (Atom.na v); - () - - let atom_of_var_ v same_sign : atom = - if same_sign then - Atom.pa v - else - Atom.na v - - let alloc_atom (self : t) ?default_pol lit : atom = - let var, same_sign = alloc_var self ?default_pol lit in - atom_of_var_ var same_sign - - let find_atom (self : t) lit : atom option = - let lit, same_sign = Lit.norm_sign lit in - match Lit_tbl.find self.v_of_lit lit with - | v -> Some (atom_of_var_ v same_sign) - | exception Not_found -> None -end - -module Make (Plugin : PLUGIN) = struct - type theory = Plugin.t - type clause = Clause0.t - type store = Store.t - - module Atom = Store.Atom - module Var = Store.Var - module Clause = Store.Clause - - module H = Heap.Make [@specialise] (struct - type store = Store.t - type t = var - - let[@inline] cmp store i j = Var.weight store j < Var.weight store i - (* comparison by weight *) - - let heap_idx = Var.heap_idx - let set_heap_idx = Var.set_heap_idx - let of_int_unsafe = Var.of_int_unsafe - end) - - (* cause of "unsat", possibly conditional to local assumptions *) - type unsat_cause = - | US_local of { - first: atom; (* assumption which was found to be proved false *) - core: atom list; (* the set of assumptions *) - } - | US_false of clause - (* true unsat *) - - exception E_sat - exception E_unsat of unsat_cause - exception UndecidedLit - exception Restart - exception Conflict of clause - - let var_decay : float = 1. /. 0.95 - (* inverse of the activity factor for variables *) - - let clause_decay : float = 1. /. 0.999 - (* inverse of the activity factor for clauses *) - - let restart_inc : float = 1.5 - (* multiplicative factor for restart limit *) - - let learntsize_inc : float = 1.1 - (* multiplicative factor for [learntsize_factor] at each restart *) - - (** Passed to clause pools when it's time to garbage collect clauses *) - module type GC_ARG = sig - val store : Store.t - val must_keep_clause : clause -> bool - val flag_clause_for_gc : clause -> unit - end - - (** A clause pool *) - module type CLAUSE_POOL = sig - val add : clause -> unit - val descr : unit -> string - val gc : (module GC_ARG) -> unit - val iter : f:(clause -> unit) -> unit - val needs_gc : unit -> bool - val size : unit -> int - end - - (* a clause pool *) - type clause_pool = (module CLAUSE_POOL) - - (* a pool with garbage collection determined by [P] *) - module Make_gc_cp (P : sig - val descr : unit -> string - val max_size : int ref - end) - () : CLAUSE_POOL = struct - let clauses_ : clause Vec.t = Vec.create () - (* Use a [Vec] so we can sort it. - TODO: when we can sort any vec, come back to that. *) - - let descr = P.descr - let add c = Vec.push clauses_ c - let iter ~f = Vec.iter ~f clauses_ - let size () = Vec.size clauses_ - let needs_gc () = size () > !P.max_size - - let gc (module G : GC_ARG) : unit = - (* find clauses to GC *) - let to_be_pushed_back = CVec.create () in - - (* sort by decreasing activity *) - Vec.sort clauses_ (fun c1 c2 -> - compare (Clause.activity G.store c2) (Clause.activity G.store c1)); - - while Vec.size clauses_ > !P.max_size do - let c = Vec.pop_exn clauses_ in - if G.must_keep_clause c then - CVec.push to_be_pushed_back c - (* must keep it, it's on the trail *) - else - G.flag_clause_for_gc c - done; - (* transfer back clauses we had to keep *) - CVec.iter ~f:(Vec.push clauses_) to_be_pushed_back; - () - end - - let make_gc_clause_pool_ ~descr ~max_size () : clause_pool = - (module Make_gc_cp - (struct - let descr = descr - let max_size = max_size - end) - ()) - - let[@inline] cp_size_ (module P : CLAUSE_POOL) : int = P.size () - let[@inline] cp_needs_gc_ (module P : CLAUSE_POOL) : bool = P.needs_gc () - let[@inline] cp_add_ (module P : CLAUSE_POOL) c : unit = P.add c - - let[@inline] cp_to_iter_ (module P : CLAUSE_POOL) yield : unit = - P.iter ~f:yield - - (* initial limit for the number of learnt clauses, 1/3 of initial - number of clauses by default *) - let learntsize_factor = 1. /. 3. - - (** Actions from theories and user, but to be done in specific points - of the solving loops. *) - module Delayed_actions : sig - type t - - val create : unit -> t - val is_empty : t -> bool - val clear_on_backtrack : t -> unit - val add_clause_learnt : t -> clause -> unit - val propagate_atom : t -> atom -> lvl:int -> clause lazy_t -> unit - val add_decision : t -> atom -> unit - - val iter : - decision:(atom -> unit) -> - propagate:(atom -> lvl:int -> clause lazy_t -> unit) -> - add_clause_learnt:(clause -> unit) -> - add_clause_pool:(clause -> clause_pool -> unit) -> - t -> - unit - end = struct - type t = { - clauses_to_add_learnt: CVec.t; - (* Clauses either assumed or pushed by the theory, waiting to be added. *) - clauses_to_add_in_pool: (clause * clause_pool) Vec.t; - (* clauses to add into a pool *) - mutable prop_level: int; - propagate: (atom * int * clause lazy_t) Vec.t; - decisions: atom Vec.t; - } - - let create () : t = - { - clauses_to_add_learnt = CVec.create (); - clauses_to_add_in_pool = Vec.create (); - prop_level = -1; - propagate = Vec.create (); - decisions = Vec.create (); - } - - let clear self = - let { - clauses_to_add_learnt; - clauses_to_add_in_pool; - prop_level = _; - propagate; - decisions; - } = - self - in - Vec.clear clauses_to_add_in_pool; - CVec.clear clauses_to_add_learnt; - Vec.clear propagate; - Vec.clear decisions - - let clear_on_backtrack self = - let { - clauses_to_add_learnt = _; - clauses_to_add_in_pool = _; - propagate; - prop_level = _; - decisions; - } = - self - in - Vec.clear propagate; - Vec.clear decisions - - let is_empty self = - let { - clauses_to_add_learnt; - clauses_to_add_in_pool; - prop_level = _; - propagate; - decisions; - } = - self - in - Vec.is_empty clauses_to_add_in_pool - && CVec.is_empty clauses_to_add_learnt - && Vec.is_empty decisions && Vec.is_empty propagate - - let add_clause_learnt (self : t) c = CVec.push self.clauses_to_add_learnt c - - let propagate_atom self p ~lvl c = - if (not (Vec.is_empty self.propagate)) && lvl < self.prop_level then - Vec.clear self.propagate - (* will be immediately backtracked *); - if lvl <= self.prop_level then ( - self.prop_level <- lvl; - Vec.push self.propagate (p, lvl, c) - ) - - let add_decision self p = Vec.push self.decisions p - - let iter ~decision ~propagate ~add_clause_learnt ~add_clause_pool self : - unit = - let { - clauses_to_add_learnt; - clauses_to_add_in_pool; - prop_level = _; - propagate = prop; - decisions; - } = - self - in - Vec.iter clauses_to_add_in_pool ~f:(fun (c, p) -> add_clause_pool c p); - CVec.iter ~f:add_clause_learnt clauses_to_add_learnt; - Vec.iter ~f:decision decisions; - Vec.iter prop ~f:(fun (p, lvl, c) -> propagate p ~lvl c); - clear self; - () - end - - (* Singleton type containing the current state *) - type t = { - store: store; (* atom/var/clause store *) - th: theory; (* user defined theory *) - proof: Proof_trace.t; (* the proof object *) - (* Clauses are simplified for efficiency purposes. In the following - vectors, the comments actually refer to the original non-simplified - clause. *) - clauses_hyps: CVec.t; (* clauses added by the user, never removed *) - max_clauses_learnt: int ref; (* used to direct GC in {!clauses_learnt} *) - clauses_learnt: clause_pool; - (* learnt clauses (tautologies true at any time, whatever the user level). - GC'd regularly. *) - clause_pools: clause_pool Vec.t; (* custom clause pools *) - delayed_actions: Delayed_actions.t; - mutable unsat_at_0: clause option; (* conflict at level 0, if any *) - mutable next_decisions: atom list; - (* When the last conflict was a semantic one (mcsat), - this stores the next decision to make; - if some theory wants atoms to be decided on (for theory combination), - store them here. *) - trail: AVec.t; - (* decision stack + propagated elements (atoms or assignments). *) - var_levels: Veci.t; (* decision levels in [trail] *) - assumptions: AVec.t; (* current assumptions *) - mutable th_head: int; - (* Start offset in the queue {!trail} of - unit facts not yet seen by the theory. *) - mutable elt_head: int; - (* Start offset in the queue {!trail} of - unit facts to propagate, within the trail *) - (* invariant: - - during propagation, th_head <= elt_head - - then, once elt_head reaches length trail, Th.assume is - called so that th_head can catch up with elt_head - - this is repeated until a fixpoint is reached; - - before a decision (and after the fixpoint), - th_head = elt_head = length trail - *) - order: H.t; (* Heap ordered by variable activity *) - to_clear: var Vec.t; (* variables to unmark *) - (* temporaries *) - temp_atom_vec: AVec.t; - temp_clause_vec: CVec.t; - temp_step_vec: Step_vec.t; - mutable var_incr: float; (* increment for variables' activity *) - mutable clause_incr: float; (* increment for clauses' activity *) - (* FIXME: use event *) - on_conflict: (Clause.t, unit) Event.Emitter.t; - on_decision: (Lit.t, unit) Event.Emitter.t; - on_learnt: (Clause.t, unit) Event.Emitter.t; - on_gc: (Lit.t array, unit) Event.Emitter.t; - stat: Stat.t; - n_conflicts: int Stat.counter; - n_propagations: int Stat.counter; - n_decisions: int Stat.counter; - n_restarts: int Stat.counter; - n_minimized_away: int Stat.counter; - } - - type solver = t - - (* intial restart limit *) - let restart_first = 100 - let _nop_on_conflict (_ : atom array) = () - - (* Starting environment. *) - let create_ ~store ~proof ~stat ~max_clauses_learnt (th : theory) : t = - { - store; - th; - unsat_at_0 = None; - next_decisions = []; - max_clauses_learnt; - clauses_hyps = CVec.create (); - clauses_learnt = - make_gc_clause_pool_ - ~descr:(fun () -> "cp.learnt-clauses") - ~max_size:max_clauses_learnt (); - delayed_actions = Delayed_actions.create (); - clause_pools = Vec.create (); - to_clear = Vec.create (); - temp_clause_vec = CVec.create (); - temp_atom_vec = AVec.create (); - temp_step_vec = Step_vec.create (); - th_head = 0; - elt_head = 0; - trail = AVec.create (); - var_levels = Veci.create (); - assumptions = AVec.create (); - order = H.create store; - var_incr = 1.; - clause_incr = 1.; - proof; - stat; - n_conflicts = Stat.mk_int stat "sat.n-conflicts"; - n_decisions = Stat.mk_int stat "sat.n-decisions"; - n_propagations = Stat.mk_int stat "sat.n-propagations"; - n_restarts = Stat.mk_int stat "sat.n-restarts"; - n_minimized_away = Stat.mk_int stat "sat.n-confl-lits-minimized-away"; - on_conflict = Event.Emitter.create (); - on_decision = Event.Emitter.create (); - on_learnt = Event.Emitter.create (); - on_gc = Event.Emitter.create (); - } - - let on_gc self = Event.of_emitter self.on_gc - let on_conflict self = Event.of_emitter self.on_conflict - let on_decision self = Event.of_emitter self.on_decision - let on_learnt self = Event.of_emitter self.on_learnt - - let create ?(stat = Stat.global) ?(size = `Big) ~proof (th : theory) : t = - let store = Store.create ~size ~stat () in - let max_clauses_learnt = ref 0 in - let self = create_ ~max_clauses_learnt ~store ~proof ~stat th in - self - - (* iterate on all learnt clauses, pools included *) - let iter_clauses_learnt_ (self : t) ~f : unit = - let[@inline] iter_pool (module P : CLAUSE_POOL) = P.iter ~f in - iter_pool self.clauses_learnt; - Vec.iter ~f:iter_pool self.clause_pools; - () - - let[@inline] decision_level st = Veci.size st.var_levels - let[@inline] nb_clauses st = CVec.size st.clauses_hyps - let stat self = self.stat - - (* Do we have a level-0 empty clause? *) - let[@inline] check_unsat_ st = - match st.unsat_at_0 with - | Some c -> raise (E_unsat (US_false c)) - | None -> () - - (* Variable and literal activity. - Activity is used to decide on which variable to decide when propagation - is done. Uses a heap (implemented in Iheap), to keep track of variable activity. - To be more general, the heap only stores the variable/literal id (i.e an int). - *) - let[@inline] insert_var_order st (v : var) : unit = H.insert st.order v - - (* find atom for the lit, if any *) - let[@inline] find_atom_ (self : t) (p : Lit.t) : atom option = - Store.find_atom self.store p - - (* create a new atom, pushing it into the decision queue if needed *) - let make_atom_ (self : t) ?default_pol (p : Lit.t) : atom = - let a = Store.alloc_atom self.store ?default_pol p in - if Atom.level self.store a < 0 then - insert_var_order self (Atom.var a) - else - assert (Atom.is_true self.store a || Atom.is_false self.store a); - a - - (* Rather than iterate over all the heap when we want to decrease all the - variables/literals activity, we instead increase the value by which - we increase the activity of 'interesting' var/lits. *) - let[@inline] var_decay_activity st = st.var_incr <- st.var_incr *. var_decay - - let[@inline] clause_decay_activity st = - st.clause_incr <- st.clause_incr *. clause_decay - - (* increase activity of [v] *) - let var_bump_activity self v = - let store = self.store in - Var.set_weight store v (Var.weight store v +. self.var_incr); - if Var.weight store v > 1e100 then ( - Store.iter_vars store (fun v -> - Var.set_weight store v (Var.weight store v *. 1e-100)); - self.var_incr <- self.var_incr *. 1e-100 - ); - if H.in_heap self.order v then H.decrease self.order v - - (* increase activity of clause [c] *) - let clause_bump_activity self (c : clause) : unit = - let store = self.store in - Clause.set_activity store c (Clause.activity store c +. self.clause_incr); - if Clause.activity store c > 1e20 then ( - let update_clause c = - Clause.set_activity store c (Clause.activity store c *. 1e-20) - in - iter_clauses_learnt_ self ~f:update_clause; - self.clause_incr <- self.clause_incr *. 1e-20 - ) - - (* Simplification of clauses. - - When adding new clauses, it is desirable to 'simplify' them, i.e - minimize the amount of literals in it, because it greatly reduces - the search space for new watched literals during propagation. - Additionally, we have to partition the lits, to ensure the watched - literals (which are the first two lits of the clause) are appropriate. - Indeed, it is better to watch true literals, and then unassigned literals. - Watching false literals should be a last resort, and come with constraints - (see {!add_clause}). - *) - exception Trivial - - (* get/build the proof for [a], which must be an atom true at level 0. - This uses a global cache to avoid repeated computations, as many clauses - might resolve against a given 0-level atom. *) - let rec proof_of_atom_lvl0_ (self : t) (a : atom) : Proof_step.id = - assert (Atom.is_true self.store a && Atom.level self.store a = 0); - - match Atom.proof_lvl0 self.store a with - | Some p -> p - | None -> - let p = - match Atom.reason self.store a with - | None -> assert false - | Some Decision -> assert false (* no decisions at level0 *) - | Some (Bcp c2 | Bcp_lazy (lazy c2)) -> - Log.debugf 50 (fun k -> - k "(@[sat.proof-of-atom-lvl0.clause@ %a@])" - (Clause.debug self.store) c2); - - let steps = ref [] in - (* recurse, so we get the whole level-0 resolution graph *) - Clause.iter self.store c2 ~f:(fun a2 -> - if not (Var.equal (Atom.var a) (Atom.var a2)) then ( - Log.debugf 50 (fun k -> - k - "(@[sat.proof-of-atom-lvl0@ :of %a@ @[:resolve-with@ \ - %a@]@])" - (Atom.debug self.store) a (Atom.debug self.store) a2); - - let p2 = proof_of_atom_lvl0_ self (Atom.neg a2) in - steps := p2 :: !steps - )); - - let proof_c2 = Clause.proof_step self.store c2 in - if !steps = [] then - proof_c2 - else - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.return (Atom.lit self.store a)) - ~hyps:Iter.(cons proof_c2 (of_list !steps)) - in - - Atom.set_proof_lvl0 self.store a p; - (* put in cache *) - p - - (* Preprocess clause, by doing the following: - - - Partition literals for new clauses, into: - - true literals (maybe makes the clause trivial if the lit is proved true at level 0) - - unassigned literals, yet to be decided - - false literals (not suitable to watch, those at level 0 can be removed from the clause) - and order them as such in the result. - - - Also, removes literals that are false at level0, and returns a proof for - their removal. - - Also, removes duplicates. - *) - let preprocess_clause_ (self : t) (c : Clause.t) : Clause.t = - let store = self.store in - let res0_proofs = ref [] in - (* steps of resolution at level 0 *) - let add_proof_lvl0_ p = res0_proofs := p :: !res0_proofs in - - let trues = Vec.create () in - let unassigned = Vec.create () in - let falses = Vec.create () in - - (* cleanup marks used to detect duplicates *) - let cleanup () = - Clause.iter store c ~f:(fun a -> Store.clear_var store (Atom.var a)) - in - - let consider_atom (a : atom) : unit = - if not (Atom.marked store a) then ( - Atom.mark store a; - if Atom.marked_both store a then raise Trivial; - - if Atom.is_true store a then ( - let lvl = Atom.level store a in - if lvl = 0 then - (* Atom true at level 0 gives a trivially true clause *) - raise Trivial; - Vec.push trues a - ) else if Atom.is_false store a then ( - let lvl = Atom.level store a in - if lvl = 0 then ( - (* Atom var false at level 0 can be eliminated from the clause, - but we need to kepp in mind that we used another clause to simplify it. *) - Log.debugf 50 (fun k -> - k "(@[sat.preprocess-clause.resolve-away-lvl0@ %a@])" - (Atom.debug store) a); - - let p = proof_of_atom_lvl0_ self (Atom.neg a) in - add_proof_lvl0_ p - ) else - Vec.push falses a - ) else - Vec.push unassigned a - ) - in - - (try - Clause.iter store c ~f:consider_atom; - cleanup () - with e -> - cleanup (); - raise e); - - (* merge all atoms together *) - let atoms = - let v = trues in - Vec.append ~into:v unassigned; - Vec.append ~into:v falses; - Vec.to_array v - in - - if !res0_proofs = [] then - (* no change except in the order of literals *) - Clause.make_a store atoms ~removable:(Clause.removable store c) - (Clause.proof_step store c) - else ( - assert (Array.length atoms < Clause.n_atoms store c); - (* some atoms were removed by resolution with level-0 clauses *) - Log.debugf 30 (fun k -> - k "(@[sat.add-clause.resolved-lvl-0@ :into [@[%a@]]@])" - (Atom.debug_a store) atoms); - let proof = - let lits = Iter.of_array atoms |> Iter.map (Atom.lit store) in - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause lits - ~hyps: - Iter.( - cons (Clause.proof_step self.store c) (of_list !res0_proofs)) - in - Clause.make_a store atoms proof ~removable:(Clause.removable store c) - ) - - let new_decision_level st = - assert (st.th_head = AVec.size st.trail); - assert (st.elt_head = AVec.size st.trail); - Veci.push st.var_levels (AVec.size st.trail); - Plugin.push_level st.th; - () - - (* Attach/Detach a clause. - - Atom clause is attached (to its watching lits) when it is first added, - either because it is assumed or learnt. - *) - let attach_clause (self : t) c = - let store = self.store in - assert (not @@ Clause.attached store c); - Log.debugf 20 (fun k -> - k "(@[sat.attach-clause@ %a@])" (Clause.debug store) c); - (* TODO: change when watchlist are updated *) - CVec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(0))) c; - CVec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(1))) c; - Clause.set_attached store c true; - () - - (* Backtracking. - Used to backtrack, i.e cancel down to [lvl] excluded, - i.e we want to go back to the state the solver was in - after decision level [lvl] was created and fully propagated. *) - let cancel_until (self : t) lvl = - let store = self.store in - assert (lvl >= 0); - (* Nothing to do if we try to backtrack to a non-existent level. *) - if decision_level self <= lvl then - Log.debugf 20 (fun k -> - k "(@[sat.cancel-until.nop@ :already-at-level <= %d@])" lvl) - else ( - Log.debugf 5 (fun k -> k "(@[sat.cancel-until %d@])" lvl); - (* We set the head of the solver and theory queue to what it was. *) - let head = ref (Veci.get self.var_levels lvl) in - self.elt_head <- !head; - self.th_head <- !head; - (* Now we need to cleanup the vars that are not valid anymore - (i.e to the right of elt_head in the queue. *) - for c = self.elt_head to AVec.size self.trail - 1 do - let a = AVec.get self.trail c in - (* Atom literal is unassigned, we nedd to add it back to - the heap of potentially assignable literals, unless it has - a level lower than [lvl], in which case we just move it back. *) - (* Atom variable is not true/false anymore, one of two things can happen: *) - if Atom.level store a <= lvl then ( - (* It is a late propagation, which has a level - lower than where we backtrack, so we just move it to the head - of the queue, to be propagated again. *) - AVec.set self.trail !head a; - head := !head + 1 - ) else ( - (* it is a result of bolean propagation, or a semantic propagation - with a level higher than the level to which we backtrack, - in that case, we simply unset its value and reinsert it into the heap. *) - Atom.set_is_true store a false; - Atom.set_is_true store (Atom.neg a) false; - Var.set_level store (Atom.var a) (-1); - Var.set_reason store (Atom.var a) None; - insert_var_order self (Atom.var a) - ) - done; - (* Recover the right theory state. *) - let n = decision_level self - lvl in - assert (n > 0); - (* Resize the vectors according to their new size. *) - AVec.shrink self.trail !head; - Veci.shrink self.var_levels lvl; - Plugin.pop_levels self.th n; - Delayed_actions.clear_on_backtrack self.delayed_actions; - (* TODO: for scoped clause pools, backtrack them *) - self.next_decisions <- [] - ); - () - - let pp_unsat_cause self out = function - | US_local { first = _; core } -> - Format.fprintf out "(@[unsat-cause@ :false-assumptions %a@])" - (Format.pp_print_list (Atom.pp self.store)) - core - | US_false c -> - Format.fprintf out "(@[unsat-cause@ :false %a@])" - (Clause.debug self.store) c - - (* Unsatisfiability is signaled through an exception, since it can happen - in multiple places (adding new clauses, or solving for instance). *) - let report_unsat self (us : unsat_cause) : _ = - Log.debugf 3 (fun k -> - k "(@[sat.unsat-conflict@ %a@])" (pp_unsat_cause self) us); - let us = - match us with - | US_false c -> - self.unsat_at_0 <- Some c; - Event.emit self.on_learnt c; - let p = Clause.proof_step self.store c in - Proof_trace.add_unsat self.proof p; - US_false c - | US_local _ -> us - in - raise (E_unsat us) - - (* Boolean propagation. - Wrapper function for adding a new propagated lit. *) - let enqueue_bool (self : t) a ~level:lvl reason : unit = - let store = self.store in - if Atom.is_false store a then ( - Log.debugf 0 (fun k -> - k "(@[sat.error.trying to enqueue a false literal %a@])" - (Atom.debug store) a); - assert false - ); - assert ( - (not (Atom.is_true store a)) - && Atom.level store a < 0 - && Atom.reason store a == None - && lvl >= 0); - (* backtrack if required *) - if lvl < decision_level self then cancel_until self lvl; - Atom.set_is_true store a true; - Var.set_level store (Atom.var a) lvl; - Var.set_reason store (Atom.var a) (Some reason); - AVec.push self.trail a; - Log.debugf 20 (fun k -> - k "(@[sat.enqueue[%d]@ %a@])" (AVec.size self.trail) (Atom.debug store) - a); - () - - (* swap elements of array *) - let[@inline] swap_arr a i j = - if i <> j then ( - let tmp = a.(i) in - a.(i) <- a.(j); - a.(j) <- tmp - ) - - (* move atoms assigned at high levels first *) - let put_high_level_atoms_first (store : store) (arr : atom array) : unit = - Array.iteri - (fun i a -> - if i > 0 && Atom.level store a > Atom.level store arr.(0) then - if (* move first to second, [i]-th to first, second to [i] *) - i = 1 - then - swap_arr arr 0 1 - else ( - let tmp = arr.(1) in - arr.(1) <- arr.(0); - arr.(0) <- arr.(i); - arr.(i) <- tmp - ) - else if i > 1 && Atom.level store a > Atom.level store arr.(1) then - swap_arr arr 1 i) - arr - - (* find which level to backtrack to, given a conflict clause - and a boolean stating whether it is - a UIP ("Unique Implication Point") - precond: the atom list is sorted by decreasing decision level *) - let backtrack_lvl (self : t) (arr : atom array) : int * bool = - let store = self.store in - if Array.length arr <= 1 then - 0, true - else ( - let a = arr.(0) in - let b = arr.(1) in - assert (Atom.level store a > 0); - if Atom.level store a > Atom.level store b then - ( (* backtrack below [a], so we can propagate [not a] *) - Atom.level store b, - true ) - else ( - assert (Atom.level store a = Atom.level store b); - assert (Atom.level store a >= 0); - max (Atom.level store a - 1) 0, false - ) - ) - - (* abtraction of the assignment level of [v] in an integer *) - let[@inline] abstract_level_ (self : t) (v : var) : int = - 1 lsl (Var.level self.store v land 31) - - exception Non_redundant - - (* can we remove [a] by self-subsuming resolutions with other lits - of the learnt clause? *) - let lit_redundant (self : t) (abstract_levels : int) (steps : Step_vec.t) - (v : var) : bool = - let store = self.store in - let to_unmark = self.to_clear in - let steps_size_init = Step_vec.size steps in - - (* save current state of [to_unmark] *) - let top = Vec.size to_unmark in - let rec aux v = - match Var.reason store v with - | None -> assert false - | Some Decision -> raise_notrace Non_redundant - | Some (Bcp c | Bcp_lazy (lazy c)) -> - let c_atoms = Clause.atoms_a store c in - assert (Var.equal v (Atom.var c_atoms.(0))); - if Proof_trace.enabled self.proof then - Step_vec.push steps (Clause.proof_step self.store c); - - (* check that all the other lits of [c] are marked or redundant *) - for i = 1 to Array.length c_atoms - 1 do - let v2 = Atom.var c_atoms.(i) in - let lvl_v2 = Var.level store v2 in - if not (Var.marked store v2) then ( - match Var.reason store v2 with - | None -> assert false - | _ when lvl_v2 = 0 -> - (* can always remove literals at level 0, but got - to update proof properly *) - if Proof_trace.enabled self.proof then ( - let p = proof_of_atom_lvl0_ self (Atom.neg c_atoms.(i)) in - Step_vec.push steps p - ) - | Some (Bcp _ | Bcp_lazy _) - when abstract_level_ self v2 land abstract_levels <> 0 -> - (* possibly removable, its level may comprise an atom in learnt clause *) - Vec.push to_unmark v2; - Var.mark store v2; - aux v2 - | Some _ -> raise_notrace Non_redundant - ) - done - in - try - aux v; - true - with Non_redundant -> - (* clear new marks, they are not actually redundant *) - for i = top to Vec.size to_unmark - 1 do - Var.unmark store (Vec.get to_unmark i) - done; - Vec.shrink to_unmark top; - Step_vec.shrink steps steps_size_init; - (* restore proof *) - false - - (* minimize conflict by removing atoms whose propagation history - is ultimately self-subsuming with [lits] *) - let minimize_conflict (self : t) (_c_level : int) (learnt : AVec.t) - (steps : Step_vec.t) : unit = - let store = self.store in - - (* abstraction of the levels involved in the conflict at all, - as logical "or" of each literal's approximate level *) - let abstract_levels = - AVec.fold_left - (fun lvl a -> lvl lor abstract_level_ self (Atom.var a)) - 0 learnt - in - - let j = ref 1 in - for i = 1 to AVec.size learnt - 1 do - let a = AVec.get learnt i in - let keep = - match Atom.reason store a with - | Some Decision -> true (* always keep decisions *) - | Some (Bcp _ | Bcp_lazy _) -> - not (lit_redundant self abstract_levels steps (Atom.var a)) - | None -> assert false - in - if keep then ( - AVec.set learnt !j a; - incr j - ) else - Stat.incr self.n_minimized_away - done; - AVec.shrink learnt !j; - () - - (* result of conflict analysis, containing the learnt clause and some - additional info. *) - type conflict_res = { - cr_backtrack_lvl: int; (* level to backtrack to *) - cr_learnt: atom array; (* lemma learnt from conflict *) - cr_is_uip: bool; (* conflict is UIP? *) - cr_steps: Step_vec.t; - } - - (* conflict analysis, starting with top of trail and conflict clause *) - let analyze (self : t) (c_clause : clause) : conflict_res = - let store = self.store in - - let to_unmark = self.to_clear in - (* for cleanup *) - Vec.clear to_unmark; - let learnt = self.temp_atom_vec in - AVec.clear learnt; - - let steps = self.temp_step_vec in - (* for proof *) - assert (Step_vec.is_empty steps); - - (* loop variables *) - let pathC = ref 0 in - let continue = ref true in - let blevel = ref 0 in - let c = ref (Some c_clause) in - (* current clause to analyze/resolve *) - let tr_ind = ref (AVec.size self.trail - 1) in - - (* pointer in trail *) - - (* conflict level *) - assert (decision_level self > 0); - let conflict_level = - if Plugin.has_theory then - Clause.fold store 0 c_clause ~f:(fun acc p -> - max acc (Atom.level store p)) - else - decision_level self - in - Log.debugf 30 (fun k -> - k "(@[sat.analyze-conflict@ :c-level %d@ :clause %a@])" conflict_level - (Clause.debug store) c_clause); - - while !continue do - (match !c with - | None -> - Log.debug 30 - "(@[sat.analyze-conflict: skipping resolution for semantic \ - propagation@])" - | Some clause -> - Log.debugf 30 (fun k -> - k "(@[sat.analyze-conflict.resolve@ %a@])" (Clause.debug store) - clause); - - if Clause.removable store clause then clause_bump_activity self clause; - if Proof_trace.enabled self.proof then - Step_vec.push steps (Clause.proof_step self.store clause); - - (* visit the current predecessors *) - let atoms = Clause.atoms_a store clause in - for j = 0 to Array.length atoms - 1 do - let q = atoms.(j) in - assert (Atom.has_value store q); - assert (Atom.level store q >= 0); - if Atom.level store q = 0 then ( - (* skip [q] entirely, resolved away at level 0 *) - assert (Atom.is_false store q); - if Proof_trace.enabled self.proof then ( - let step = proof_of_atom_lvl0_ self (Atom.neg q) in - Step_vec.push steps step - ) - ) else if not (Var.marked store (Atom.var q)) then ( - Var.mark store (Atom.var q); - Vec.push to_unmark (Atom.var q); - if Atom.level store q > 0 then ( - var_bump_activity self (Atom.var q); - if Atom.level store q >= conflict_level then - incr pathC - else ( - AVec.push learnt q; - blevel := max !blevel (Atom.level store q) - ) - ) - ) - done); - - (* look for the next node to expand *) - while - let a = AVec.get self.trail !tr_ind in - Log.debugf 30 (fun k -> - k "(@[sat.analyze-conflict.at-trail-elt@ %a@])" (Atom.debug store) a); - (not (Var.marked store (Atom.var a))) - || Atom.level store a < conflict_level - do - decr tr_ind - done; - let p = AVec.get self.trail !tr_ind in - decr pathC; - decr tr_ind; - match !pathC, Atom.reason store p with - | 0, _ -> - continue := false; - AVec.push learnt (Atom.neg p) - | n, Some (Bcp cl | Bcp_lazy (lazy cl)) -> - assert (n > 0); - assert (Atom.level store p >= conflict_level); - c := Some cl - | _, (None | Some Decision) -> assert false - done; - - Log.debugf 10 (fun k -> - k "(@[sat.conflict.res@ %a@])" (AVec.pp @@ Atom.debug store) learnt); - - (* minimize conflict, to get a more general lemma *) - minimize_conflict self conflict_level learnt steps; - - let cr_steps = Step_vec.copy steps in - Step_vec.clear self.temp_step_vec; - - (* cleanup marks *) - Vec.iter ~f:(Store.clear_var store) to_unmark; - Vec.clear to_unmark; - - (* put high-level literals first, so that: - - they make adequate watch lits - - the first literal is the UIP, if any *) - let cr_learnt = AVec.to_array learnt in - AVec.clear learnt; - Array.sort - (fun p q -> compare (Atom.level store q) (Atom.level store p)) - cr_learnt; - - (* put_high_level_atoms_first a; *) - let level, is_uip = backtrack_lvl self cr_learnt in - Log.debugf 10 (fun k -> - k "(@[sat.conflict.res.final@ :lvl %d@ {@[%a@]}@])" level - (Util.pp_array @@ Atom.debug store) - cr_learnt); - - { cr_backtrack_lvl = level; cr_learnt; cr_is_uip = is_uip; cr_steps } - - (* Get the correct vector to insert a clause in. *) - let[@inline] add_clause_to_vec_ ~pool self c = - if Clause.removable self.store c && Clause.n_atoms self.store c > 2 then - (* add clause to some pool/set of clauses *) - cp_add_ pool c - else - CVec.push self.clauses_hyps c - - (* add the learnt clause to the clause database, propagate, etc. *) - let record_learnt_clause (self : t) ~pool (cr : conflict_res) : unit = - let store = self.store in - (match cr.cr_learnt with - | [||] -> assert false - | [| fuip |] -> - assert (cr.cr_backtrack_lvl = 0 && decision_level self = 0); - - let p = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) - in - let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in - Event.emit self.on_learnt uclause; - - if Atom.is_false store fuip then - (* incompatible at level 0 *) - report_unsat self (US_false uclause) - else - (* no need to attach [uclause], it is true at level 0 *) - enqueue_bool self fuip ~level:0 (Bcp uclause) - | _ -> - let fuip = cr.cr_learnt.(0) in - let p = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) - in - let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in - - add_clause_to_vec_ ~pool self lclause; - attach_clause self lclause; - clause_bump_activity self lclause; - Event.emit self.on_learnt lclause; - assert cr.cr_is_uip; - enqueue_bool self fuip ~level:cr.cr_backtrack_lvl (Bcp lclause)); - var_decay_activity self; - clause_decay_activity self - - (* process a conflict: - - learn clause - - backtrack - - report unsat if conflict at level 0 - *) - let add_boolean_conflict (self : t) (confl : clause) : unit = - let store = self.store in - Log.debugf 5 (fun k -> - k "(@[sat.add-bool-conflict@ %a@])" (Clause.debug store) confl); - self.next_decisions <- []; - assert (decision_level self >= 0); - if - decision_level self = 0 - || Clause.for_all store confl ~f:(fun a -> Atom.level store a <= 0) - then - (* Top-level conflict *) - report_unsat self (US_false confl); - let cr = analyze self confl in - cancel_until self (max cr.cr_backtrack_lvl 0); - record_learnt_clause ~pool:self.clauses_learnt self cr - - (* Add a new clause, simplifying, propagating, and backtracking if - the clause is false in the current trail *) - let add_clause_ (self : t) ~pool (init : clause) : unit = - let store = self.store in - Log.debugf 30 (fun k -> - k "(@[sat.add-clause@ @[%a@]@])" (Clause.debug store) init); - (* Insertion of new lits is done before simplification. Indeed, else a lit in a - trivial clause could end up being not decided on, which is a bug. *) - Clause.iter store init ~f:(fun x -> insert_var_order self (Atom.var x)); - try - (* preprocess to remove dups, sort literals, etc. *) - let clause = preprocess_clause_ self init in - assert (Clause.removable store clause = Clause.removable store init); - - Log.debugf 5 (fun k -> - k "(@[sat.new-clause@ @[%a@]@])" (Clause.debug store) clause); - let atoms = Clause.atoms_a self.store clause in - match atoms with - | [||] -> report_unsat self @@ US_false clause - | [| a |] -> - cancel_until self 0; - if Atom.is_false store a then - (* cannot recover from this *) - report_unsat self @@ US_false clause - else if Atom.is_true store a then - () - (* atom is already true, (at level 0) nothing to do *) - else ( - Log.debugf 40 (fun k -> - k "(@[sat.add-clause.unit-clause@ :propagating %a@])" - (Atom.debug store) a); - add_clause_to_vec_ ~pool self clause; - enqueue_bool self a ~level:0 (Bcp clause) - ) - | _ -> - let a = atoms.(0) in - let b = atoms.(1) in - add_clause_to_vec_ ~pool self clause; - if Atom.is_false store a then ( - (* Atom need to be sorted in decreasing order of decision level, - or we might watch the wrong literals. *) - put_high_level_atoms_first store (Clause.atoms_a store clause); - attach_clause self clause; - add_boolean_conflict self clause - ) else ( - attach_clause self clause; - if Atom.is_false store b && not (Atom.has_value store a) then ( - (* unit, propagate [a] *) - let lvl = - Array.fold_left (fun m a -> max m (Atom.level store a)) 0 atoms - in - cancel_until self lvl; - Log.debugf 50 (fun k -> - k "(@[sat.add-clause.propagate@ %a@ :lvl %d@])" - (Atom.debug store) a lvl); - enqueue_bool self a ~level:lvl (Bcp clause) - ) - ) - with Trivial -> - Log.debugf 5 (fun k -> - k "(@[sat.add-clause@ :ignore-trivial @[%a@]@])" (Clause.debug store) - init) - - type watch_res = Watch_kept | Watch_removed - - (* boolean propagation. - [a] is the false atom, one of [c]'s two watch literals - [i] is the index of [c] in [a.watched] - @return whether [c] was removed from [a.watched] - *) - let propagate_in_clause (self : t) (a : atom) (c : clause) (i : int) : - watch_res = - let store = self.store in - let atoms = Clause.atoms_a store c in - let first = atoms.(0) in - if first = Atom.neg a then ( - (* false lit must be at index 1 *) - atoms.(0) <- atoms.(1); - atoms.(1) <- first - ) else - assert (Atom.neg a = atoms.(1)); - let first = atoms.(0) in - if Atom.is_true store first then - Watch_kept - (* true clause, keep it in watched *) - else ( - try - (* look for another watch lit *) - for k = 2 to Array.length atoms - 1 do - let ak = atoms.(k) in - if not (Atom.is_false store ak) then ( - (* watch lit found: update and exit *) - atoms.(1) <- ak; - atoms.(k) <- Atom.neg a; - (* remove [c] from [a.watched], add it to [ak.neg.watched] *) - CVec.push (Atom.watched store (Atom.neg ak)) c; - assert (Clause.equal (CVec.get (Atom.watched store a) i) c); - CVec.fast_remove (Atom.watched store a) i; - raise_notrace Exit - ) - done; - (* no watch lit found *) - if Atom.is_false store first then ( - (* clause is false *) - self.elt_head <- AVec.size self.trail; - raise_notrace (Conflict c) - ) else ( - Stat.incr self.n_propagations; - enqueue_bool self first ~level:(decision_level self) (Bcp c) - ); - Watch_kept - with Exit -> Watch_removed - ) - - (* propagate atom [a], which was just decided. This checks every - clause watching [a] to see if the clause is false, unit, or has - other possible watches - @param res the optional conflict clause that the propagation might trigger *) - let propagate_atom (self : t) a : unit = - let store = self.store in - let watched = Atom.watched store a in - let rec aux i = - if i >= CVec.size watched then - () - else ( - let c = CVec.get watched i in - assert (Clause.attached store c); - let j = - if Clause.dead store c then - i - (* remove on the fly *) - else ( - match propagate_in_clause self a c i with - | Watch_kept -> i + 1 - | Watch_removed -> i (* clause at this index changed *) - ) - in - aux j - ) - in - aux 0 - - exception Th_conflict of Clause.t - - let acts_add_clause self ?(keep = false) (l : Lit.t list) (p : Proof_step.id) - : unit = - let atoms = List.rev_map (make_atom_ self) l in - let removable = not keep in - let c = Clause.make_l self.store ~removable atoms p in - Log.debugf 5 (fun k -> - k "(@[sat.th.add-clause@ %a@])" (Clause.debug self.store) c); - (* will be added later, even if we backtrack *) - Delayed_actions.add_clause_learnt self.delayed_actions c - - let acts_add_decision_lit (self : t) (f : Lit.t) (sign : bool) : unit = - let store = self.store in - let a = make_atom_ self f in - let a = - if sign then - a - else - Atom.neg a - in - if not (Atom.has_value store a) then ( - Log.debugf 10 (fun k -> - k "(@[sat.th.add-decision-lit@ %a@])" (Atom.debug store) a); - Delayed_actions.add_decision self.delayed_actions a - ) - - let acts_raise self (l : Lit.t list) (p : Proof_step.id) : 'a = - let atoms = List.rev_map (make_atom_ self) l in - (* conflicts can be removed *) - let c = Clause.make_l self.store ~removable:true atoms p in - Log.debugf 5 (fun k -> - k "(@[@{sat.th.raise-conflict@}@ %a@])" - (Clause.debug self.store) c); - (* we can shortcut the rest of the theory propagations *) - raise_notrace (Th_conflict c) - - let check_consequence_lits_false_ self l p : unit = - let store = self.store in - Log.debugf 50 (fun k -> - k "(@[sat.check-consequence-lits: %a@ :for %a@])" - (Util.pp_list (Atom.debug store)) - l (Atom.debug store) p); - match List.find (fun a -> Atom.is_true store a) l with - | a -> - invalid_argf - "slice.acts_propagate:@ Consequence should contain only false \ - literals,@ but @[%a@] is true" - (Atom.debug store) (Atom.neg a) - | exception Not_found -> () - - let acts_propagate (self : t) f (expl : Solver_intf.reason) = - let store = self.store in - match expl with - | Solver_intf.Consequence mk_expl -> - let p = make_atom_ self f in - Log.debugf 30 (fun k -> - k "(@[sat.propagate-from-theory@ %a@])" (Atom.debug store) p); - if Atom.is_true store p then - () - else if Atom.is_false store p then ( - let lits, proof = mk_expl () in - let guard = - List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits - in - check_consequence_lits_false_ self guard p; - let c = Clause.make_l store ~removable:true (p :: guard) proof in - raise_notrace (Th_conflict c) - ) else ( - insert_var_order self (Atom.var p); - let c, level = - (* Check literals + proof eagerly, as it's safer. - - We could check invariants in a [lazy] block, - as conflict analysis would run in an environment where - the literals should be true anyway, since it's an extension of the - current trail. - (otherwise the propagated lit would have been backtracked and - discarded already.) - - However it helps catching propagation bugs to verify truthiness - of the guard (and level) eagerly. - *) - let lits, proof = mk_expl () in - let guard = - List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits - in - check_consequence_lits_false_ self guard p; - let level = - List.fold_left (fun l a -> max l (Atom.level store a)) 0 guard - in - assert (level <= decision_level self); - (* delay creating the actual clause. *) - lazy (Clause.make_l store ~removable:true (p :: guard) proof), level - in - Delayed_actions.propagate_atom self.delayed_actions p ~lvl:level c - ) - - let[@inline never] perform_delayed_actions_ (self : t) : unit = - let add_clause_learnt c = add_clause_ ~pool:self.clauses_learnt self c - and add_clause_pool c pool = add_clause_ ~pool self c - and decision a = self.next_decisions <- a :: self.next_decisions - and propagate p ~lvl c = - if Atom.is_true self.store p then - () - else if Atom.is_false self.store p then - raise_notrace (Th_conflict (Lazy.force c)) - else ( - Stat.incr self.n_propagations; - enqueue_bool self p ~level:lvl (Bcp_lazy c) - ) - in - Delayed_actions.iter self.delayed_actions ~add_clause_learnt - ~add_clause_pool ~propagate ~decision; - () - - let[@inline] has_no_delayed_actions (self : t) : bool = - Delayed_actions.is_empty self.delayed_actions - - let[@inline] perform_delayed_actions self = - if not (has_no_delayed_actions self) then perform_delayed_actions_ self - - let[@specialise] acts_iter self ~full head f : unit = - for - i = - if full then - 0 - else - head to AVec.size self.trail - 1 - do - let a = AVec.get self.trail i in - f (Atom.lit self.store a) - done - - let eval_atom_ self a = - if Atom.is_true self.store a then - Solver_intf.L_true - else if Atom.is_false self.store a then - Solver_intf.L_false - else - Solver_intf.L_undefined - - let[@inline] acts_eval_lit self (f : Lit.t) : Solver_intf.lbool = - let a = make_atom_ self f in - eval_atom_ self a - - let[@inline] acts_add_lit self ?default_pol f : unit = - ignore (make_atom_ ?default_pol self f : atom) - - let[@inline] current_slice st : Solver_intf.acts = - let module M = struct - let proof = st.proof - let iter_assumptions = acts_iter st ~full:false st.th_head - let eval_lit = acts_eval_lit st - let add_lit = acts_add_lit st - let add_clause = acts_add_clause st - let propagate = acts_propagate st - let raise_conflict c pr = acts_raise st c pr - let add_decision_lit = acts_add_decision_lit st - end in - (module M) - - (* full slice, for [if_sat] final check *) - let[@inline] full_slice st : Solver_intf.acts = - let module M = struct - let proof = st.proof - let iter_assumptions = acts_iter st ~full:true st.th_head - let eval_lit = acts_eval_lit st - let add_lit = acts_add_lit st - let add_clause = acts_add_clause st - let propagate = acts_propagate st - let raise_conflict c pr = acts_raise st c pr - let add_decision_lit = acts_add_decision_lit st - end in - (module M) - - (* Assert that the conflict is indeeed a conflict *) - let check_is_conflict_ self (c : Clause.t) : unit = - if not @@ Clause.for_all self.store c ~f:(Atom.is_false self.store) then ( - Log.debugf 0 (fun k -> - k "conflict should be false: %a" (Clause.debug self.store) c); - assert false - ) - - (* some boolean literals were decided/propagated within Msat. Now we - need to inform the theory of those assumptions, so it can do its job. - @return the conflict clause, if the theory detects unsatisfiability *) - let rec theory_propagate self : clause option = - assert (self.elt_head = AVec.size self.trail); - assert (self.th_head <= self.elt_head); - if self.th_head = self.elt_head then - None - (* fixpoint/no propagation *) - else ( - let slice = current_slice self in - self.th_head <- self.elt_head; - (* catch up *) - match Plugin.partial_check self.th slice with - | () -> - perform_delayed_actions self; - propagate self - | exception Th_conflict c -> - check_is_conflict_ self c; - Clause.iter self.store c ~f:(fun a -> - insert_var_order self (Atom.var a)); - Some c - ) - - (* fixpoint between boolean propagation and theory propagation - @return a conflict clause, if any *) - and propagate (st : t) : clause option = - (* First, treat the stack of lemmas/actions added by the theory, if any *) - perform_delayed_actions st; - (* Now, check that the situation is sane *) - assert (st.elt_head <= AVec.size st.trail); - if st.elt_head = AVec.size st.trail then - theory_propagate st - else ( - match - while st.elt_head < AVec.size st.trail do - let a = AVec.get st.trail st.elt_head in - propagate_atom st a; - st.elt_head <- st.elt_head + 1 - done - with - | () -> theory_propagate st - | exception Conflict c -> Some c - ) - - (* compute unsat core from assumption [a] *) - let analyze_final (self : t) (a : atom) : atom list = - let store = self.store in - Log.debugf 5 (fun k -> - k "(@[sat.analyze-final@ :lit %a@])" (Atom.debug store) a); - assert (Atom.is_false store a); - let core = ref [ a ] in - let idx = ref (AVec.size self.trail - 1) in - Var.mark store (Atom.var a); - let seen = ref [ Atom.var a ] in - while !idx >= 0 do - let a' = AVec.get self.trail !idx in - if Var.marked store (Atom.var a') then ( - match Atom.reason store a' with - | Some Decision -> core := a' :: !core - | Some (Bcp c | Bcp_lazy (lazy c)) -> - Clause.iter store c ~f:(fun a -> - let v = Atom.var a in - if not (Var.marked store v) then ( - seen := v :: !seen; - Var.mark store v - )) - | None -> () - ); - decr idx - done; - List.iter (Var.unmark store) !seen; - Log.debugf 5 (fun k -> - k "(@[sat.analyze-final.done@ :core %a@])" - (Format.pp_print_list (Atom.debug store)) - !core); - !core - - (* GC: remove some learnt clauses. - This works even during the proof with a non empty trail. *) - let reduce_clause_db (self : t) : unit = - let store = self.store in - - Log.debugf 3 (fun k -> - k "(@[sat.gc-clauses.start :max-learnt %d@])" !(self.max_clauses_learnt)); - - let to_be_gc = self.temp_clause_vec in - (* clauses to collect *) - assert (CVec.is_empty to_be_gc); - - (* atoms whose watches will need to be rebuilt to filter out - dead clauses *) - let dirty_atoms = self.temp_atom_vec in - assert (AVec.is_empty dirty_atoms); - - (* [a] is watching at least one removed clause, we'll need to - trim its watchlist *) - let[@inline] mark_dirty_atom a = - if not (Atom.marked store a) then ( - Atom.mark store a; - AVec.push dirty_atoms a - ) - in - - (* iter on the clauses that are used to explain atoms on the trail, - which we must therefore keep for now as they might participate in - conflict resolution *) - let iter_clauses_on_trail ~f : unit = - AVec.iter self.trail ~f:(fun a -> - match Atom.reason store a with - | Some (Bcp c) -> f c - | Some (Bcp_lazy lc) when Lazy.is_val lc -> f (Lazy.force lc) - | _ -> ()) - in - - iter_clauses_on_trail ~f:(fun c -> Clause.set_marked store c true); - - (* first, mark clauses used on the trail, we cannot GC them. - TODO: once we use DRUP, we can avoid marking level-0 explanations - as they will never participate in resolution. *) - AVec.iter - ~f:(fun a -> - match Atom.reason store a with - | Some (Bcp c) -> Clause.set_marked store c true - | Some (Bcp_lazy lc) when Lazy.is_val lc -> - Clause.set_marked store (Lazy.force lc) true - | _ -> ()) - self.trail; - - (* GC the clause [c] *) - let flag_clause_for_gc c : unit = - assert (Clause.removable store c); - Log.debugf 10 (fun k -> - k "(@[sat.gc.will-collect@ %a@])" (Clause.debug store) c); - CVec.push to_be_gc c; - Clause.set_dead store c true; - let atoms = Clause.atoms_a store c in - mark_dirty_atom (Atom.neg atoms.(0)); - (* need to remove from watchlists *) - mark_dirty_atom (Atom.neg atoms.(1)); - Event.emit self.on_gc (Clause.lits_a store c); - Proof_trace.delete self.proof (Clause.proof_step store c) - in - - let gc_arg = - (module struct - let store = self.store - let flag_clause_for_gc = flag_clause_for_gc - let must_keep_clause c = Clause.marked store c - end : GC_ARG) - in - - (* GC a pool, if it needs it *) - let gc_pool (module P : CLAUSE_POOL) : unit = - if P.needs_gc () then ( - Log.debugf 5 (fun k -> k "(@[sat.gc.pool@ :descr %s@])" (P.descr ())); - P.gc gc_arg - ) - in - - gc_pool self.clauses_learnt; - Vec.iter ~f:gc_pool self.clause_pools; - - let n_collected = CVec.size to_be_gc in - - (* update watchlist of dirty atoms *) - AVec.iter dirty_atoms ~f:(fun a -> - assert (Atom.marked store a); - Atom.unmark store a; - let w = Atom.watched store a in - CVec.filter_in_place (fun c -> not (Clause.dead store c)) w); - AVec.clear dirty_atoms; - - (* actually remove the clauses now that they are detached *) - CVec.iter ~f:(Clause.dealloc store) to_be_gc; - CVec.clear to_be_gc; - - (* remove marks on clauses on the trail *) - iter_clauses_on_trail ~f:(fun c -> Clause.set_marked store c false); - - Log.debugf 3 (fun k -> k "(@[sat.gc.done :collected %d@])" n_collected); - () - - (* Decide on a new literal, and enqueue it into the trail. - Return [true] if a decision was made. - @param full if true, do decisions; - if false, only pick from [self.next_decisions] - and [self.assumptions] *) - let pick_branch_lit ~full self : bool = - let rec pick_lit () = - match self.next_decisions with - | atom :: tl -> - self.next_decisions <- tl; - pick_with_given_atom atom - | [] when decision_level self < AVec.size self.assumptions -> - (* use an assumption *) - let a = AVec.get self.assumptions (decision_level self) in - if Atom.is_true self.store a then ( - new_decision_level self; - (* pseudo decision level, [a] is already true *) - pick_lit () - ) else if Atom.is_false self.store a then ( - (* root conflict, find unsat core *) - let core = analyze_final self a in - raise (E_unsat (US_local { first = a; core })) - ) else - pick_with_given_atom a - | [] when not full -> false - | [] -> - (match H.remove_min self.order with - | v -> - pick_with_given_atom - (if Var.default_pol self.store v then - Atom.pa v - else - Atom.na v) - | exception Not_found -> false) - (* pick a decision, trying [atom] first if it's not assigned yet. *) - and pick_with_given_atom (atom : atom) : bool = - let v = Atom.var atom in - if Var.level self.store v >= 0 then ( - assert ( - Atom.is_true self.store (Atom.pa v) - || Atom.is_true self.store (Atom.na v)); - pick_lit () - ) else ( - new_decision_level self; - let current_level = decision_level self in - enqueue_bool self atom ~level:current_level Decision; - Stat.incr self.n_decisions; - Event.emit self.on_decision (Atom.lit self.store atom); - true - ) - in - pick_lit () - - (* do some amount of search, until the number of conflicts or clause learnt - reaches the given parameters *) - let search (self : t) ~on_progress ~(max_conflicts : int) : unit = - Log.debugf 3 (fun k -> - k "(@[sat.search@ :max-conflicts %d@ :max-learnt %d@])" max_conflicts - !(self.max_clauses_learnt)); - let n_conflicts = ref 0 in - while true do - match propagate self with - | Some confl -> - (* Conflict *) - incr n_conflicts; - (* When the theory has raised Unsat, add_boolean_conflict - might 'forget' the initial conflict clause, and only add the - analyzed backtrack clause. So in those case, we use add_clause - to make sure the initial conflict clause is also added. *) - if Clause.attached self.store confl then - add_boolean_conflict self confl - else - add_clause_ ~pool:self.clauses_learnt self confl; - Stat.incr self.n_conflicts; - Event.emit self.on_conflict confl - | None -> - (* No Conflict *) - assert (self.elt_head = AVec.size self.trail); - assert (self.elt_head = self.th_head); - if max_conflicts > 0 && !n_conflicts >= max_conflicts then ( - Log.debug 1 "(sat.restarting)"; - cancel_until self 0; - Stat.incr self.n_restarts; - raise_notrace Restart - ); - - (* if decision_level() = 0 then simplify (); *) - let do_gc = - !(self.max_clauses_learnt) > 0 - && cp_size_ self.clauses_learnt - AVec.size self.trail - > !(self.max_clauses_learnt) - || Vec.exists cp_needs_gc_ self.clause_pools - in - if do_gc then ( - reduce_clause_db self; - on_progress () - ); - - let decided = pick_branch_lit ~full:true self in - if not decided then raise_notrace E_sat - done - - let eval_level (self : t) (a : atom) = - let lvl = Atom.level self.store a in - if Atom.is_true self.store a then ( - assert (lvl >= 0); - true, lvl - ) else if Atom.is_false self.store a then - false, lvl - else - raise UndecidedLit - - let[@inline] eval st lit = fst @@ eval_level st lit - - (* fixpoint of propagation and decisions until a model is found, or a - conflict is reached *) - let solve_ ~on_progress (self : t) : unit = - Log.debugf 5 (fun k -> - k "(@[sat.solve :assms %d@])" (AVec.size self.assumptions)); - check_unsat_ self; - try - perform_delayed_actions self; - (* add initial clauses *) - let max_conflicts = ref (float_of_int restart_first) in - let max_learnt = - ref (float_of_int (nb_clauses self) *. learntsize_factor) - in - while true do - on_progress (); - try - self.max_clauses_learnt := int_of_float !max_learnt; - search self ~on_progress ~max_conflicts:(int_of_float !max_conflicts) - with - | Restart -> - max_conflicts := !max_conflicts *. restart_inc; - max_learnt := !max_learnt *. learntsize_inc - | E_sat -> - assert ( - self.elt_head = AVec.size self.trail - && has_no_delayed_actions self - && self.next_decisions = []); - on_progress (); - (match Plugin.final_check self.th (full_slice self) with - | () -> - if - self.elt_head = AVec.size self.trail - && has_no_delayed_actions self - && self.next_decisions = [] - then - (* nothing more to do, that means the plugin is satisfied - with the trail *) - raise_notrace E_sat; - (* otherwise, keep on *) - perform_delayed_actions self - | exception Th_conflict c -> - check_is_conflict_ self c; - Clause.iter self.store c ~f:(fun a -> - insert_var_order self (Atom.var a)); - Log.debugf 5 (fun k -> - k "(@[sat.theory-conflict-clause@ %a@])" - (Clause.debug self.store) c); - Stat.incr self.n_conflicts; - Event.emit self.on_conflict c; - Delayed_actions.add_clause_learnt self.delayed_actions c; - perform_delayed_actions self; - on_progress ()) - done - with E_sat -> () - - let assume self cnf : unit = - List.iter - (fun l -> - let atoms = Util.array_of_list_map (make_atom_ self) l in - let proof = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_list l) - in - let c = Clause.make_a self.store ~removable:false atoms proof in - Log.debugf 10 (fun k -> - k "(@[sat.assume-clause@ @[%a@]@])" (Clause.debug self.store) - c); - Delayed_actions.add_clause_learnt self.delayed_actions c) - cnf - - let[@inline] theory st = st.th - let[@inline] store st = st.store - let[@inline] proof st = st.proof - - let[@inline] add_lit self ?default_pol lit = - ignore (make_atom_ self lit ?default_pol : atom) - - let[@inline] set_default_pol (self : t) (lit : Lit.t) (pol : bool) : unit = - let a = make_atom_ self lit ~default_pol:pol in - Var.set_default_pol self.store (Atom.var a) pol - - (* Result type *) - type res = - | Sat of Solver_intf.sat_state - | Unsat of clause Solver_intf.unsat_state - - let pp_all self lvl status = - Log.debugf lvl (fun k -> - k - "(@[sat.full-state :res %s - Full summary:@,\ - @[Trail:@\n\ - %a@]@,\ - @[Hyps:@\n\ - %a@]@,\ - @[Lemmas:@\n\ - %a@]@,\ - @]@." - status - (AVec.pp @@ Atom.debug self.store) - self.trail - (CVec.pp @@ Clause.debug self.store) - self.clauses_hyps - (Util.pp_iter @@ Clause.debug self.store) - (cp_to_iter_ self.clauses_learnt)) - - let mk_sat (self : t) : Solver_intf.sat_state = - pp_all self 99 "SAT"; - let t = self.trail in - let module M = struct - let iter_trail f = AVec.iter ~f:(fun a -> f (Atom.lit self.store a)) t - let[@inline] eval f = eval self (make_atom_ self f) - let[@inline] eval_level f = eval_level self (make_atom_ self f) - end in - (module M) - - (* make a clause that contains no level-0 false literals, by resolving - against them. This clause can be used in a refutation proof. - Note that the clause might still contain some {b assumptions}. *) - let resolve_with_lvl0 (self : t) (c : clause) : clause = - let lvl0 = ref [] in - let res = ref [] in - let to_unmark = self.temp_atom_vec in - assert (AVec.is_empty to_unmark); - - (* resolve against the root cause of [a] being false *) - let resolve_with_a (a : atom) : unit = - assert (Atom.is_false self.store a && Atom.level self.store a = 0); - if not (Var.marked self.store (Atom.var a)) then ( - Log.debugf 50 (fun k -> - k "(@[sat.resolve-lvl0@ :atom %a@])" (Atom.debug self.store) a); - AVec.push to_unmark a; - Var.mark self.store (Atom.var a); - - let p = proof_of_atom_lvl0_ self (Atom.neg a) in - lvl0 := p :: !lvl0 - ) - in - - Clause.iter self.store c ~f:(fun a -> - if Atom.level self.store a = 0 then resolve_with_a a); - AVec.iter to_unmark ~f:(fun a -> Var.unmark self.store (Atom.var a)); - AVec.clear to_unmark; - - if !lvl0 = [] then - c - (* no resolution happened *) - else ( - let proof = - let lits = Iter.of_list !res |> Iter.map (Atom.lit self.store) in - let hyps = Iter.of_list (Clause.proof_step self.store c :: !lvl0) in - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause lits ~hyps - in - Clause.make_l self.store ~removable:false !res proof - ) - - let mk_unsat (self : t) (us : unsat_cause) : _ Solver_intf.unsat_state = - pp_all self 99 "UNSAT"; - let store = store self in - let unsat_assumptions () = - match us with - | US_local { first = _; core } -> - let lits = Iter.of_list core |> Iter.map (Atom.lit store) in - lits - | _ -> Iter.empty - in - let unsat_conflict = - match us with - | US_false c0 -> - Log.debugf 10 (fun k -> - k "(@[sat.unsat-conflict-clause@ %a@])" (Clause.debug store) c0); - let c = resolve_with_lvl0 self c0 in - Log.debugf 10 (fun k -> - k "(@[sat.unsat-conflict-clause.proper@ %a@])" (Clause.debug store) - c); - fun () -> c - | US_local { core = []; _ } -> assert false - | US_local { first; core } -> - (* TODO: do we need to filter out literals? *) - let c = - lazy - (let core = List.rev core in - (* increasing trail order *) - assert (Atom.equal first @@ List.hd core); - let proof = - let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in - Proof_trace.add_step self.proof @@ Proof_sat.sat_unsat_core lits - in - Clause.make_l self.store ~removable:false [] proof) - in - fun () -> Lazy.force c - in - let module M = struct - type clause = Clause.t - - let unsat_conflict = unsat_conflict - let unsat_assumptions = unsat_assumptions - - let unsat_proof () = - let c = unsat_conflict () in - Clause.proof_step self.store c - end in - (module M) - - type propagation_result = - | PR_sat - | PR_conflict of { backtracked: int } - | PR_unsat of clause Solver_intf.unsat_state - - (* decide on assumptions, and do propagations, but no other kind of decision *) - let propagate_under_assumptions (self : t) : propagation_result = - let result = ref PR_sat in - try - while true do - match propagate self with - | Some confl -> - (* When the theory has raised Unsat, add_boolean_conflict - might 'forget' the initial conflict clause, and only add the - analyzed backtrack clause. So in those case, we use add_clause - to make sure the initial conflict clause is also added. *) - if Clause.attached self.store confl then - add_boolean_conflict self confl - else - add_clause_ ~pool:self.clauses_learnt self confl; - Stat.incr self.n_conflicts; - - (* see by how much we backtracked the decision trail *) - let new_lvl = decision_level self in - assert (new_lvl < AVec.size self.assumptions); - let backtracked = AVec.size self.assumptions - new_lvl in - result := PR_conflict { backtracked }; - AVec.shrink self.assumptions new_lvl; - raise_notrace Exit - | None -> - (* No Conflict *) - let decided = pick_branch_lit self ~full:false in - if not decided then ( - result := PR_sat; - raise Exit - ) - done; - assert false - with Exit -> !result - - let add_clause_atoms_ self ~pool ~removable (c : atom array) - (pr : Proof_step.id) : unit = - try - let c = Clause.make_a self.store ~removable c pr in - add_clause_ ~pool self c - with E_unsat (US_false c) -> self.unsat_at_0 <- Some c - - let add_clause_a self c pr : unit = - let c = Array.map (make_atom_ self) c in - add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr - - let add_clause self (c : Lit.t list) (pr : Proof_step.id) : unit = - let c = Util.array_of_list_map (make_atom_ self) c in - add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr - - let add_input_clause self (c : Lit.t list) = - let pr = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_list c) - in - add_clause self c pr - - let add_input_clause_a self c = - let pr = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_array c) - in - add_clause_a self c pr - - (* run [f()] with additional assumptions *) - let with_local_assumptions_ (self : t) (assumptions : Lit.t list) f = - let old_assm_lvl = AVec.size self.assumptions in - List.iter - (fun lit -> - let a = make_atom_ self lit in - AVec.push self.assumptions a) - assumptions; - try - let x = f () in - AVec.shrink self.assumptions old_assm_lvl; - x - with e -> - AVec.shrink self.assumptions old_assm_lvl; - raise e - - let solve ?(on_progress = fun _ -> ()) ?(assumptions = []) (self : t) : res = - cancel_until self 0; - (* make sure we are at level 0 *) - with_local_assumptions_ self assumptions @@ fun () -> - try - solve_ ~on_progress self; - Sat (mk_sat self) - with E_unsat us -> Unsat (mk_unsat self us) - - let push_assumption (self : t) (lit : Lit.t) : unit = - let a = make_atom_ self lit in - AVec.push self.assumptions a - - let pop_assumptions self n : unit = - let n_ass = AVec.size self.assumptions in - assert (n <= n_ass); - AVec.shrink self.assumptions (n_ass - n) - - let check_sat_propagations_only ?(assumptions = []) (self : t) : - propagation_result = - cancel_until self 0; - with_local_assumptions_ self assumptions @@ fun () -> - try - check_unsat_ self; - perform_delayed_actions self; - (* add initial clauses *) - propagate_under_assumptions self - with E_unsat us -> - let us = mk_unsat self us in - PR_unsat us - - let true_at_level0 (self : t) (lit : Lit.t) : bool = - match find_atom_ self lit with - | None -> false - | Some a -> - (try - let b, lev = eval_level self a in - b && lev = 0 - with UndecidedLit -> false) - - let[@inline] eval_lit self (lit : Lit.t) : Solver_intf.lbool = - match find_atom_ self lit with - | Some a -> eval_atom_ self a - | None -> Solver_intf.L_undefined -end -[@@inline] [@@specialise] - -module Make_cdcl_t (Plugin : Solver_intf.PLUGIN_CDCL_T) = Make (struct - include Plugin - - let has_theory = true -end) -[@@inline] [@@specialise] - -module Pure_sat = Make (struct - type t = unit - - let push_level () = () - let pop_levels _ _ = () - let partial_check () _ = () - let final_check () _ = () - let has_theory = false -end) -[@@specialise] diff --git a/src/sat/Solver.mli b/src/sat/Solver.mli deleted file mode 100644 index 499e94ee..00000000 --- a/src/sat/Solver.mli +++ /dev/null @@ -1,5 +0,0 @@ -module type S = Solver_intf.S -(** Safe external interface of solvers. *) - -module Pure_sat : S with type theory = unit -module Make_cdcl_t (Th : Solver_intf.PLUGIN_CDCL_T) : S with type theory = Th.t diff --git a/src/sat/Solver_intf.ml b/src/sat/Solver_intf.ml deleted file mode 100644 index f3630ba0..00000000 --- a/src/sat/Solver_intf.ml +++ /dev/null @@ -1,342 +0,0 @@ -(** Interface for Solvers - - This modules defines the safe external interface for solvers. - Solvers that implements this interface can be obtained using the [Make] - functor. -*) - -(* -MSAT is free software, using the Apache license, see file LICENSE -Copyright 2016 Guillaume Bury -Copyright 2016 Simon Cruanes -*) - -open Sidekick_core - -type 'a printer = Format.formatter -> 'a -> unit - -(** Solver in a "SATISFIABLE" state *) -module type SAT_STATE = sig - val eval : Lit.t -> bool - (** Returns the valuation of a lit in the current state - of the sat solver. - @raise UndecidedLit if the literal is not decided *) - - val eval_level : Lit.t -> bool * int - (** Return the current assignement of the literals, as well as its - decision level. If the level is 0, then it is necessary for - the literal to have this value; otherwise it is due to choices - that can potentially be backtracked. - @raise UndecidedLit if the literal is not decided *) - - val iter_trail : (Lit.t -> unit) -> unit - (** Iter through the lits in order of decision/propagation - (starting from the first propagation, to the last propagation). *) -end - -type sat_state = (module SAT_STATE) -(** The type of values returned when the solver reaches a SAT state. *) - -(** Solver in an "UNSATISFIABLE" state *) -module type UNSAT_STATE = sig - type clause - - val unsat_conflict : unit -> clause - (** Returns the unsat clause found at the toplevel *) - - val unsat_assumptions : unit -> Lit.t Iter.t - (** Subset of assumptions responsible for "unsat" *) - - val unsat_proof : unit -> Proof_term.step_id -end - -type 'clause unsat_state = (module UNSAT_STATE with type clause = 'clause) -(** The type of values returned when the solver reaches an UNSAT state. *) - -type same_sign = bool -(** This type is used during the normalisation of lits. - [true] means the literal stayed the same, [false] that its sign was flipped. *) - -(** The type of reasons for propagations of a lit [f]. *) -type reason = Consequence of (unit -> Lit.t list * Proof_step.id) [@@unboxed] -(** [Consequence (l, p)] means that the lits in [l] imply the propagated - lit [f]. The proof should be a proof of the clause "[l] implies [f]". - - invariant: in [Consequence (fun () -> l,p)], all elements of [l] must be true in - the current trail. - - {b note} on lazyiness: the justification is suspended (using [unit -> …]) - to avoid potentially costly computations that might never be used - if this literal is backtracked without participating in a conflict. - Therefore the function that produces [(l,p)] needs only be safe in - trails (partial models) that are conservative extensions of the current - trail. - If the theory isn't robust w.r.t. extensions of the trail (e.g. if - its internal state undergoes significant changes), - it can be easier to produce the explanation eagerly when - propagating, and then use [Consequence (fun () -> expl, proof)] with - the already produced [(expl,proof)] tuple. - *) - -type lbool = L_true | L_false | L_undefined (** Valuation of an atom *) - -(** Actions available to the Plugin - - The plugin provides callbacks for the SAT solver to use. These callbacks - are provided with a [(module ACTS)] so they can modify the SAT solver - by adding new lemmas, raise conflicts, etc. *) -module type ACTS = sig - val proof : Proof_trace.t - - val iter_assumptions : (Lit.t -> unit) -> unit - (** Traverse the new assumptions on the boolean trail. *) - - val eval_lit : Lit.t -> lbool - (** Obtain current value of the given literal *) - - val add_lit : ?default_pol:bool -> Lit.t -> unit - (** Map the given lit to an internal atom, which will be decided by the - SAT solver. *) - - val add_clause : ?keep:bool -> Lit.t list -> Proof_step.id -> unit - (** Add a clause to the solver. - @param keep if true, the clause will be kept by the solver. - Otherwise the solver is allowed to GC the clause and propose this - partial model again. - - [C_use_allocator alloc] puts the clause in the given allocator. - *) - - val raise_conflict : Lit.t list -> Proof_step.id -> 'b - (** Raise a conflict, yielding control back to the solver. - The list of atoms must be a valid theory lemma that is false in the - current trail. *) - - val propagate : Lit.t -> reason -> unit - (** Propagate a lit, i.e. the theory can evaluate the lit to be true - (see the definition of {!type:eval_res} *) - - val add_decision_lit : Lit.t -> bool -> unit - (** Ask the SAT solver to decide on the given lit with given sign - before it can answer [SAT]. The order of decisions is still unspecified. - Useful for theory combination. This will be undone on backtracking. *) -end - -type acts = (module ACTS) -(** The type for a slice of assertions to assume/propagate in the theory. *) - -exception No_proof - -module type LIT = sig - (** lits *) - - type t - (** The type of atomic lits over terms. *) - - val equal : t -> t -> bool - (** Equality over lits. *) - - val hash : t -> int - (** Hashing function for lits. Should be such that two lits equal according - to {!val:Expr_intf.S.equal} have the same hash. *) - - val pp : t printer - (** Printing function used among other thing for debugging. *) - - val neg : t -> t - (** Formula negation *) - - val norm_sign : t -> t * same_sign - (** Returns a 'normalized' form of the lit, possibly same_sign - (in which case return [false]). - [norm] must be so that [a] and [neg a] normalise to the same lit, - but one returns [false] and the other [true]. *) -end - -(** Signature for theories to be given to the CDCL(T) solver *) -module type PLUGIN_CDCL_T = sig - type t - (** The plugin state itself *) - - val push_level : t -> unit - (** Create a new backtrack level *) - - val pop_levels : t -> int -> unit - (** Pop [n] levels of the theory *) - - val partial_check : t -> acts -> unit - (** Assume the lits in the slice, possibly using the [slice] - to push new lits to be propagated or to raising a conflict or to add - new lemmas. *) - - val final_check : t -> acts -> unit - (** Called at the end of the search in case a model has been found. - If no new clause is pushed, then proof search ends and "sat" is returned; - if lemmas are added, search is resumed; - if a conflict clause is added, search backtracks and then resumes. *) -end - -exception Resource_exhausted -(** Can be raised in a progress handler *) - -(** The external interface implemented by safe solvers, such as the one - created by the {!Solver.Make} and {!Mcsolver.Make} functors. *) -module type S = sig - (** literals *) - - type clause - type theory - - type solver - (** The main solver type. *) - - type store - (** Stores atoms, clauses, etc. *) - - module Clause : sig - type t = clause - - val equal : t -> t -> bool - - module Tbl : Hashtbl.S with type key = t - - val pp : store -> t printer - (** Print the clause *) - - val short_name : store -> t -> string - (** Short name for a clause. Unspecified *) - - val n_atoms : store -> t -> int - - val lits_iter : store -> t -> Lit.t Iter.t - (** Literals of a clause *) - - val lits_a : store -> t -> Lit.t array - (** Atoms of a clause *) - - val lits_l : store -> t -> Lit.t list - (** List of atoms of a clause *) - end - - (** {2 Main Solver Type} *) - - type t = solver - (** Main solver type, containing all state for solving. *) - - val create : - ?stat:Stat.t -> - ?size:[ `Tiny | `Small | `Big ] -> - proof:Proof_trace.t -> - theory -> - t - (** Create new solver - @param theory the theory - @param the proof - @param size the initial size of internal data structures. The bigger, - the faster, but also the more RAM it uses. *) - - val theory : t -> theory - (** Access the theory state *) - - val store : t -> store - (** Store for the solver *) - - val stat : t -> Stat.t - (** Statistics *) - - val proof : t -> Proof_trace.t - (** Access the inner proof *) - - val on_conflict : t -> (Clause.t, unit) Event.t - val on_decision : t -> (Lit.t, unit) Event.t - val on_learnt : t -> (Clause.t, unit) Event.t - val on_gc : t -> (Lit.t array, unit) Event.t - - (** {2 Types} *) - - (** Result type for the solver *) - type res = - | Sat of sat_state - (** Returned when the solver reaches SAT, with a model *) - | Unsat of clause unsat_state - (** Returned when the solver reaches UNSAT, with a proof *) - - exception UndecidedLit - (** Exception raised by the evaluating functions when a literal - has not yet been assigned a value. *) - - (** {2 Base operations} *) - - val assume : t -> Lit.t list list -> unit - (** Add the list of clauses to the current set of assumptions. - Modifies the sat solver state in place. *) - - val add_clause : t -> Lit.t list -> Proof_step.id -> unit - (** Lower level addition of clauses *) - - val add_clause_a : t -> Lit.t array -> Proof_step.id -> unit - (** Lower level addition of clauses *) - - val add_input_clause : t -> Lit.t list -> unit - (** Like {!add_clause} but with the justification of being an input clause *) - - val add_input_clause_a : t -> Lit.t array -> unit - (** Like {!add_clause_a} but with justification of being an input clause *) - - (** {2 Solving} *) - - val solve : ?on_progress:(unit -> unit) -> ?assumptions:Lit.t list -> t -> res - (** Try and solves the current set of clauses. - @param assumptions additional atomic assumptions to be temporarily added. - The assumptions are just used for this call to [solve], they are - not saved in the solver's state. - @param on_progress regularly called during solving. - Can raise {!Resource_exhausted} - to stop solving. - - @raise Resource_exhausted if the on_progress handler raised it to stop - *) - - (** {2 Evaluating and adding literals} *) - - val add_lit : t -> ?default_pol:bool -> Lit.t -> unit - (** Ensure the SAT solver handles this particular literal, ie add - a boolean variable for it if it's not already there. *) - - val set_default_pol : t -> Lit.t -> bool -> unit - (** Set default polarity for the given boolean variable. - Sign of the literal is ignored. *) - - val true_at_level0 : t -> Lit.t -> bool - (** [true_at_level0 a] returns [true] if [a] was proved at level0, i.e. - it must hold in all models *) - - val eval_lit : t -> Lit.t -> lbool - (** Evaluate atom in current state *) - - (** {2 Assumption stack} *) - - val push_assumption : t -> Lit.t -> unit - (** Pushes an assumption onto the assumption stack. It will remain - there until it's pop'd by {!pop_assumptions}. *) - - val pop_assumptions : t -> int -> unit - (** [pop_assumptions solver n] removes [n] assumptions from the stack. - It removes the assumptions that were the most - recently added via {!push_assumptions}. *) - - (** Result returned by {!check_sat_propagations_only} *) - type propagation_result = - | PR_sat - | PR_conflict of { backtracked: int } - | PR_unsat of clause unsat_state - - val check_sat_propagations_only : - ?assumptions:Lit.t list -> t -> propagation_result - (** [check_sat_propagations_only solver] uses the added clauses - and local assumptions (using {!push_assumptions} and [assumptions]) - to quickly assess whether the context is satisfiable. - It is not complete; calling {!solve} is required to get an accurate - result. - @returns either [Ok()] if propagation yielded no conflict, or [Error c] - if a conflict clause [c] was found. *) -end diff --git a/src/sat/base_types_.ml b/src/sat/base_types_.ml new file mode 100644 index 00000000..7e6843dd --- /dev/null +++ b/src/sat/base_types_.ml @@ -0,0 +1,63 @@ +open Sidekick_core +open Sigs + +(* a boolean variable (positive int) *) +module Var0 : sig + include Int_id.S +end = struct + include Int_id.Make () +end + +type var = Var0.t + +(* a signed atom. +v is (v << 1), -v is (v<<1 | 1) *) +module Atom0 : sig + include Int_id.S + + val neg : t -> t + val sign : t -> bool + val of_var : var -> t + val var : t -> var + val pa : var -> t + val na : var -> t + + module AVec : Vec_sig.S with type elt := t + module ATbl : CCHashtbl.S with type key = t +end = struct + include Int_id.Make () + + let[@inline] neg i = i lxor 1 + let[@inline] sign i = i land 1 = 0 + let[@inline] pa v = (v : var :> int) lsl 1 + let of_var = pa + let[@inline] var a = Var0.of_int_unsafe (a lsr 1) + let[@inline] na v = ((v : var :> int) lsl 1) lor 1 + + module AVec = Veci + module ATbl = CCHashtbl.Make (CCInt) +end + +module Clause0 : sig + include Int_id.S + module Tbl : Hashtbl.S with type key = t + module CVec : Vec_sig.S with type elt := t +end = struct + include Int_id.Make () + module Tbl = Util.Int_tbl + module CVec = Veci +end + +module Step_vec = Proof_trace.Step_vec + +type atom = Atom0.t +type clause = Clause0.t +type var_reason = Decision | Bcp of clause | Bcp_lazy of clause lazy_t + +module AVec = Atom0.AVec +(** Vector of atoms *) + +module ATbl = Atom0.ATbl +(** Hashtbl of atoms *) + +module CVec = Clause0.CVec +(** Vector of clauses *) diff --git a/src/sat/dune b/src/sat/dune index 7a17aa9b..3beb168f 100644 --- a/src/sat/dune +++ b/src/sat/dune @@ -2,6 +2,6 @@ (name sidekick_sat) (public_name sidekick.sat) (synopsis "Pure OCaml SAT solver implementation for sidekick") - (private_modules heap heap_intf) + (private_modules heap heap_intf base_types_) (libraries iter sidekick.util sidekick.core) (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/sat/Heap.ml b/src/sat/heap.ml similarity index 100% rename from src/sat/Heap.ml rename to src/sat/heap.ml diff --git a/src/sat/Heap.mli b/src/sat/heap.mli similarity index 100% rename from src/sat/Heap.mli rename to src/sat/heap.mli diff --git a/src/sat/Heap_intf.ml b/src/sat/heap_intf.ml similarity index 100% rename from src/sat/Heap_intf.ml rename to src/sat/heap_intf.ml diff --git a/src/sat/sigs.ml b/src/sat/sigs.ml new file mode 100644 index 00000000..a55ef26d --- /dev/null +++ b/src/sat/sigs.ml @@ -0,0 +1,153 @@ +(** Main types and signatures *) + +(* +MSAT is free software, using the Apache license, see file LICENSE +Copyright 2016 Guillaume Bury +Copyright 2016 Simon Cruanes +*) + +open Sidekick_core + +(** Solver in a "SATISFIABLE" state *) +module type SAT_STATE = sig + val eval : Lit.t -> bool + (** Returns the valuation of a lit in the current state + of the sat solver. + @raise UndecidedLit if the literal is not decided *) + + val eval_level : Lit.t -> bool * int + (** Return the current assignement of the literals, as well as its + decision level. If the level is 0, then it is necessary for + the literal to have this value; otherwise it is due to choices + that can potentially be backtracked. + @raise UndecidedLit if the literal is not decided *) + + val iter_trail : (Lit.t -> unit) -> unit + (** Iter through the lits in order of decision/propagation + (starting from the first propagation, to the last propagation). *) +end + +type sat_state = (module SAT_STATE) +(** The type of values returned when the solver reaches a SAT state. *) + +(** Solver in an "UNSATISFIABLE" state *) +module type UNSAT_STATE = sig + type clause + + val unsat_conflict : unit -> clause + (** Returns the unsat clause found at the toplevel *) + + val unsat_assumptions : unit -> Lit.t Iter.t + (** Subset of assumptions responsible for "unsat" *) + + val unsat_proof : unit -> Proof_term.step_id +end + +type 'clause unsat_state = (module UNSAT_STATE with type clause = 'clause) +(** The type of values returned when the solver reaches an UNSAT state. *) + +type same_sign = bool +(** This type is used during the normalisation of lits. + [true] means the literal stayed the same, [false] that its sign was flipped. *) + +(** The type of reasons for propagations of a lit [f]. *) +type reason = Consequence of (unit -> Lit.t list * Proof_step.id) [@@unboxed] +(** [Consequence (l, p)] means that the lits in [l] imply the propagated + lit [f]. The proof should be a proof of the clause "[l] implies [f]". + + invariant: in [Consequence (fun () -> l,p)], all elements of [l] must be true in + the current trail. + + {b note} on lazyiness: the justification is suspended (using [unit -> …]) + to avoid potentially costly computations that might never be used + if this literal is backtracked without participating in a conflict. + Therefore the function that produces [(l,p)] needs only be safe in + trails (partial models) that are conservative extensions of the current + trail. + If the theory isn't robust w.r.t. extensions of the trail (e.g. if + its internal state undergoes significant changes), + it can be easier to produce the explanation eagerly when + propagating, and then use [Consequence (fun () -> expl, proof)] with + the already produced [(expl,proof)] tuple. + *) + +type lbool = L_true | L_false | L_undefined (** Valuation of an atom *) + +let pp_lbool out = function + | L_true -> Fmt.string out "true" + | L_false -> Fmt.string out "false" + | L_undefined -> Fmt.string out "undefined" + +(** Actions available to the Plugin. + + The plugin provides callbacks for the SAT solver to use. These callbacks + are provided with a [(module ACTS)] so they can modify the SAT solver + by adding new lemmas, raise conflicts, etc. *) +module type ACTS = sig + val proof : Proof_trace.t + + val iter_assumptions : (Lit.t -> unit) -> unit + (** Traverse the new assumptions on the boolean trail. *) + + val eval_lit : Lit.t -> lbool + (** Obtain current value of the given literal *) + + val add_lit : ?default_pol:bool -> Lit.t -> unit + (** Map the given lit to an internal atom, which will be decided by the + SAT solver. *) + + val add_clause : ?keep:bool -> Lit.t list -> Proof_step.id -> unit + (** Add a clause to the solver. + @param keep if true, the clause will be kept by the solver. + Otherwise the solver is allowed to GC the clause and propose this + partial model again. + - [C_use_allocator alloc] puts the clause in the given allocator. + *) + + val raise_conflict : Lit.t list -> Proof_step.id -> 'b + (** Raise a conflict, yielding control back to the solver. + The list of atoms must be a valid theory lemma that is false in the + current trail. *) + + val propagate : Lit.t -> reason -> unit + (** Propagate a lit, i.e. the theory can evaluate the lit to be true + (see the definition of {!type:eval_res} *) + + val add_decision_lit : Lit.t -> bool -> unit + (** Ask the SAT solver to decide on the given lit with given sign + before it can answer [SAT]. The order of decisions is still unspecified. + Useful for theory combination. This will be undone on backtracking. *) +end + +type acts = (module ACTS) +(** The type for a slice of assertions to assume/propagate in the theory. *) + +(** Signature for theories to be given to the CDCL(T) solver *) +module type THEORY_CDCL_T = sig + val push_level : unit -> unit + (** Create a new backtrack level *) + + val pop_levels : int -> unit + (** Pop [n] levels of the theory *) + + val partial_check : acts -> unit + (** Assume the lits in the slice, possibly using the [slice] + to push new lits to be propagated or to raising a conflict or to add + new lemmas. *) + + val final_check : acts -> unit + (** Called at the end of the search in case a model has been found. + If no new clause is pushed, then proof search ends and "sat" is returned; + if lemmas are added, search is resumed; + if a conflict clause is added, search backtracks and then resumes. *) +end + +module type PLUGIN = sig + include THEORY_CDCL_T + + val has_theory : bool + (** [true] iff the solver is parametrized by a theory, not just + pure SAT. *) +end + +type plugin = (module PLUGIN) diff --git a/src/sat/solver.ml b/src/sat/solver.ml new file mode 100644 index 00000000..61e6f43e --- /dev/null +++ b/src/sat/solver.ml @@ -0,0 +1,2036 @@ +open Sidekick_core +open Sigs +open Base_types_ + +let invalid_argf fmt = + Format.kasprintf (fun msg -> invalid_arg ("sidekick.sat: " ^ msg)) fmt + +type clause = Clause0.t +type store = Store.t +type plugin = Sigs.plugin + +module Atom = Store.Atom +module Var = Store.Var +module Clause = Store.Clause + +module H = Heap.Make [@specialise] (struct + type store = Store.t + type t = var + + let[@inline] cmp store i j = Var.weight store j < Var.weight store i + (* comparison by weight *) + + let heap_idx = Var.heap_idx + let set_heap_idx = Var.set_heap_idx + let of_int_unsafe = Var.of_int_unsafe +end) + +(* cause of "unsat", possibly conditional to local assumptions *) +type unsat_cause = + | US_local of { + first: atom; (* assumption which was found to be proved false *) + core: atom list; (* the set of assumptions *) + } + | US_false of clause +(* true unsat *) + +exception E_sat +exception E_unsat of unsat_cause +exception UndecidedLit +exception Restart +exception Conflict of clause + +let var_decay : float = 1. /. 0.95 +(* inverse of the activity factor for variables *) + +let clause_decay : float = 1. /. 0.999 +(* inverse of the activity factor for clauses *) + +let restart_inc : float = 1.5 +(* multiplicative factor for restart limit *) + +let learntsize_inc : float = 1.1 +(* multiplicative factor for [learntsize_factor] at each restart *) + +(** Passed to clause pools when it's time to garbage collect clauses *) +module type GC_ARG = sig + val store : Store.t + val must_keep_clause : clause -> bool + val flag_clause_for_gc : clause -> unit +end + +(** A clause pool *) +module type CLAUSE_POOL = sig + val add : clause -> unit + val descr : unit -> string + val gc : (module GC_ARG) -> unit + val iter : f:(clause -> unit) -> unit + val needs_gc : unit -> bool + val size : unit -> int +end + +(* a clause pool *) +type clause_pool = (module CLAUSE_POOL) + +(* a pool with garbage collection determined by [P] *) +module Make_gc_cp (P : sig + val descr : unit -> string + val max_size : int ref +end) +() : CLAUSE_POOL = struct + let clauses_ : clause Vec.t = Vec.create () + (* Use a [Vec] so we can sort it. + TODO: when we can sort any vec, come back to that. *) + + let descr = P.descr + let add c = Vec.push clauses_ c + let iter ~f = Vec.iter ~f clauses_ + let size () = Vec.size clauses_ + let needs_gc () = size () > !P.max_size + + let gc (module G : GC_ARG) : unit = + (* find clauses to GC *) + let to_be_pushed_back = CVec.create () in + + (* sort by decreasing activity *) + Vec.sort clauses_ (fun c1 c2 -> + compare (Clause.activity G.store c2) (Clause.activity G.store c1)); + + while Vec.size clauses_ > !P.max_size do + let c = Vec.pop_exn clauses_ in + if G.must_keep_clause c then + CVec.push to_be_pushed_back c + (* must keep it, it's on the trail *) + else + G.flag_clause_for_gc c + done; + (* transfer back clauses we had to keep *) + CVec.iter ~f:(Vec.push clauses_) to_be_pushed_back; + () +end + +let make_gc_clause_pool_ ~descr ~max_size () : clause_pool = + (module Make_gc_cp + (struct + let descr = descr + let max_size = max_size + end) + ()) + +let[@inline] cp_size_ (module P : CLAUSE_POOL) : int = P.size () +let[@inline] cp_needs_gc_ (module P : CLAUSE_POOL) : bool = P.needs_gc () +let[@inline] cp_add_ (module P : CLAUSE_POOL) c : unit = P.add c +let[@inline] cp_to_iter_ (module P : CLAUSE_POOL) yield : unit = P.iter ~f:yield + +(* initial limit for the number of learnt clauses, 1/3 of initial + number of clauses by default *) +let learntsize_factor = 1. /. 3. + +(** Actions from theories and user, but to be done in specific points + of the solving loops. *) +module Delayed_actions : sig + type t + + val create : unit -> t + val is_empty : t -> bool + val clear_on_backtrack : t -> unit + val add_clause_learnt : t -> clause -> unit + val propagate_atom : t -> atom -> lvl:int -> clause lazy_t -> unit + val add_decision : t -> atom -> unit + + val iter : + decision:(atom -> unit) -> + propagate:(atom -> lvl:int -> clause lazy_t -> unit) -> + add_clause_learnt:(clause -> unit) -> + add_clause_pool:(clause -> clause_pool -> unit) -> + t -> + unit +end = struct + type t = { + clauses_to_add_learnt: CVec.t; + (* Clauses either assumed or pushed by the theory, waiting to be added. *) + clauses_to_add_in_pool: (clause * clause_pool) Vec.t; + (* clauses to add into a pool *) + mutable prop_level: int; + propagate: (atom * int * clause lazy_t) Vec.t; + decisions: atom Vec.t; + } + + let create () : t = + { + clauses_to_add_learnt = CVec.create (); + clauses_to_add_in_pool = Vec.create (); + prop_level = -1; + propagate = Vec.create (); + decisions = Vec.create (); + } + + let clear self = + let { + clauses_to_add_learnt; + clauses_to_add_in_pool; + prop_level = _; + propagate; + decisions; + } = + self + in + Vec.clear clauses_to_add_in_pool; + CVec.clear clauses_to_add_learnt; + Vec.clear propagate; + Vec.clear decisions + + let clear_on_backtrack self = + let { + clauses_to_add_learnt = _; + clauses_to_add_in_pool = _; + propagate; + prop_level = _; + decisions; + } = + self + in + Vec.clear propagate; + Vec.clear decisions + + let is_empty self = + let { + clauses_to_add_learnt; + clauses_to_add_in_pool; + prop_level = _; + propagate; + decisions; + } = + self + in + Vec.is_empty clauses_to_add_in_pool + && CVec.is_empty clauses_to_add_learnt + && Vec.is_empty decisions && Vec.is_empty propagate + + let add_clause_learnt (self : t) c = CVec.push self.clauses_to_add_learnt c + + let propagate_atom self p ~lvl c = + if (not (Vec.is_empty self.propagate)) && lvl < self.prop_level then + Vec.clear self.propagate + (* will be immediately backtracked *); + if lvl <= self.prop_level then ( + self.prop_level <- lvl; + Vec.push self.propagate (p, lvl, c) + ) + + let add_decision self p = Vec.push self.decisions p + + let iter ~decision ~propagate ~add_clause_learnt ~add_clause_pool self : unit + = + let { + clauses_to_add_learnt; + clauses_to_add_in_pool; + prop_level = _; + propagate = prop; + decisions; + } = + self + in + Vec.iter clauses_to_add_in_pool ~f:(fun (c, p) -> add_clause_pool c p); + CVec.iter ~f:add_clause_learnt clauses_to_add_learnt; + Vec.iter ~f:decision decisions; + Vec.iter prop ~f:(fun (p, lvl, c) -> propagate p ~lvl c); + clear self; + () +end + +(* Singleton type containing the current state *) +type t = { + store: store; (* atom/var/clause store *) + plugin: plugin; (* user defined theory *) + proof: Proof_trace.t; (* the proof object *) + (* Clauses are simplified for efficiency purposes. In the following + vectors, the comments actually refer to the original non-simplified + clause. *) + clauses_hyps: CVec.t; (* clauses added by the user, never removed *) + max_clauses_learnt: int ref; (* used to direct GC in {!clauses_learnt} *) + clauses_learnt: clause_pool; + (* learnt clauses (tautologies true at any time, whatever the user level). + GC'd regularly. *) + clause_pools: clause_pool Vec.t; (* custom clause pools *) + delayed_actions: Delayed_actions.t; + mutable unsat_at_0: clause option; (* conflict at level 0, if any *) + mutable next_decisions: atom list; + (* When the last conflict was a semantic one (mcsat), + this stores the next decision to make; + if some theory wants atoms to be decided on (for theory combination), + store them here. *) + trail: AVec.t; + (* decision stack + propagated elements (atoms or assignments). *) + var_levels: Veci.t; (* decision levels in [trail] *) + assumptions: AVec.t; (* current assumptions *) + mutable th_head: int; + (* Start offset in the queue {!trail} of + unit facts not yet seen by the theory. *) + mutable elt_head: int; + (* Start offset in the queue {!trail} of + unit facts to propagate, within the trail *) + (* invariant: + - during propagation, th_head <= elt_head + - then, once elt_head reaches length trail, Th.assume is + called so that th_head can catch up with elt_head + - this is repeated until a fixpoint is reached; + - before a decision (and after the fixpoint), + th_head = elt_head = length trail + *) + order: H.t; (* Heap ordered by variable activity *) + to_clear: var Vec.t; (* variables to unmark *) + (* temporaries *) + temp_atom_vec: AVec.t; + temp_clause_vec: CVec.t; + temp_step_vec: Step_vec.t; + mutable var_incr: float; (* increment for variables' activity *) + mutable clause_incr: float; (* increment for clauses' activity *) + (* FIXME: use event *) + on_conflict: (Clause.t, unit) Event.Emitter.t; + on_decision: (Lit.t, unit) Event.Emitter.t; + on_learnt: (Clause.t, unit) Event.Emitter.t; + on_gc: (Lit.t array, unit) Event.Emitter.t; + stat: Stat.t; + n_conflicts: int Stat.counter; + n_propagations: int Stat.counter; + n_decisions: int Stat.counter; + n_restarts: int Stat.counter; + n_minimized_away: int Stat.counter; +} + +type solver = t + +(* intial restart limit *) +let restart_first = 100 +let _nop_on_conflict (_ : atom array) = () + +(* Starting environment. *) +let create_ ~store ~proof ~stat ~max_clauses_learnt (plugin : plugin) : t = + { + store; + plugin; + unsat_at_0 = None; + next_decisions = []; + max_clauses_learnt; + clauses_hyps = CVec.create (); + clauses_learnt = + make_gc_clause_pool_ + ~descr:(fun () -> "cp.learnt-clauses") + ~max_size:max_clauses_learnt (); + delayed_actions = Delayed_actions.create (); + clause_pools = Vec.create (); + to_clear = Vec.create (); + temp_clause_vec = CVec.create (); + temp_atom_vec = AVec.create (); + temp_step_vec = Step_vec.create (); + th_head = 0; + elt_head = 0; + trail = AVec.create (); + var_levels = Veci.create (); + assumptions = AVec.create (); + order = H.create store; + var_incr = 1.; + clause_incr = 1.; + proof; + stat; + n_conflicts = Stat.mk_int stat "sat.n-conflicts"; + n_decisions = Stat.mk_int stat "sat.n-decisions"; + n_propagations = Stat.mk_int stat "sat.n-propagations"; + n_restarts = Stat.mk_int stat "sat.n-restarts"; + n_minimized_away = Stat.mk_int stat "sat.n-confl-lits-minimized-away"; + on_conflict = Event.Emitter.create (); + on_decision = Event.Emitter.create (); + on_learnt = Event.Emitter.create (); + on_gc = Event.Emitter.create (); + } + +let on_gc self = Event.of_emitter self.on_gc +let on_conflict self = Event.of_emitter self.on_conflict +let on_decision self = Event.of_emitter self.on_decision +let on_learnt self = Event.of_emitter self.on_learnt + +(* iterate on all learnt clauses, pools included *) +let iter_clauses_learnt_ (self : t) ~f : unit = + let[@inline] iter_pool (module P : CLAUSE_POOL) = P.iter ~f in + iter_pool self.clauses_learnt; + Vec.iter ~f:iter_pool self.clause_pools; + () + +let[@inline] decision_level st = Veci.size st.var_levels +let[@inline] nb_clauses st = CVec.size st.clauses_hyps +let stat self = self.stat + +(* Do we have a level-0 empty clause? *) +let[@inline] check_unsat_ st = + match st.unsat_at_0 with + | Some c -> raise (E_unsat (US_false c)) + | None -> () + +(* Variable and literal activity. + Activity is used to decide on which variable to decide when propagation + is done. Uses a heap (implemented in Iheap), to keep track of variable activity. + To be more general, the heap only stores the variable/literal id (i.e an int). +*) +let[@inline] insert_var_order st (v : var) : unit = H.insert st.order v + +(* find atom for the lit, if any *) +let[@inline] find_atom_ (self : t) (p : Lit.t) : atom option = + Store.find_atom self.store p + +(* create a new atom, pushing it into the decision queue if needed *) +let make_atom_ (self : t) ?default_pol (p : Lit.t) : atom = + let a = Store.alloc_atom self.store ?default_pol p in + if Atom.level self.store a < 0 then + insert_var_order self (Atom.var a) + else + assert (Atom.is_true self.store a || Atom.is_false self.store a); + a + +(* Rather than iterate over all the heap when we want to decrease all the + variables/literals activity, we instead increase the value by which + we increase the activity of 'interesting' var/lits. *) +let[@inline] var_decay_activity st = st.var_incr <- st.var_incr *. var_decay + +let[@inline] clause_decay_activity st = + st.clause_incr <- st.clause_incr *. clause_decay + +(* increase activity of [v] *) +let var_bump_activity self v = + let store = self.store in + Var.set_weight store v (Var.weight store v +. self.var_incr); + if Var.weight store v > 1e100 then ( + Store.iter_vars store (fun v -> + Var.set_weight store v (Var.weight store v *. 1e-100)); + self.var_incr <- self.var_incr *. 1e-100 + ); + if H.in_heap self.order v then H.decrease self.order v + +(* increase activity of clause [c] *) +let clause_bump_activity self (c : clause) : unit = + let store = self.store in + Clause.set_activity store c (Clause.activity store c +. self.clause_incr); + if Clause.activity store c > 1e20 then ( + let update_clause c = + Clause.set_activity store c (Clause.activity store c *. 1e-20) + in + iter_clauses_learnt_ self ~f:update_clause; + self.clause_incr <- self.clause_incr *. 1e-20 + ) + +(* Simplification of clauses. + + When adding new clauses, it is desirable to 'simplify' them, i.e + minimize the amount of literals in it, because it greatly reduces + the search space for new watched literals during propagation. + Additionally, we have to partition the lits, to ensure the watched + literals (which are the first two lits of the clause) are appropriate. + Indeed, it is better to watch true literals, and then unassigned literals. + Watching false literals should be a last resort, and come with constraints + (see {!add_clause}). +*) +exception Trivial + +(* get/build the proof for [a], which must be an atom true at level 0. + This uses a global cache to avoid repeated computations, as many clauses + might resolve against a given 0-level atom. *) +let rec proof_of_atom_lvl0_ (self : t) (a : atom) : Proof_step.id = + assert (Atom.is_true self.store a && Atom.level self.store a = 0); + + match Atom.proof_lvl0 self.store a with + | Some p -> p + | None -> + let p = + match Atom.reason self.store a with + | None -> assert false + | Some Decision -> assert false (* no decisions at level0 *) + | Some (Bcp c2 | Bcp_lazy (lazy c2)) -> + Log.debugf 50 (fun k -> + k "(@[sat.proof-of-atom-lvl0.clause@ %a@])" + (Clause.debug self.store) c2); + + let steps = ref [] in + (* recurse, so we get the whole level-0 resolution graph *) + Clause.iter self.store c2 ~f:(fun a2 -> + if not (Var.equal (Atom.var a) (Atom.var a2)) then ( + Log.debugf 50 (fun k -> + k + "(@[sat.proof-of-atom-lvl0@ :of %a@ @[:resolve-with@ \ + %a@]@])" + (Atom.debug self.store) a (Atom.debug self.store) a2); + + let p2 = proof_of_atom_lvl0_ self (Atom.neg a2) in + steps := p2 :: !steps + )); + + let proof_c2 = Clause.proof_step self.store c2 in + if !steps = [] then + proof_c2 + else + Proof_trace.add_step self.proof + @@ Proof_sat.sat_redundant_clause + (Iter.return (Atom.lit self.store a)) + ~hyps:Iter.(cons proof_c2 (of_list !steps)) + in + + Atom.set_proof_lvl0 self.store a p; + (* put in cache *) + p + +(* Preprocess clause, by doing the following: + + - Partition literals for new clauses, into: + - true literals (maybe makes the clause trivial if the lit is proved true at level 0) + - unassigned literals, yet to be decided + - false literals (not suitable to watch, those at level 0 can be removed from the clause) + and order them as such in the result. + + - Also, removes literals that are false at level0, and returns a proof for + their removal. + - Also, removes duplicates. +*) +let preprocess_clause_ (self : t) (c : Clause.t) : Clause.t = + let store = self.store in + let res0_proofs = ref [] in + (* steps of resolution at level 0 *) + let add_proof_lvl0_ p = res0_proofs := p :: !res0_proofs in + + let trues = Vec.create () in + let unassigned = Vec.create () in + let falses = Vec.create () in + + (* cleanup marks used to detect duplicates *) + let cleanup () = + Clause.iter store c ~f:(fun a -> Store.clear_var store (Atom.var a)) + in + + let consider_atom (a : atom) : unit = + if not (Atom.marked store a) then ( + Atom.mark store a; + if Atom.marked_both store a then raise Trivial; + + if Atom.is_true store a then ( + let lvl = Atom.level store a in + if lvl = 0 then + (* Atom true at level 0 gives a trivially true clause *) + raise Trivial; + Vec.push trues a + ) else if Atom.is_false store a then ( + let lvl = Atom.level store a in + if lvl = 0 then ( + (* Atom var false at level 0 can be eliminated from the clause, + but we need to kepp in mind that we used another clause to simplify it. *) + Log.debugf 50 (fun k -> + k "(@[sat.preprocess-clause.resolve-away-lvl0@ %a@])" + (Atom.debug store) a); + + let p = proof_of_atom_lvl0_ self (Atom.neg a) in + add_proof_lvl0_ p + ) else + Vec.push falses a + ) else + Vec.push unassigned a + ) + in + + (try + Clause.iter store c ~f:consider_atom; + cleanup () + with e -> + cleanup (); + raise e); + + (* merge all atoms together *) + let atoms = + let v = trues in + Vec.append ~into:v unassigned; + Vec.append ~into:v falses; + Vec.to_array v + in + + if !res0_proofs = [] then + (* no change except in the order of literals *) + Clause.make_a store atoms ~removable:(Clause.removable store c) + (Clause.proof_step store c) + else ( + assert (Array.length atoms < Clause.n_atoms store c); + (* some atoms were removed by resolution with level-0 clauses *) + Log.debugf 30 (fun k -> + k "(@[sat.add-clause.resolved-lvl-0@ :into [@[%a@]]@])" + (Atom.debug_a store) atoms); + let proof = + let lits = Iter.of_array atoms |> Iter.map (Atom.lit store) in + Proof_trace.add_step self.proof + @@ Proof_sat.sat_redundant_clause lits + ~hyps: + Iter.(cons (Clause.proof_step self.store c) (of_list !res0_proofs)) + in + Clause.make_a store atoms proof ~removable:(Clause.removable store c) + ) + +let new_decision_level (self : t) = + assert (self.th_head = AVec.size self.trail); + assert (self.elt_head = AVec.size self.trail); + Veci.push self.var_levels (AVec.size self.trail); + let (module P) = self.plugin in + P.push_level (); + () + +(* Attach/Detach a clause. + + Atom clause is attached (to its watching lits) when it is first added, + either because it is assumed or learnt. +*) +let attach_clause (self : t) c = + let store = self.store in + assert (not @@ Clause.attached store c); + Log.debugf 20 (fun k -> + k "(@[sat.attach-clause@ %a@])" (Clause.debug store) c); + (* TODO: change when watchlist are updated *) + CVec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(0))) c; + CVec.push (Atom.watched store (Atom.neg (Clause.atoms_a store c).(1))) c; + Clause.set_attached store c true; + () + +(* Backtracking. + Used to backtrack, i.e cancel down to [lvl] excluded, + i.e we want to go back to the state the solver was in + after decision level [lvl] was created and fully propagated. *) +let cancel_until (self : t) lvl = + let store = self.store in + assert (lvl >= 0); + (* Nothing to do if we try to backtrack to a non-existent level. *) + if decision_level self <= lvl then + Log.debugf 20 (fun k -> + k "(@[sat.cancel-until.nop@ :already-at-level <= %d@])" lvl) + else ( + Log.debugf 5 (fun k -> k "(@[sat.cancel-until %d@])" lvl); + (* We set the head of the solver and theory queue to what it was. *) + let head = ref (Veci.get self.var_levels lvl) in + self.elt_head <- !head; + self.th_head <- !head; + (* Now we need to cleanup the vars that are not valid anymore + (i.e to the right of elt_head in the queue. *) + for c = self.elt_head to AVec.size self.trail - 1 do + let a = AVec.get self.trail c in + (* Atom literal is unassigned, we nedd to add it back to + the heap of potentially assignable literals, unless it has + a level lower than [lvl], in which case we just move it back. *) + (* Atom variable is not true/false anymore, one of two things can happen: *) + if Atom.level store a <= lvl then ( + (* It is a late propagation, which has a level + lower than where we backtrack, so we just move it to the head + of the queue, to be propagated again. *) + AVec.set self.trail !head a; + head := !head + 1 + ) else ( + (* it is a result of bolean propagation, or a semantic propagation + with a level higher than the level to which we backtrack, + in that case, we simply unset its value and reinsert it into the heap. *) + Atom.set_is_true store a false; + Atom.set_is_true store (Atom.neg a) false; + Var.set_level store (Atom.var a) (-1); + Var.set_reason store (Atom.var a) None; + insert_var_order self (Atom.var a) + ) + done; + (* Recover the right theory state. *) + let n = decision_level self - lvl in + assert (n > 0); + (* Resize the vectors according to their new size. *) + AVec.shrink self.trail !head; + Veci.shrink self.var_levels lvl; + let (module P) = self.plugin in + P.pop_levels n; + Delayed_actions.clear_on_backtrack self.delayed_actions; + (* TODO: for scoped clause pools, backtrack them *) + self.next_decisions <- [] + ); + () + +let pp_unsat_cause self out = function + | US_local { first = _; core } -> + Format.fprintf out "(@[unsat-cause@ :false-assumptions %a@])" + (Format.pp_print_list (Atom.pp self.store)) + core + | US_false c -> + Format.fprintf out "(@[unsat-cause@ :false %a@])" (Clause.debug self.store) + c + +(* Unsatisfiability is signaled through an exception, since it can happen + in multiple places (adding new clauses, or solving for instance). *) +let report_unsat self (us : unsat_cause) : _ = + Log.debugf 3 (fun k -> + k "(@[sat.unsat-conflict@ %a@])" (pp_unsat_cause self) us); + let us = + match us with + | US_false c -> + self.unsat_at_0 <- Some c; + Event.emit self.on_learnt c; + let p = Clause.proof_step self.store c in + Proof_trace.add_unsat self.proof p; + US_false c + | US_local _ -> us + in + raise (E_unsat us) + +(* Boolean propagation. + Wrapper function for adding a new propagated lit. *) +let enqueue_bool (self : t) a ~level:lvl reason : unit = + let store = self.store in + if Atom.is_false store a then ( + Log.debugf 0 (fun k -> + k "(@[sat.error.trying to enqueue a false literal %a@])" + (Atom.debug store) a); + assert false + ); + assert ( + (not (Atom.is_true store a)) + && Atom.level store a < 0 + && Atom.reason store a == None + && lvl >= 0); + (* backtrack if required *) + if lvl < decision_level self then cancel_until self lvl; + Atom.set_is_true store a true; + Var.set_level store (Atom.var a) lvl; + Var.set_reason store (Atom.var a) (Some reason); + AVec.push self.trail a; + Log.debugf 20 (fun k -> + k "(@[sat.enqueue[%d]@ %a@])" (AVec.size self.trail) (Atom.debug store) a); + () + +(* swap elements of array *) +let[@inline] swap_arr a i j = + if i <> j then ( + let tmp = a.(i) in + a.(i) <- a.(j); + a.(j) <- tmp + ) + +(* move atoms assigned at high levels first *) +let put_high_level_atoms_first (store : store) (arr : atom array) : unit = + Array.iteri + (fun i a -> + if i > 0 && Atom.level store a > Atom.level store arr.(0) then + if (* move first to second, [i]-th to first, second to [i] *) + i = 1 then + swap_arr arr 0 1 + else ( + let tmp = arr.(1) in + arr.(1) <- arr.(0); + arr.(0) <- arr.(i); + arr.(i) <- tmp + ) + else if i > 1 && Atom.level store a > Atom.level store arr.(1) then + swap_arr arr 1 i) + arr + +(* find which level to backtrack to, given a conflict clause + and a boolean stating whether it is + a UIP ("Unique Implication Point") + precond: the atom list is sorted by decreasing decision level *) +let backtrack_lvl (self : t) (arr : atom array) : int * bool = + let store = self.store in + if Array.length arr <= 1 then + 0, true + else ( + let a = arr.(0) in + let b = arr.(1) in + assert (Atom.level store a > 0); + if Atom.level store a > Atom.level store b then + ( (* backtrack below [a], so we can propagate [not a] *) + Atom.level store b, + true ) + else ( + assert (Atom.level store a = Atom.level store b); + assert (Atom.level store a >= 0); + max (Atom.level store a - 1) 0, false + ) + ) + +(* abtraction of the assignment level of [v] in an integer *) +let[@inline] abstract_level_ (self : t) (v : var) : int = + 1 lsl (Var.level self.store v land 31) + +exception Non_redundant + +(* can we remove [a] by self-subsuming resolutions with other lits + of the learnt clause? *) +let lit_redundant (self : t) (abstract_levels : int) (steps : Step_vec.t) + (v : var) : bool = + let store = self.store in + let to_unmark = self.to_clear in + let steps_size_init = Step_vec.size steps in + + (* save current state of [to_unmark] *) + let top = Vec.size to_unmark in + let rec aux v = + match Var.reason store v with + | None -> assert false + | Some Decision -> raise_notrace Non_redundant + | Some (Bcp c | Bcp_lazy (lazy c)) -> + let c_atoms = Clause.atoms_a store c in + assert (Var.equal v (Atom.var c_atoms.(0))); + if Proof_trace.enabled self.proof then + Step_vec.push steps (Clause.proof_step self.store c); + + (* check that all the other lits of [c] are marked or redundant *) + for i = 1 to Array.length c_atoms - 1 do + let v2 = Atom.var c_atoms.(i) in + let lvl_v2 = Var.level store v2 in + if not (Var.marked store v2) then ( + match Var.reason store v2 with + | None -> assert false + | _ when lvl_v2 = 0 -> + (* can always remove literals at level 0, but got + to update proof properly *) + if Proof_trace.enabled self.proof then ( + let p = proof_of_atom_lvl0_ self (Atom.neg c_atoms.(i)) in + Step_vec.push steps p + ) + | Some (Bcp _ | Bcp_lazy _) + when abstract_level_ self v2 land abstract_levels <> 0 -> + (* possibly removable, its level may comprise an atom in learnt clause *) + Vec.push to_unmark v2; + Var.mark store v2; + aux v2 + | Some _ -> raise_notrace Non_redundant + ) + done + in + try + aux v; + true + with Non_redundant -> + (* clear new marks, they are not actually redundant *) + for i = top to Vec.size to_unmark - 1 do + Var.unmark store (Vec.get to_unmark i) + done; + Vec.shrink to_unmark top; + Step_vec.shrink steps steps_size_init; + (* restore proof *) + false + +(* minimize conflict by removing atoms whose propagation history + is ultimately self-subsuming with [lits] *) +let minimize_conflict (self : t) (_c_level : int) (learnt : AVec.t) + (steps : Step_vec.t) : unit = + let store = self.store in + + (* abstraction of the levels involved in the conflict at all, + as logical "or" of each literal's approximate level *) + let abstract_levels = + AVec.fold_left + (fun lvl a -> lvl lor abstract_level_ self (Atom.var a)) + 0 learnt + in + + let j = ref 1 in + for i = 1 to AVec.size learnt - 1 do + let a = AVec.get learnt i in + let keep = + match Atom.reason store a with + | Some Decision -> true (* always keep decisions *) + | Some (Bcp _ | Bcp_lazy _) -> + not (lit_redundant self abstract_levels steps (Atom.var a)) + | None -> assert false + in + if keep then ( + AVec.set learnt !j a; + incr j + ) else + Stat.incr self.n_minimized_away + done; + AVec.shrink learnt !j; + () + +(* result of conflict analysis, containing the learnt clause and some + additional info. *) +type conflict_res = { + cr_backtrack_lvl: int; (* level to backtrack to *) + cr_learnt: atom array; (* lemma learnt from conflict *) + cr_is_uip: bool; (* conflict is UIP? *) + cr_steps: Step_vec.t; +} + +(* conflict analysis, starting with top of trail and conflict clause *) +let analyze (self : t) (c_clause : clause) : conflict_res = + let store = self.store in + + let to_unmark = self.to_clear in + (* for cleanup *) + Vec.clear to_unmark; + let learnt = self.temp_atom_vec in + AVec.clear learnt; + + let steps = self.temp_step_vec in + (* for proof *) + assert (Step_vec.is_empty steps); + + (* loop variables *) + let pathC = ref 0 in + let continue = ref true in + let blevel = ref 0 in + let c = ref (Some c_clause) in + (* current clause to analyze/resolve *) + let tr_ind = ref (AVec.size self.trail - 1) in + + (* pointer in trail *) + + (* conflict level *) + assert (decision_level self > 0); + let conflict_level = + let (module P) = self.plugin in + if P.has_theory then + Clause.fold store 0 c_clause ~f:(fun acc p -> + max acc (Atom.level store p)) + else + decision_level self + in + Log.debugf 30 (fun k -> + k "(@[sat.analyze-conflict@ :c-level %d@ :clause %a@])" conflict_level + (Clause.debug store) c_clause); + + while !continue do + (match !c with + | None -> + Log.debug 30 + "(@[sat.analyze-conflict: skipping resolution for semantic \ + propagation@])" + | Some clause -> + Log.debugf 30 (fun k -> + k "(@[sat.analyze-conflict.resolve@ %a@])" (Clause.debug store) clause); + + if Clause.removable store clause then clause_bump_activity self clause; + if Proof_trace.enabled self.proof then + Step_vec.push steps (Clause.proof_step self.store clause); + + (* visit the current predecessors *) + let atoms = Clause.atoms_a store clause in + for j = 0 to Array.length atoms - 1 do + let q = atoms.(j) in + assert (Atom.has_value store q); + assert (Atom.level store q >= 0); + if Atom.level store q = 0 then ( + (* skip [q] entirely, resolved away at level 0 *) + assert (Atom.is_false store q); + if Proof_trace.enabled self.proof then ( + let step = proof_of_atom_lvl0_ self (Atom.neg q) in + Step_vec.push steps step + ) + ) else if not (Var.marked store (Atom.var q)) then ( + Var.mark store (Atom.var q); + Vec.push to_unmark (Atom.var q); + if Atom.level store q > 0 then ( + var_bump_activity self (Atom.var q); + if Atom.level store q >= conflict_level then + incr pathC + else ( + AVec.push learnt q; + blevel := max !blevel (Atom.level store q) + ) + ) + ) + done); + + (* look for the next node to expand *) + while + let a = AVec.get self.trail !tr_ind in + Log.debugf 30 (fun k -> + k "(@[sat.analyze-conflict.at-trail-elt@ %a@])" (Atom.debug store) a); + (not (Var.marked store (Atom.var a))) + || Atom.level store a < conflict_level + do + decr tr_ind + done; + let p = AVec.get self.trail !tr_ind in + decr pathC; + decr tr_ind; + match !pathC, Atom.reason store p with + | 0, _ -> + continue := false; + AVec.push learnt (Atom.neg p) + | n, Some (Bcp cl | Bcp_lazy (lazy cl)) -> + assert (n > 0); + assert (Atom.level store p >= conflict_level); + c := Some cl + | _, (None | Some Decision) -> assert false + done; + + Log.debugf 10 (fun k -> + k "(@[sat.conflict.res@ %a@])" (AVec.pp @@ Atom.debug store) learnt); + + (* minimize conflict, to get a more general lemma *) + minimize_conflict self conflict_level learnt steps; + + let cr_steps = Step_vec.copy steps in + Step_vec.clear self.temp_step_vec; + + (* cleanup marks *) + Vec.iter ~f:(Store.clear_var store) to_unmark; + Vec.clear to_unmark; + + (* put high-level literals first, so that: + - they make adequate watch lits + - the first literal is the UIP, if any *) + let cr_learnt = AVec.to_array learnt in + AVec.clear learnt; + Array.sort + (fun p q -> compare (Atom.level store q) (Atom.level store p)) + cr_learnt; + + (* put_high_level_atoms_first a; *) + let level, is_uip = backtrack_lvl self cr_learnt in + Log.debugf 10 (fun k -> + k "(@[sat.conflict.res.final@ :lvl %d@ {@[%a@]}@])" level + (Util.pp_array @@ Atom.debug store) + cr_learnt); + + { cr_backtrack_lvl = level; cr_learnt; cr_is_uip = is_uip; cr_steps } + +(* Get the correct vector to insert a clause in. *) +let[@inline] add_clause_to_vec_ ~pool self c = + if Clause.removable self.store c && Clause.n_atoms self.store c > 2 then + (* add clause to some pool/set of clauses *) + cp_add_ pool c + else + CVec.push self.clauses_hyps c + +(* add the learnt clause to the clause database, propagate, etc. *) +let record_learnt_clause (self : t) ~pool (cr : conflict_res) : unit = + let store = self.store in + (match cr.cr_learnt with + | [||] -> assert false + | [| fuip |] -> + assert (cr.cr_backtrack_lvl = 0 && decision_level self = 0); + + let p = + Proof_trace.add_step self.proof + @@ Proof_sat.sat_redundant_clause + (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) + ~hyps:(Step_vec.to_iter cr.cr_steps) + in + let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in + Event.emit self.on_learnt uclause; + + if Atom.is_false store fuip then + (* incompatible at level 0 *) + report_unsat self (US_false uclause) + else + (* no need to attach [uclause], it is true at level 0 *) + enqueue_bool self fuip ~level:0 (Bcp uclause) + | _ -> + let fuip = cr.cr_learnt.(0) in + let p = + Proof_trace.add_step self.proof + @@ Proof_sat.sat_redundant_clause + (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) + ~hyps:(Step_vec.to_iter cr.cr_steps) + in + let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in + + add_clause_to_vec_ ~pool self lclause; + attach_clause self lclause; + clause_bump_activity self lclause; + Event.emit self.on_learnt lclause; + assert cr.cr_is_uip; + enqueue_bool self fuip ~level:cr.cr_backtrack_lvl (Bcp lclause)); + var_decay_activity self; + clause_decay_activity self + +(* process a conflict: + - learn clause + - backtrack + - report unsat if conflict at level 0 +*) +let add_boolean_conflict (self : t) (confl : clause) : unit = + let store = self.store in + Log.debugf 5 (fun k -> + k "(@[sat.add-bool-conflict@ %a@])" (Clause.debug store) confl); + self.next_decisions <- []; + assert (decision_level self >= 0); + if + decision_level self = 0 + || Clause.for_all store confl ~f:(fun a -> Atom.level store a <= 0) + then + (* Top-level conflict *) + report_unsat self (US_false confl); + let cr = analyze self confl in + cancel_until self (max cr.cr_backtrack_lvl 0); + record_learnt_clause ~pool:self.clauses_learnt self cr + +(* Add a new clause, simplifying, propagating, and backtracking if + the clause is false in the current trail *) +let add_clause_ (self : t) ~pool (init : clause) : unit = + let store = self.store in + Log.debugf 30 (fun k -> + k "(@[sat.add-clause@ @[%a@]@])" (Clause.debug store) init); + (* Insertion of new lits is done before simplification. Indeed, else a lit in a + trivial clause could end up being not decided on, which is a bug. *) + Clause.iter store init ~f:(fun x -> insert_var_order self (Atom.var x)); + try + (* preprocess to remove dups, sort literals, etc. *) + let clause = preprocess_clause_ self init in + assert (Clause.removable store clause = Clause.removable store init); + + Log.debugf 5 (fun k -> + k "(@[sat.new-clause@ @[%a@]@])" (Clause.debug store) clause); + let atoms = Clause.atoms_a self.store clause in + match atoms with + | [||] -> report_unsat self @@ US_false clause + | [| a |] -> + cancel_until self 0; + if Atom.is_false store a then + (* cannot recover from this *) + report_unsat self @@ US_false clause + else if Atom.is_true store a then + () + (* atom is already true, (at level 0) nothing to do *) + else ( + Log.debugf 40 (fun k -> + k "(@[sat.add-clause.unit-clause@ :propagating %a@])" + (Atom.debug store) a); + add_clause_to_vec_ ~pool self clause; + enqueue_bool self a ~level:0 (Bcp clause) + ) + | _ -> + let a = atoms.(0) in + let b = atoms.(1) in + add_clause_to_vec_ ~pool self clause; + if Atom.is_false store a then ( + (* Atom need to be sorted in decreasing order of decision level, + or we might watch the wrong literals. *) + put_high_level_atoms_first store (Clause.atoms_a store clause); + attach_clause self clause; + add_boolean_conflict self clause + ) else ( + attach_clause self clause; + if Atom.is_false store b && not (Atom.has_value store a) then ( + (* unit, propagate [a] *) + let lvl = + Array.fold_left (fun m a -> max m (Atom.level store a)) 0 atoms + in + cancel_until self lvl; + Log.debugf 50 (fun k -> + k "(@[sat.add-clause.propagate@ %a@ :lvl %d@])" (Atom.debug store) + a lvl); + enqueue_bool self a ~level:lvl (Bcp clause) + ) + ) + with Trivial -> + Log.debugf 5 (fun k -> + k "(@[sat.add-clause@ :ignore-trivial @[%a@]@])" (Clause.debug store) + init) + +type watch_res = Watch_kept | Watch_removed + +(* boolean propagation. + [a] is the false atom, one of [c]'s two watch literals + [i] is the index of [c] in [a.watched] + @return whether [c] was removed from [a.watched] +*) +let propagate_in_clause (self : t) (a : atom) (c : clause) (i : int) : watch_res + = + let store = self.store in + let atoms = Clause.atoms_a store c in + let first = atoms.(0) in + if first = Atom.neg a then ( + (* false lit must be at index 1 *) + atoms.(0) <- atoms.(1); + atoms.(1) <- first + ) else + assert (Atom.neg a = atoms.(1)); + let first = atoms.(0) in + if Atom.is_true store first then + Watch_kept + (* true clause, keep it in watched *) + else ( + try + (* look for another watch lit *) + for k = 2 to Array.length atoms - 1 do + let ak = atoms.(k) in + if not (Atom.is_false store ak) then ( + (* watch lit found: update and exit *) + atoms.(1) <- ak; + atoms.(k) <- Atom.neg a; + (* remove [c] from [a.watched], add it to [ak.neg.watched] *) + CVec.push (Atom.watched store (Atom.neg ak)) c; + assert (Clause.equal (CVec.get (Atom.watched store a) i) c); + CVec.fast_remove (Atom.watched store a) i; + raise_notrace Exit + ) + done; + (* no watch lit found *) + if Atom.is_false store first then ( + (* clause is false *) + self.elt_head <- AVec.size self.trail; + raise_notrace (Conflict c) + ) else ( + Stat.incr self.n_propagations; + enqueue_bool self first ~level:(decision_level self) (Bcp c) + ); + Watch_kept + with Exit -> Watch_removed + ) + +(* propagate atom [a], which was just decided. This checks every + clause watching [a] to see if the clause is false, unit, or has + other possible watches + @param res the optional conflict clause that the propagation might trigger *) +let propagate_atom (self : t) a : unit = + let store = self.store in + let watched = Atom.watched store a in + let rec aux i = + if i >= CVec.size watched then + () + else ( + let c = CVec.get watched i in + assert (Clause.attached store c); + let j = + if Clause.dead store c then + i + (* remove on the fly *) + else ( + match propagate_in_clause self a c i with + | Watch_kept -> i + 1 + | Watch_removed -> i (* clause at this index changed *) + ) + in + aux j + ) + in + aux 0 + +exception Th_conflict of Clause.t + +let acts_add_clause self ?(keep = false) (l : Lit.t list) (p : Proof_step.id) : + unit = + let atoms = List.rev_map (make_atom_ self) l in + let removable = not keep in + let c = Clause.make_l self.store ~removable atoms p in + Log.debugf 5 (fun k -> + k "(@[sat.th.add-clause@ %a@])" (Clause.debug self.store) c); + (* will be added later, even if we backtrack *) + Delayed_actions.add_clause_learnt self.delayed_actions c + +let acts_add_decision_lit (self : t) (f : Lit.t) (sign : bool) : unit = + let store = self.store in + let a = make_atom_ self f in + let a = + if sign then + a + else + Atom.neg a + in + if not (Atom.has_value store a) then ( + Log.debugf 10 (fun k -> + k "(@[sat.th.add-decision-lit@ %a@])" (Atom.debug store) a); + Delayed_actions.add_decision self.delayed_actions a + ) + +let acts_raise self (l : Lit.t list) (p : Proof_step.id) : 'a = + let atoms = List.rev_map (make_atom_ self) l in + (* conflicts can be removed *) + let c = Clause.make_l self.store ~removable:true atoms p in + Log.debugf 5 (fun k -> + k "(@[@{sat.th.raise-conflict@}@ %a@])" (Clause.debug self.store) + c); + (* we can shortcut the rest of the theory propagations *) + raise_notrace (Th_conflict c) + +let check_consequence_lits_false_ self l p : unit = + let store = self.store in + Log.debugf 50 (fun k -> + k "(@[sat.check-consequence-lits: %a@ :for %a@])" + (Util.pp_list (Atom.debug store)) + l (Atom.debug store) p); + match List.find (fun a -> Atom.is_true store a) l with + | a -> + invalid_argf + "slice.acts_propagate:@ Consequence should contain only false literals,@ \ + but @[%a@] is true" + (Atom.debug store) (Atom.neg a) + | exception Not_found -> () + +let acts_propagate (self : t) f (expl : reason) = + let store = self.store in + match expl with + | Consequence mk_expl -> + let p = make_atom_ self f in + Log.debugf 30 (fun k -> + k "(@[sat.propagate-from-theory@ %a@])" (Atom.debug store) p); + if Atom.is_true store p then + () + else if Atom.is_false store p then ( + let lits, proof = mk_expl () in + let guard = List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits in + check_consequence_lits_false_ self guard p; + let c = Clause.make_l store ~removable:true (p :: guard) proof in + raise_notrace (Th_conflict c) + ) else ( + insert_var_order self (Atom.var p); + let c, level = + (* Check literals + proof eagerly, as it's safer. + + We could check invariants in a [lazy] block, + as conflict analysis would run in an environment where + the literals should be true anyway, since it's an extension of the + current trail. + (otherwise the propagated lit would have been backtracked and + discarded already.) + + However it helps catching propagation bugs to verify truthiness + of the guard (and level) eagerly. + *) + let lits, proof = mk_expl () in + let guard = + List.rev_map (fun f -> Atom.neg @@ make_atom_ self f) lits + in + check_consequence_lits_false_ self guard p; + let level = + List.fold_left (fun l a -> max l (Atom.level store a)) 0 guard + in + assert (level <= decision_level self); + (* delay creating the actual clause. *) + lazy (Clause.make_l store ~removable:true (p :: guard) proof), level + in + Delayed_actions.propagate_atom self.delayed_actions p ~lvl:level c + ) + +let[@inline never] perform_delayed_actions_ (self : t) : unit = + let add_clause_learnt c = add_clause_ ~pool:self.clauses_learnt self c + and add_clause_pool c pool = add_clause_ ~pool self c + and decision a = self.next_decisions <- a :: self.next_decisions + and propagate p ~lvl c = + if Atom.is_true self.store p then + () + else if Atom.is_false self.store p then + raise_notrace (Th_conflict (Lazy.force c)) + else ( + Stat.incr self.n_propagations; + enqueue_bool self p ~level:lvl (Bcp_lazy c) + ) + in + Delayed_actions.iter self.delayed_actions ~add_clause_learnt ~add_clause_pool + ~propagate ~decision; + () + +let[@inline] has_no_delayed_actions (self : t) : bool = + Delayed_actions.is_empty self.delayed_actions + +let[@inline] perform_delayed_actions self = + if not (has_no_delayed_actions self) then perform_delayed_actions_ self + +let[@specialise] acts_iter self ~full head f : unit = + for + i = + if full then + 0 + else + head to AVec.size self.trail - 1 + do + let a = AVec.get self.trail i in + f (Atom.lit self.store a) + done + +let eval_atom_ self a = + if Atom.is_true self.store a then + L_true + else if Atom.is_false self.store a then + L_false + else + L_undefined + +let[@inline] acts_eval_lit self (f : Lit.t) : lbool = + let a = make_atom_ self f in + eval_atom_ self a + +let[@inline] acts_add_lit self ?default_pol f : unit = + ignore (make_atom_ ?default_pol self f : atom) + +let[@inline] current_slice st : acts = + let module M = struct + let proof = st.proof + let iter_assumptions = acts_iter st ~full:false st.th_head + let eval_lit = acts_eval_lit st + let add_lit = acts_add_lit st + let add_clause = acts_add_clause st + let propagate = acts_propagate st + let raise_conflict c pr = acts_raise st c pr + let add_decision_lit = acts_add_decision_lit st + end in + (module M) + +(* full slice, for [if_sat] final check *) +let[@inline] full_slice st : acts = + let module M = struct + let proof = st.proof + let iter_assumptions = acts_iter st ~full:true st.th_head + let eval_lit = acts_eval_lit st + let add_lit = acts_add_lit st + let add_clause = acts_add_clause st + let propagate = acts_propagate st + let raise_conflict c pr = acts_raise st c pr + let add_decision_lit = acts_add_decision_lit st + end in + (module M) + +(* Assert that the conflict is indeeed a conflict *) +let check_is_conflict_ self (c : Clause.t) : unit = + if not @@ Clause.for_all self.store c ~f:(Atom.is_false self.store) then ( + Log.debugf 0 (fun k -> + k "conflict should be false: %a" (Clause.debug self.store) c); + assert false + ) + +(* some boolean literals were decided/propagated within Msat. Now we + need to inform the theory of those assumptions, so it can do its job. + @return the conflict clause, if the theory detects unsatisfiability *) +let rec theory_propagate self : clause option = + assert (self.elt_head = AVec.size self.trail); + assert (self.th_head <= self.elt_head); + if self.th_head = self.elt_head then + None + (* fixpoint/no propagation *) + else ( + let slice = current_slice self in + self.th_head <- self.elt_head; + (* catch up *) + let (module P) = self.plugin in + match P.partial_check slice with + | () -> + perform_delayed_actions self; + propagate self + | exception Th_conflict c -> + check_is_conflict_ self c; + Clause.iter self.store c ~f:(fun a -> insert_var_order self (Atom.var a)); + Some c + ) + +(* fixpoint between boolean propagation and theory propagation + @return a conflict clause, if any *) +and propagate (st : t) : clause option = + (* First, treat the stack of lemmas/actions added by the theory, if any *) + perform_delayed_actions st; + (* Now, check that the situation is sane *) + assert (st.elt_head <= AVec.size st.trail); + if st.elt_head = AVec.size st.trail then + theory_propagate st + else ( + match + while st.elt_head < AVec.size st.trail do + let a = AVec.get st.trail st.elt_head in + propagate_atom st a; + st.elt_head <- st.elt_head + 1 + done + with + | () -> theory_propagate st + | exception Conflict c -> Some c + ) + +(* compute unsat core from assumption [a] *) +let analyze_final (self : t) (a : atom) : atom list = + let store = self.store in + Log.debugf 5 (fun k -> + k "(@[sat.analyze-final@ :lit %a@])" (Atom.debug store) a); + assert (Atom.is_false store a); + let core = ref [ a ] in + let idx = ref (AVec.size self.trail - 1) in + Var.mark store (Atom.var a); + let seen = ref [ Atom.var a ] in + while !idx >= 0 do + let a' = AVec.get self.trail !idx in + if Var.marked store (Atom.var a') then ( + match Atom.reason store a' with + | Some Decision -> core := a' :: !core + | Some (Bcp c | Bcp_lazy (lazy c)) -> + Clause.iter store c ~f:(fun a -> + let v = Atom.var a in + if not (Var.marked store v) then ( + seen := v :: !seen; + Var.mark store v + )) + | None -> () + ); + decr idx + done; + List.iter (Var.unmark store) !seen; + Log.debugf 5 (fun k -> + k "(@[sat.analyze-final.done@ :core %a@])" + (Format.pp_print_list (Atom.debug store)) + !core); + !core + +(* GC: remove some learnt clauses. + This works even during the proof with a non empty trail. *) +let reduce_clause_db (self : t) : unit = + let store = self.store in + + Log.debugf 3 (fun k -> + k "(@[sat.gc-clauses.start :max-learnt %d@])" !(self.max_clauses_learnt)); + + let to_be_gc = self.temp_clause_vec in + (* clauses to collect *) + assert (CVec.is_empty to_be_gc); + + (* atoms whose watches will need to be rebuilt to filter out + dead clauses *) + let dirty_atoms = self.temp_atom_vec in + assert (AVec.is_empty dirty_atoms); + + (* [a] is watching at least one removed clause, we'll need to + trim its watchlist *) + let[@inline] mark_dirty_atom a = + if not (Atom.marked store a) then ( + Atom.mark store a; + AVec.push dirty_atoms a + ) + in + + (* iter on the clauses that are used to explain atoms on the trail, + which we must therefore keep for now as they might participate in + conflict resolution *) + let iter_clauses_on_trail ~f : unit = + AVec.iter self.trail ~f:(fun a -> + match Atom.reason store a with + | Some (Bcp c) -> f c + | Some (Bcp_lazy lc) when Lazy.is_val lc -> f (Lazy.force lc) + | _ -> ()) + in + + iter_clauses_on_trail ~f:(fun c -> Clause.set_marked store c true); + + (* first, mark clauses used on the trail, we cannot GC them. + TODO: once we use DRUP, we can avoid marking level-0 explanations + as they will never participate in resolution. *) + AVec.iter + ~f:(fun a -> + match Atom.reason store a with + | Some (Bcp c) -> Clause.set_marked store c true + | Some (Bcp_lazy lc) when Lazy.is_val lc -> + Clause.set_marked store (Lazy.force lc) true + | _ -> ()) + self.trail; + + (* GC the clause [c] *) + let flag_clause_for_gc c : unit = + assert (Clause.removable store c); + Log.debugf 10 (fun k -> + k "(@[sat.gc.will-collect@ %a@])" (Clause.debug store) c); + CVec.push to_be_gc c; + Clause.set_dead store c true; + let atoms = Clause.atoms_a store c in + mark_dirty_atom (Atom.neg atoms.(0)); + (* need to remove from watchlists *) + mark_dirty_atom (Atom.neg atoms.(1)); + Event.emit self.on_gc (Clause.lits_a store c); + Proof_trace.delete self.proof (Clause.proof_step store c) + in + + let gc_arg = + (module struct + let store = self.store + let flag_clause_for_gc = flag_clause_for_gc + let must_keep_clause c = Clause.marked store c + end : GC_ARG) + in + + (* GC a pool, if it needs it *) + let gc_pool (module P : CLAUSE_POOL) : unit = + if P.needs_gc () then ( + Log.debugf 5 (fun k -> k "(@[sat.gc.pool@ :descr %s@])" (P.descr ())); + P.gc gc_arg + ) + in + + gc_pool self.clauses_learnt; + Vec.iter ~f:gc_pool self.clause_pools; + + let n_collected = CVec.size to_be_gc in + + (* update watchlist of dirty atoms *) + AVec.iter dirty_atoms ~f:(fun a -> + assert (Atom.marked store a); + Atom.unmark store a; + let w = Atom.watched store a in + CVec.filter_in_place (fun c -> not (Clause.dead store c)) w); + AVec.clear dirty_atoms; + + (* actually remove the clauses now that they are detached *) + CVec.iter ~f:(Clause.dealloc store) to_be_gc; + CVec.clear to_be_gc; + + (* remove marks on clauses on the trail *) + iter_clauses_on_trail ~f:(fun c -> Clause.set_marked store c false); + + Log.debugf 3 (fun k -> k "(@[sat.gc.done :collected %d@])" n_collected); + () + +(* Decide on a new literal, and enqueue it into the trail. + Return [true] if a decision was made. + @param full if true, do decisions; + if false, only pick from [self.next_decisions] + and [self.assumptions] *) +let pick_branch_lit ~full self : bool = + let rec pick_lit () = + match self.next_decisions with + | atom :: tl -> + self.next_decisions <- tl; + pick_with_given_atom atom + | [] when decision_level self < AVec.size self.assumptions -> + (* use an assumption *) + let a = AVec.get self.assumptions (decision_level self) in + if Atom.is_true self.store a then ( + new_decision_level self; + (* pseudo decision level, [a] is already true *) + pick_lit () + ) else if Atom.is_false self.store a then ( + (* root conflict, find unsat core *) + let core = analyze_final self a in + raise (E_unsat (US_local { first = a; core })) + ) else + pick_with_given_atom a + | [] when not full -> false + | [] -> + (match H.remove_min self.order with + | v -> + pick_with_given_atom + (if Var.default_pol self.store v then + Atom.pa v + else + Atom.na v) + | exception Not_found -> false) + (* pick a decision, trying [atom] first if it's not assigned yet. *) + and pick_with_given_atom (atom : atom) : bool = + let v = Atom.var atom in + if Var.level self.store v >= 0 then ( + assert ( + Atom.is_true self.store (Atom.pa v) + || Atom.is_true self.store (Atom.na v)); + pick_lit () + ) else ( + new_decision_level self; + let current_level = decision_level self in + enqueue_bool self atom ~level:current_level Decision; + Stat.incr self.n_decisions; + Event.emit self.on_decision (Atom.lit self.store atom); + true + ) + in + pick_lit () + +(* do some amount of search, until the number of conflicts or clause learnt + reaches the given parameters *) +let search (self : t) ~on_progress ~(max_conflicts : int) : unit = + Log.debugf 3 (fun k -> + k "(@[sat.search@ :max-conflicts %d@ :max-learnt %d@])" max_conflicts + !(self.max_clauses_learnt)); + let n_conflicts = ref 0 in + while true do + match propagate self with + | Some confl -> + (* Conflict *) + incr n_conflicts; + (* When the theory has raised Unsat, add_boolean_conflict + might 'forget' the initial conflict clause, and only add the + analyzed backtrack clause. So in those case, we use add_clause + to make sure the initial conflict clause is also added. *) + if Clause.attached self.store confl then + add_boolean_conflict self confl + else + add_clause_ ~pool:self.clauses_learnt self confl; + Stat.incr self.n_conflicts; + Event.emit self.on_conflict confl + | None -> + (* No Conflict *) + assert (self.elt_head = AVec.size self.trail); + assert (self.elt_head = self.th_head); + if max_conflicts > 0 && !n_conflicts >= max_conflicts then ( + Log.debug 1 "(sat.restarting)"; + cancel_until self 0; + Stat.incr self.n_restarts; + raise_notrace Restart + ); + + (* if decision_level() = 0 then simplify (); *) + let do_gc = + !(self.max_clauses_learnt) > 0 + && cp_size_ self.clauses_learnt - AVec.size self.trail + > !(self.max_clauses_learnt) + || Vec.exists cp_needs_gc_ self.clause_pools + in + if do_gc then ( + reduce_clause_db self; + on_progress () + ); + + let decided = pick_branch_lit ~full:true self in + if not decided then raise_notrace E_sat + done + +let eval_level (self : t) (a : atom) = + let lvl = Atom.level self.store a in + if Atom.is_true self.store a then ( + assert (lvl >= 0); + true, lvl + ) else if Atom.is_false self.store a then + false, lvl + else + raise UndecidedLit + +let[@inline] eval st lit = fst @@ eval_level st lit + +(* fixpoint of propagation and decisions until a model is found, or a + conflict is reached *) +let solve_ ~on_progress (self : t) : unit = + Log.debugf 5 (fun k -> + k "(@[sat.solve :assms %d@])" (AVec.size self.assumptions)); + check_unsat_ self; + try + perform_delayed_actions self; + (* add initial clauses *) + let max_conflicts = ref (float_of_int restart_first) in + let max_learnt = + ref (float_of_int (nb_clauses self) *. learntsize_factor) + in + while true do + on_progress (); + try + self.max_clauses_learnt := int_of_float !max_learnt; + search self ~on_progress ~max_conflicts:(int_of_float !max_conflicts) + with + | Restart -> + max_conflicts := !max_conflicts *. restart_inc; + max_learnt := !max_learnt *. learntsize_inc + | E_sat -> + assert ( + self.elt_head = AVec.size self.trail + && has_no_delayed_actions self + && self.next_decisions = []); + on_progress (); + let (module P) = self.plugin in + (match P.final_check (full_slice self) with + | () -> + if + self.elt_head = AVec.size self.trail + && has_no_delayed_actions self + && self.next_decisions = [] + then + (* nothing more to do, that means the plugin is satisfied + with the trail *) + raise_notrace E_sat; + (* otherwise, keep on *) + perform_delayed_actions self + | exception Th_conflict c -> + check_is_conflict_ self c; + Clause.iter self.store c ~f:(fun a -> + insert_var_order self (Atom.var a)); + Log.debugf 5 (fun k -> + k "(@[sat.theory-conflict-clause@ %a@])" (Clause.debug self.store) + c); + Stat.incr self.n_conflicts; + Event.emit self.on_conflict c; + Delayed_actions.add_clause_learnt self.delayed_actions c; + perform_delayed_actions self; + on_progress ()) + done + with E_sat -> () + +let assume self cnf : unit = + List.iter + (fun l -> + let atoms = Util.array_of_list_map (make_atom_ self) l in + let proof = + Proof_trace.add_step self.proof + @@ Proof_sat.sat_input_clause (Iter.of_list l) + in + let c = Clause.make_a self.store ~removable:false atoms proof in + Log.debugf 10 (fun k -> + k "(@[sat.assume-clause@ @[%a@]@])" (Clause.debug self.store) c); + Delayed_actions.add_clause_learnt self.delayed_actions c) + cnf + +let[@inline] store st = st.store +let[@inline] proof st = st.proof + +let[@inline] add_lit self ?default_pol lit = + ignore (make_atom_ self lit ?default_pol : atom) + +let[@inline] set_default_pol (self : t) (lit : Lit.t) (pol : bool) : unit = + let a = make_atom_ self lit ~default_pol:pol in + Var.set_default_pol self.store (Atom.var a) pol + +(* Result type *) +type res = Sat of sat_state | Unsat of clause unsat_state + +let pp_all self lvl status = + Log.debugf lvl (fun k -> + k + "(@[sat.full-state :res %s - Full summary:@,\ + @[Trail:@\n\ + %a@]@,\ + @[Hyps:@\n\ + %a@]@,\ + @[Lemmas:@\n\ + %a@]@,\ + @]@." + status + (AVec.pp @@ Atom.debug self.store) + self.trail + (CVec.pp @@ Clause.debug self.store) + self.clauses_hyps + (Util.pp_iter @@ Clause.debug self.store) + (cp_to_iter_ self.clauses_learnt)) + +let mk_sat (self : t) : sat_state = + pp_all self 99 "SAT"; + let t = self.trail in + let module M = struct + let iter_trail f = AVec.iter ~f:(fun a -> f (Atom.lit self.store a)) t + let[@inline] eval f = eval self (make_atom_ self f) + let[@inline] eval_level f = eval_level self (make_atom_ self f) + end in + (module M) + +(* make a clause that contains no level-0 false literals, by resolving + against them. This clause can be used in a refutation proof. + Note that the clause might still contain some {b assumptions}. *) +let resolve_with_lvl0 (self : t) (c : clause) : clause = + let lvl0 = ref [] in + let res = ref [] in + let to_unmark = self.temp_atom_vec in + assert (AVec.is_empty to_unmark); + + (* resolve against the root cause of [a] being false *) + let resolve_with_a (a : atom) : unit = + assert (Atom.is_false self.store a && Atom.level self.store a = 0); + if not (Var.marked self.store (Atom.var a)) then ( + Log.debugf 50 (fun k -> + k "(@[sat.resolve-lvl0@ :atom %a@])" (Atom.debug self.store) a); + AVec.push to_unmark a; + Var.mark self.store (Atom.var a); + + let p = proof_of_atom_lvl0_ self (Atom.neg a) in + lvl0 := p :: !lvl0 + ) + in + + Clause.iter self.store c ~f:(fun a -> + if Atom.level self.store a = 0 then resolve_with_a a); + AVec.iter to_unmark ~f:(fun a -> Var.unmark self.store (Atom.var a)); + AVec.clear to_unmark; + + if !lvl0 = [] then + c + (* no resolution happened *) + else ( + let proof = + let lits = Iter.of_list !res |> Iter.map (Atom.lit self.store) in + let hyps = Iter.of_list (Clause.proof_step self.store c :: !lvl0) in + Proof_trace.add_step self.proof + @@ Proof_sat.sat_redundant_clause lits ~hyps + in + Clause.make_l self.store ~removable:false !res proof + ) + +let mk_unsat (self : t) (us : unsat_cause) : _ unsat_state = + pp_all self 99 "UNSAT"; + let store = store self in + let unsat_assumptions () = + match us with + | US_local { first = _; core } -> + let lits = Iter.of_list core |> Iter.map (Atom.lit store) in + lits + | _ -> Iter.empty + in + let unsat_conflict = + match us with + | US_false c0 -> + Log.debugf 10 (fun k -> + k "(@[sat.unsat-conflict-clause@ %a@])" (Clause.debug store) c0); + let c = resolve_with_lvl0 self c0 in + Log.debugf 10 (fun k -> + k "(@[sat.unsat-conflict-clause.proper@ %a@])" (Clause.debug store) c); + fun () -> c + | US_local { core = []; _ } -> assert false + | US_local { first; core } -> + (* TODO: do we need to filter out literals? *) + let c = + lazy + (let core = List.rev core in + (* increasing trail order *) + assert (Atom.equal first @@ List.hd core); + let proof = + let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in + Proof_trace.add_step self.proof @@ Proof_sat.sat_unsat_core lits + in + Clause.make_l self.store ~removable:false [] proof) + in + fun () -> Lazy.force c + in + let module M = struct + type clause = Clause.t + + let unsat_conflict = unsat_conflict + let unsat_assumptions = unsat_assumptions + + let unsat_proof () = + let c = unsat_conflict () in + Clause.proof_step self.store c + end in + (module M) + +type propagation_result = + | PR_sat + | PR_conflict of { backtracked: int } + | PR_unsat of clause unsat_state + +(* decide on assumptions, and do propagations, but no other kind of decision *) +let propagate_under_assumptions (self : t) : propagation_result = + let result = ref PR_sat in + try + while true do + match propagate self with + | Some confl -> + (* When the theory has raised Unsat, add_boolean_conflict + might 'forget' the initial conflict clause, and only add the + analyzed backtrack clause. So in those case, we use add_clause + to make sure the initial conflict clause is also added. *) + if Clause.attached self.store confl then + add_boolean_conflict self confl + else + add_clause_ ~pool:self.clauses_learnt self confl; + Stat.incr self.n_conflicts; + + (* see by how much we backtracked the decision trail *) + let new_lvl = decision_level self in + assert (new_lvl < AVec.size self.assumptions); + let backtracked = AVec.size self.assumptions - new_lvl in + result := PR_conflict { backtracked }; + AVec.shrink self.assumptions new_lvl; + raise_notrace Exit + | None -> + (* No Conflict *) + let decided = pick_branch_lit self ~full:false in + if not decided then ( + result := PR_sat; + raise Exit + ) + done; + assert false + with Exit -> !result + +let add_clause_atoms_ self ~pool ~removable (c : atom array) + (pr : Proof_step.id) : unit = + try + let c = Clause.make_a self.store ~removable c pr in + add_clause_ ~pool self c + with E_unsat (US_false c) -> self.unsat_at_0 <- Some c + +let add_clause_a self c pr : unit = + let c = Array.map (make_atom_ self) c in + add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr + +let add_clause self (c : Lit.t list) (pr : Proof_step.id) : unit = + let c = Util.array_of_list_map (make_atom_ self) c in + add_clause_atoms_ ~pool:self.clauses_learnt ~removable:false self c pr + +let add_input_clause self (c : Lit.t list) = + let pr = + Proof_trace.add_step self.proof + @@ Proof_sat.sat_input_clause (Iter.of_list c) + in + add_clause self c pr + +let add_input_clause_a self c = + let pr = + Proof_trace.add_step self.proof + @@ Proof_sat.sat_input_clause (Iter.of_array c) + in + add_clause_a self c pr + +(* run [f()] with additional assumptions *) +let with_local_assumptions_ (self : t) (assumptions : Lit.t list) f = + let old_assm_lvl = AVec.size self.assumptions in + List.iter + (fun lit -> + let a = make_atom_ self lit in + AVec.push self.assumptions a) + assumptions; + try + let x = f () in + AVec.shrink self.assumptions old_assm_lvl; + x + with e -> + AVec.shrink self.assumptions old_assm_lvl; + raise e + +let solve ?(on_progress = fun _ -> ()) ?(assumptions = []) (self : t) : res = + cancel_until self 0; + (* make sure we are at level 0 *) + with_local_assumptions_ self assumptions @@ fun () -> + try + solve_ ~on_progress self; + Sat (mk_sat self) + with E_unsat us -> Unsat (mk_unsat self us) + +let push_assumption (self : t) (lit : Lit.t) : unit = + let a = make_atom_ self lit in + AVec.push self.assumptions a + +let pop_assumptions self n : unit = + let n_ass = AVec.size self.assumptions in + assert (n <= n_ass); + AVec.shrink self.assumptions (n_ass - n) + +let check_sat_propagations_only ?(assumptions = []) (self : t) : + propagation_result = + cancel_until self 0; + with_local_assumptions_ self assumptions @@ fun () -> + try + check_unsat_ self; + perform_delayed_actions self; + (* add initial clauses *) + propagate_under_assumptions self + with E_unsat us -> + let us = mk_unsat self us in + PR_unsat us + +let true_at_level0 (self : t) (lit : Lit.t) : bool = + match find_atom_ self lit with + | None -> false + | Some a -> + (try + let b, lev = eval_level self a in + b && lev = 0 + with UndecidedLit -> false) + +let[@inline] eval_lit self (lit : Lit.t) : lbool = + match find_atom_ self lit with + | Some a -> eval_atom_ self a + | None -> L_undefined + +let create ?(stat = Stat.global) ?(size = `Big) ~proof (p : plugin) : t = + let store = Store.create ~size ~stat () in + let max_clauses_learnt = ref 0 in + let self = create_ ~max_clauses_learnt ~store ~proof ~stat p in + self + +let plugin_cdcl_t (module P : THEORY_CDCL_T) : (module PLUGIN) = + (module struct + include P + + let has_theory = true + end) + +let plugin_pure_sat : plugin = + (module struct + let push_level () = () + let pop_levels _ = () + let partial_check _ = () + let final_check _ = () + let has_theory = false + end) + +let create_pure_sat ?stat ?size ~proof () : t = + create ?stat ?size ~proof plugin_pure_sat diff --git a/src/sat/solver.mli b/src/sat/solver.mli new file mode 100644 index 00000000..808dde58 --- /dev/null +++ b/src/sat/solver.mli @@ -0,0 +1,176 @@ +(** The external interface implemented by SAT solvers. *) + +(* +MSAT is free software, using the Apache license, see file LICENSE +Copyright 2016 Guillaume Bury +Copyright 2016 Simon Cruanes +*) + +open Sidekick_core +open Sigs + +type clause +type plugin = Sigs.plugin + +type solver +(** The main solver type. *) + +type store +(** Stores atoms, clauses, etc. *) + +module Clause : sig + type t = clause + + val equal : t -> t -> bool + + module Tbl : Hashtbl.S with type key = t + + val pp : store -> t Fmt.printer + (** Print the clause *) + + val short_name : store -> t -> string + (** Short name for a clause. Unspecified *) + + val n_atoms : store -> t -> int + + val lits_iter : store -> t -> Lit.t Iter.t + (** Literals of a clause *) + + val lits_a : store -> t -> Lit.t array + (** Atoms of a clause *) + + val lits_l : store -> t -> Lit.t list + (** List of atoms of a clause *) +end + +(** {2 Main Solver Type} *) + +type t = solver +(** Main solver type, containing all state for solving. *) + +val store : t -> store +(** Store for the solver *) + +val stat : t -> Stat.t +(** Statistics *) + +val proof : t -> Proof_trace.t +(** Access the inner proof *) + +val on_conflict : t -> (Clause.t, unit) Event.t +val on_decision : t -> (Lit.t, unit) Event.t +val on_learnt : t -> (Clause.t, unit) Event.t +val on_gc : t -> (Lit.t array, unit) Event.t + +(** {2 Types} *) + +(** Result type for the solver *) +type res = + | Sat of sat_state (** Returned when the solver reaches SAT, with a model *) + | Unsat of clause unsat_state + (** Returned when the solver reaches UNSAT, with a proof *) + +exception UndecidedLit +(** Exception raised by the evaluating functions when a literal + has not yet been assigned a value. *) + +(** {2 Base operations} *) + +val assume : t -> Lit.t list list -> unit +(** Add the list of clauses to the current set of assumptions. + Modifies the sat solver state in place. *) + +val add_clause : t -> Lit.t list -> Proof_step.id -> unit +(** Lower level addition of clauses *) + +val add_clause_a : t -> Lit.t array -> Proof_step.id -> unit +(** Lower level addition of clauses *) + +val add_input_clause : t -> Lit.t list -> unit +(** Like {!add_clause} but with the justification of being an input clause *) + +val add_input_clause_a : t -> Lit.t array -> unit +(** Like {!add_clause_a} but with justification of being an input clause *) + +(** {2 Solving} *) + +val solve : ?on_progress:(unit -> unit) -> ?assumptions:Lit.t list -> t -> res +(** Try and solves the current set of clauses. + @param assumptions additional atomic assumptions to be temporarily added. + The assumptions are just used for this call to [solve], they are + not saved in the solver's state. + @param on_progress regularly called during solving. + Can raise {!Resource_exhausted} + to stop solving. + + @raise Resource_exhausted if the on_progress handler raised it to stop + *) + +(** {2 Evaluating and adding literals} *) + +val add_lit : t -> ?default_pol:bool -> Lit.t -> unit +(** Ensure the SAT solver handles this particular literal, ie add + a boolean variable for it if it's not already there. *) + +val set_default_pol : t -> Lit.t -> bool -> unit +(** Set default polarity for the given boolean variable. + Sign of the literal is ignored. *) + +val true_at_level0 : t -> Lit.t -> bool +(** [true_at_level0 a] returns [true] if [a] was proved at level0, i.e. + it must hold in all models *) + +val eval_lit : t -> Lit.t -> lbool +(** Evaluate atom in current state *) + +(** {2 Assumption stack} *) + +val push_assumption : t -> Lit.t -> unit +(** Pushes an assumption onto the assumption stack. It will remain + there until it's pop'd by {!pop_assumptions}. *) + +val pop_assumptions : t -> int -> unit +(** [pop_assumptions solver n] removes [n] assumptions from the stack. + It removes the assumptions that were the most + recently added via {!push_assumptions}. *) + +(** Result returned by {!check_sat_propagations_only} *) +type propagation_result = + | PR_sat + | PR_conflict of { backtracked: int } + | PR_unsat of clause unsat_state + +val check_sat_propagations_only : + ?assumptions:Lit.t list -> t -> propagation_result +(** [check_sat_propagations_only solver] uses the added clauses + and local assumptions (using {!push_assumptions} and [assumptions]) + to quickly assess whether the context is satisfiable. + It is not complete; calling {!solve} is required to get an accurate + result. + @returns either [Ok()] if propagation yielded no conflict, or [Error c] + if a conflict clause [c] was found. *) + +(** {2 Initialization} *) + +val plugin_cdcl_t : (module THEORY_CDCL_T) -> (module PLUGIN) + +val create : + ?stat:Stat.t -> + ?size:[ `Tiny | `Small | `Big ] -> + proof:Proof_trace.t -> + plugin -> + t +(** Create new solver + @param theory the theory + @param the proof + @param size the initial size of internal data structures. The bigger, + the faster, but also the more RAM it uses. *) + +val plugin_pure_sat : plugin + +val create_pure_sat : + ?stat:Stat.t -> + ?size:[ `Tiny | `Small | `Big ] -> + proof:Proof_trace.t -> + unit -> + t diff --git a/src/sat/store.ml b/src/sat/store.ml new file mode 100644 index 00000000..a91447e2 --- /dev/null +++ b/src/sat/store.ml @@ -0,0 +1,408 @@ +open Sidekick_core +open Sigs +include Base_types_ +module Lit_tbl = Hashtbl.Make (Lit) + +type cstore = { + c_lits: atom array Vec.t; (* storage for clause content *) + c_activity: Vec_float.t; + c_recycle_idx: Veci.t; (* recycle clause numbers that were GC'd *) + c_proof: Step_vec.t; (* clause -> proof_rule for its proof *) + c_attached: Bitvec.t; + c_marked: Bitvec.t; + c_removable: Bitvec.t; + c_dead: Bitvec.t; +} + +type t = { + (* variables *) + v_of_lit: var Lit_tbl.t; (* lit -> var *) + v_level: int Vec.t; (* decision/assignment level, or -1 *) + v_heap_idx: int Vec.t; (* index in priority heap *) + v_weight: Vec_float.t; (* heuristic activity *) + v_reason: var_reason option Vec.t; (* reason for assignment *) + v_seen: Bitvec.t; (* generic temporary marker *) + v_default_polarity: Bitvec.t; (* default polarity in decisions *) + mutable v_count: int; + (* atoms *) + a_is_true: Bitvec.t; + a_seen: Bitvec.t; + a_form: Lit.t Vec.t; + (* TODO: store watches in clauses instead *) + a_watched: Clause0.CVec.t Vec.t; + a_proof_lvl0: Proof_step.id ATbl.t; + (* atom -> proof for it to be true at level 0 *) + stat_n_atoms: int Stat.counter; + (* clauses *) + c_store: cstore; +} + +type store = t + +let create ?(size = `Big) ~stat () : t = + let size_map = + match size with + | `Tiny -> 8 + | `Small -> 16 + | `Big -> 4096 + in + let stat_n_atoms = Stat.mk_int stat "sat.n-atoms" in + { + v_of_lit = Lit_tbl.create size_map; + v_level = Vec.create (); + v_heap_idx = Vec.create (); + v_weight = Vec_float.create (); + v_reason = Vec.create (); + v_seen = Bitvec.create (); + v_default_polarity = Bitvec.create (); + v_count = 0; + a_is_true = Bitvec.create (); + a_form = Vec.create (); + a_watched = Vec.create (); + a_seen = Bitvec.create (); + a_proof_lvl0 = ATbl.create 16; + stat_n_atoms; + c_store = + { + c_lits = Vec.create (); + c_activity = Vec_float.create (); + c_recycle_idx = Veci.create ~cap:0 (); + c_proof = Step_vec.create ~cap:0 (); + c_dead = Bitvec.create (); + c_attached = Bitvec.create (); + c_removable = Bitvec.create (); + c_marked = Bitvec.create (); + }; + } + +(** iterate on variables *) +let iter_vars self f = + Vec.iteri self.v_level ~f:(fun i _ -> f (Var0.of_int_unsafe i)) + +module Var = struct + include Var0 + + let[@inline] level self v = Vec.get self.v_level (v : var :> int) + let[@inline] set_level self v l = Vec.set self.v_level (v : var :> int) l + let[@inline] reason self v = Vec.get self.v_reason (v : var :> int) + let[@inline] set_reason self v r = Vec.set self.v_reason (v : var :> int) r + let[@inline] weight self v = Vec_float.get self.v_weight (v : var :> int) + + let[@inline] set_weight self v w = + Vec_float.set self.v_weight (v : var :> int) w + + let[@inline] mark self v = Bitvec.set self.v_seen (v : var :> int) true + let[@inline] unmark self v = Bitvec.set self.v_seen (v : var :> int) false + let[@inline] marked self v = Bitvec.get self.v_seen (v : var :> int) + + let[@inline] set_default_pol self v b = + Bitvec.set self.v_default_polarity (v : var :> int) b + + let[@inline] default_pol self v = + Bitvec.get self.v_default_polarity (v : var :> int) + + let[@inline] heap_idx self v = Vec.get self.v_heap_idx (v : var :> int) + + let[@inline] set_heap_idx self v i = + Vec.set self.v_heap_idx (v : var :> int) i +end + +module Atom = struct + include Atom0 + + let[@inline] lit self a = Vec.get self.a_form (a : atom :> int) + let lit = lit + let[@inline] mark self a = Bitvec.set self.a_seen (a : atom :> int) true + let[@inline] unmark self a = Bitvec.set self.a_seen (a : atom :> int) false + let[@inline] marked self a = Bitvec.get self.a_seen (a : atom :> int) + let[@inline] watched self a = Vec.get self.a_watched (a : atom :> int) + let[@inline] is_true self a = Bitvec.get self.a_is_true (a : atom :> int) + + let[@inline] set_is_true self a b = + Bitvec.set self.a_is_true (a : atom :> int) b + + let[@inline] is_false self a = is_true self (neg a) + let[@inline] has_value self a = is_true self a || is_false self a + let[@inline] reason self a = Var.reason self (var a) + let[@inline] level self a = Var.level self (var a) + let[@inline] marked_both self a = marked self a && marked self (neg a) + let proof_lvl0 self a = ATbl.get self.a_proof_lvl0 a + let set_proof_lvl0 self a p = ATbl.replace self.a_proof_lvl0 a p + let pp self fmt a = Lit.pp fmt (lit self a) + + let pp_a self fmt v = + if Array.length v = 0 then + Format.fprintf fmt "@<1>∅" + else ( + pp self fmt v.(0); + if Array.length v > 1 then + for i = 1 to Array.length v - 1 do + Format.fprintf fmt " @<1>∨ %a" (pp self) v.(i) + done + ) + + (* Complete debug printing *) + + let[@inline] pp_sign a = + if sign a then + "+" + else + "-" + + (* print level+reason of assignment *) + let debug_reason _self out = function + | n, _ when n < 0 -> Format.fprintf out "%%" + | n, None -> Format.fprintf out "%d" n + | n, Some Decision -> Format.fprintf out "@@%d" n + | n, Some (Bcp c) -> Format.fprintf out "->%d/%d" n (c :> int) + | n, Some (Bcp_lazy _) -> Format.fprintf out "->%d/" n + + let pp_level self out a = + let v = var a in + debug_reason self out (Var.level self v, Var.reason self v) + + let debug_value self out (a : atom) = + if is_true self a then + Format.fprintf out "T%a" (pp_level self) a + else if is_false self a then + Format.fprintf out "F%a" (pp_level self) a + else + () + + let debug self out a = + Format.fprintf out "%s%d[%a][atom:@[%a@]]" (pp_sign a) + (var a : var :> int) + (debug_value self) a Lit.pp (lit self a) + + let debug_a self out vec = + Array.iter (fun a -> Format.fprintf out "@[%a@]@ " (debug self) a) vec +end + +module Clause = struct + include Clause0 + + (* TODO: store watch lists inside clauses *) + + let make_a (store : store) ~removable (atoms : atom array) proof_step : t = + let { + c_recycle_idx; + c_lits; + c_activity; + c_attached; + c_dead; + c_removable; + c_marked; + c_proof; + } = + store.c_store + in + (* allocate new ID *) + let cid = + if Veci.is_empty c_recycle_idx then + Vec.size c_lits + else + Veci.pop c_recycle_idx + in + + (* allocate space *) + (let new_len = cid + 1 in + Vec.ensure_size c_lits ~elt:[||] new_len; + Vec_float.ensure_size c_activity new_len; + Step_vec.ensure_size c_proof new_len; + Bitvec.ensure_size c_attached new_len; + Bitvec.ensure_size c_dead new_len; + Bitvec.ensure_size c_removable new_len; + Bitvec.ensure_size c_marked new_len; + + Bitvec.set c_removable cid removable); + + Vec.set c_lits cid atoms; + Step_vec.set c_proof cid proof_step; + + let c = of_int_unsafe cid in + c + + let make_l store ~removable atoms proof_rule : t = + make_a store ~removable (Array.of_list atoms) proof_rule + + let[@inline] n_atoms (store : store) (c : t) : int = + Array.length (Vec.get store.c_store.c_lits (c : t :> int)) + + let[@inline] iter (store : store) ~f c = + let { c_lits; _ } = store.c_store in + Array.iter f (Vec.get c_lits (c : t :> int)) + + exception Early_exit + + let for_all store ~f c = + try + iter store c ~f:(fun x -> if not (f x) then raise_notrace Early_exit); + true + with Early_exit -> false + + let fold (store : store) ~f acc c = + let { c_lits; _ } = store.c_store in + Array.fold_left f acc (Vec.get c_lits (c : t :> int)) + + let[@inline] marked store c = Bitvec.get store.c_store.c_marked (c : t :> int) + + let[@inline] set_marked store c b = + Bitvec.set store.c_store.c_marked (c : t :> int) b + + let[@inline] attached store c = + Bitvec.get store.c_store.c_attached (c : t :> int) + + let[@inline] set_attached store c b = + Bitvec.set store.c_store.c_attached (c : t :> int) b + + let[@inline] dead store c = Bitvec.get store.c_store.c_dead (c : t :> int) + + let[@inline] set_dead store c b = + Bitvec.set store.c_store.c_dead (c : t :> int) b + + let[@inline] removable store c = + Bitvec.get store.c_store.c_removable (c : t :> int) + + let[@inline] proof_step store c = + Step_vec.get store.c_store.c_proof (c : t :> int) + + let dealloc store c : unit = + assert (dead store c); + let { + c_lits; + c_recycle_idx; + c_activity; + c_proof = _; + c_dead; + c_removable; + c_attached; + c_marked; + } = + store.c_store + in + + (* clear data *) + let cid = (c : t :> int) in + Bitvec.set c_attached cid false; + Bitvec.set c_dead cid false; + Bitvec.set c_removable cid false; + Bitvec.set c_marked cid false; + Vec.set c_lits cid [||]; + Vec_float.set c_activity cid 0.; + + Veci.push c_recycle_idx cid; + (* recycle idx *) + () + + let[@inline] activity store c = + Vec_float.get store.c_store.c_activity (c : t :> int) + + let[@inline] set_activity store c f = + Vec_float.set store.c_store.c_activity (c : t :> int) f + + let[@inline] atoms_a store c : atom array = + Vec.get store.c_store.c_lits (c : t :> int) + + let lits_l store c : Lit.t list = + let arr = atoms_a store c in + Util.array_to_list_map (Atom.lit store) arr + + let lits_a store c : Lit.t array = + let arr = atoms_a store c in + Array.map (Atom.lit store) arr + + let lits_iter store c : Lit.t Iter.t = + let arr = atoms_a store c in + Iter.of_array arr |> Iter.map (Atom.lit store) + + let short_name _store c = Printf.sprintf "cl[%d]" (c : t :> int) + + let pp store fmt c = + Format.fprintf fmt "(cl[%d] : %a" + (c : t :> int) + (Atom.pp_a store) (atoms_a store c) + + let debug store out c = + let atoms = atoms_a store c in + Format.fprintf out "(@[cl[%d]@ {@[%a@]}@])" + (c : t :> int) + (Atom.debug_a store) atoms +end + +(* allocate new variable *) +let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var = + let { + v_count; + v_of_lit; + v_level; + v_heap_idx; + v_weight; + v_reason; + v_seen; + v_default_polarity; + stat_n_atoms; + a_is_true; + a_seen; + a_watched; + a_form; + c_store = _; + a_proof_lvl0 = _; + } = + self + in + + let v_idx = v_count in + let v = Var.of_int_unsafe v_idx in + + Stat.incr stat_n_atoms; + + self.v_count <- 1 + v_idx; + Lit_tbl.add v_of_lit form v; + Vec.push v_level (-1); + Vec.push v_heap_idx (-1); + Vec.push v_reason None; + Vec_float.push v_weight 0.; + Bitvec.ensure_size v_seen v_idx; + Bitvec.ensure_size v_default_polarity v_idx; + Bitvec.set v_default_polarity v_idx pol; + + assert (Vec.size a_form = 2 * (v : var :> int)); + Bitvec.ensure_size a_is_true (2 * (v : var :> int)); + Bitvec.ensure_size a_seen (2 * (v : var :> int)); + Vec.push a_form form; + Vec.push a_watched (CVec.create ~cap:0 ()); + Vec.push a_form (Lit.neg form); + Vec.push a_watched (CVec.create ~cap:0 ()); + assert (Vec.get a_form (Atom.of_var v : atom :> int) == form); + + v + +(* create new variable *) +let alloc_var (self : t) ?default_pol (lit : Lit.t) : var * same_sign = + let lit, same_sign = Lit.norm_sign lit in + try Lit_tbl.find self.v_of_lit lit, same_sign + with Not_found -> + let v = alloc_var_uncached_ ?default_pol self lit in + v, same_sign + +let clear_var (self : t) (v : var) : unit = + Var.unmark self v; + Atom.unmark self (Atom.pa v); + Atom.unmark self (Atom.na v); + () + +let atom_of_var_ v same_sign : atom = + if same_sign then + Atom.pa v + else + Atom.na v + +let alloc_atom (self : t) ?default_pol lit : atom = + let var, same_sign = alloc_var self ?default_pol lit in + atom_of_var_ var same_sign + +let find_atom (self : t) lit : atom option = + let lit, same_sign = Lit.norm_sign lit in + match Lit_tbl.find self.v_of_lit lit with + | v -> Some (atom_of_var_ v same_sign) + | exception Not_found -> None diff --git a/src/sat/store.mli b/src/sat/store.mli new file mode 100644 index 00000000..f31d8399 --- /dev/null +++ b/src/sat/store.mli @@ -0,0 +1,129 @@ +open Sidekick_core +open Sigs + +type var = Base_types_.var +type atom = Base_types_.atom +type clause = Base_types_.clause + +module CVec = Base_types_.CVec + +type var_reason = Base_types_.var_reason = + | Decision + | Bcp of clause + | Bcp_lazy of clause lazy_t + +type t +type store = t + +val create : ?size:[< `Big | `Small | `Tiny > `Big ] -> stat:Stat.t -> unit -> t +val iter_vars : t -> (var -> unit) -> unit + +module Var : sig + type t = var + + val equal : t -> t -> same_sign + val compare : t -> t -> int + val hash : t -> int + val to_int : t -> int + val of_int_unsafe : int -> t + val level : store -> var -> int + val set_level : store -> var -> int -> unit + val reason : store -> var -> var_reason option + val set_reason : store -> var -> var_reason option -> unit + val weight : store -> var -> float + val set_weight : store -> var -> float -> unit + val mark : store -> var -> unit + val unmark : store -> var -> unit + val marked : store -> var -> same_sign + val set_default_pol : store -> var -> same_sign -> unit + val default_pol : store -> var -> same_sign + val heap_idx : store -> var -> int + val set_heap_idx : store -> var -> int -> unit +end + +module Atom : sig + type t = atom + + val equal : t -> t -> same_sign + val compare : t -> t -> int + val hash : t -> int + val to_int : t -> int + val of_int_unsafe : int -> t + val neg : t -> t + val sign : t -> same_sign + val of_var : var -> t + val var : t -> var + val pa : var -> t + val na : var -> t + + module AVec = Sidekick_sat__Base_types_.Atom0.AVec + module ATbl = Sidekick_sat__Base_types_.Atom0.ATbl + + val lit : store -> atom -> Lit.t + val mark : store -> atom -> unit + val unmark : store -> atom -> unit + val marked : store -> atom -> same_sign + val watched : store -> atom -> CVec.t + val is_true : store -> atom -> same_sign + val set_is_true : store -> atom -> same_sign -> unit + val is_false : store -> t -> same_sign + val has_value : store -> atom -> same_sign + val reason : store -> t -> var_reason option + val level : store -> t -> int + val marked_both : store -> atom -> same_sign + val proof_lvl0 : store -> ATbl.key -> int32 option + val set_proof_lvl0 : store -> ATbl.key -> int32 -> unit + val pp : store -> Format.formatter -> atom -> unit + val pp_a : store -> Format.formatter -> atom array -> unit + val pp_sign : t -> string + val debug_reason : 'a -> Format.formatter -> int * var_reason option -> unit + val pp_level : store -> Format.formatter -> t -> unit + val debug_value : store -> Format.formatter -> atom -> unit + val debug : store -> Format.formatter -> t -> unit + val debug_a : store -> Format.formatter -> t array -> unit +end + +module Clause : sig + type t = clause + + val equal : t -> t -> same_sign + val compare : t -> t -> int + val hash : t -> int + val to_int : t -> int + val of_int_unsafe : int -> t + + module Tbl : Hashtbl.S with type key = t + module CVec = Base_types_.CVec + + val make_a : store -> removable:same_sign -> atom array -> int32 -> t + val make_l : store -> removable:same_sign -> atom list -> int32 -> t + val n_atoms : store -> t -> int + val marked : store -> t -> same_sign + val set_marked : store -> t -> same_sign -> unit + val attached : store -> t -> same_sign + val set_attached : store -> t -> same_sign -> unit + val removable : store -> t -> same_sign + val dead : store -> t -> same_sign + val set_dead : store -> t -> same_sign -> unit + val dealloc : store -> t -> unit + val proof_step : store -> t -> int32 + val activity : store -> t -> float + val set_activity : store -> t -> float -> unit + val iter : store -> f:(atom -> unit) -> t -> unit + val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a + val for_all : store -> f:(atom -> same_sign) -> t -> same_sign + val atoms_a : store -> t -> atom array + val lits_l : store -> t -> Lit.t list + val lits_a : store -> t -> Lit.t array + val lits_iter : store -> t -> Lit.t Iter.t + val short_name : store -> t -> string + val pp : store -> Format.formatter -> t -> unit + val debug : store -> Format.formatter -> t -> unit +end + +val alloc_var_uncached_ : ?default_pol:same_sign -> t -> Lit.t -> var +val alloc_var : t -> ?default_pol:same_sign -> Lit.t -> var * same_sign +val clear_var : t -> var -> unit +val atom_of_var_ : var -> same_sign -> atom +val alloc_atom : t -> ?default_pol:same_sign -> Lit.t -> atom +val find_atom : t -> Lit.t -> atom option From 1ecb189fd5cdbe0854955a9c525c29bc55289cb7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:17:20 -0400 Subject: [PATCH 048/174] refactor: core and CC --- src/cc/CC.ml | 3 +++ src/cc/CC.mli | 16 ++++++++++++++++ src/cc/dune | 2 +- src/core-logic/t_builtins.ml | 6 ++++++ src/core-logic/t_builtins.mli | 1 + src/core/Sidekick_core.ml | 2 ++ 6 files changed, 29 insertions(+), 1 deletion(-) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index ba2214be..a9192ccf 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -969,3 +969,6 @@ module Default = struct | _ -> View.Opaque t) end) end + +let create (module A : ARG) ?stat ?size tst proof : t = + create_ ?stat ?size tst proof ~view_as_cc:A.view_as_cc diff --git a/src/cc/CC.mli b/src/cc/CC.mli index 117a56e2..9107db9e 100644 --- a/src/cc/CC.mli +++ b/src/cc/CC.mli @@ -1,3 +1,5 @@ +(** Main congruence closure type. *) + open Sidekick_core type e_node = E_node.t @@ -275,6 +277,20 @@ end module Make (_ : ARG) : BUILD module Default : BUILD +val create : + (module ARG) -> + ?stat:Stat.t -> + ?size:[ `Small | `Big ] -> + Term.store -> + Proof_trace.t -> + t +(** Create a new congruence closure. + + @param term_store used to be able to create new terms. All terms + interacting with this congruence closure must belong in this term state + as well. + *) + (**/**) module Debug_ : sig diff --git a/src/cc/dune b/src/cc/dune index 5994f7ba..cd929144 100644 --- a/src/cc/dune +++ b/src/cc/dune @@ -2,6 +2,6 @@ (name Sidekick_cc) (public_name sidekick.cc) (synopsis "main congruence closure implementation") - (private_modules types_ signature) + (private_modules signature) (libraries containers iter sidekick.sigs sidekick.core sidekick.util) (flags :standard -open Sidekick_util)) diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml index 3b83a4f7..3bc09bd0 100644 --- a/src/core-logic/t_builtins.ml +++ b/src/core-logic/t_builtins.ml @@ -39,6 +39,12 @@ let bool store = const store @@ Const.make C_bool ops ~ty:(type_ store) let true_ store = const store @@ Const.make C_true ops ~ty:(bool store) let false_ store = const store @@ Const.make C_false ops ~ty:(bool store) +let bool_val store b = + if b then + true_ store + else + false_ store + let c_eq store = let type_ = type_ store in let v = bvar_i store 0 ~ty:type_ in diff --git a/src/core-logic/t_builtins.mli b/src/core-logic/t_builtins.mli index 9f090b58..8ae490ee 100644 --- a/src/core-logic/t_builtins.mli +++ b/src/core-logic/t_builtins.mli @@ -11,6 +11,7 @@ val c_eq : store -> t val c_ite : store -> t val true_ : store -> t val false_ : store -> t +val bool_val : store -> bool -> t val eq : store -> t -> t -> t (** [eq a b] is [a = b] *) diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index 8e78ae4c..204c1174 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -32,3 +32,5 @@ module Proof_trace = Proof_trace module Proof_term = Proof_term module Subst = Sidekick_core_logic.Subst module Var = Sidekick_core_logic.Var + +exception Resource_exhausted From 83e456ef8a0d110d0c09e9e8af65fd19c54f5b00 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:17:37 -0400 Subject: [PATCH 049/174] remove sidekick_lit functor --- src/lit/Sidekick_lit.ml | 44 ----------------------------------------- src/lit/dune | 6 ------ 2 files changed, 50 deletions(-) delete mode 100644 src/lit/Sidekick_lit.ml delete mode 100644 src/lit/dune diff --git a/src/lit/Sidekick_lit.ml b/src/lit/Sidekick_lit.ml deleted file mode 100644 index 64fb360f..00000000 --- a/src/lit/Sidekick_lit.ml +++ /dev/null @@ -1,44 +0,0 @@ -(** Implementation of literals from terms *) - -module Make (T : Sidekick_core.TERM) : Sidekick_core.LIT with module T = T = -struct - module T = T - - type term = T.Term.t - type t = { lit_term: term; lit_sign: bool } - - let[@inline] neg l = { l with lit_sign = not l.lit_sign } - let[@inline] sign t = t.lit_sign - let[@inline] abs t = { t with lit_sign = true } - let[@inline] term (t : t) : term = t.lit_term - let[@inline] signed_term t = term t, sign t - let make ~sign t = { lit_sign = sign; lit_term = t } - - let atom ?(sign = true) tst (t : term) : t = - let t, sign' = T.Term.abs tst t in - let sign = - if not sign' then - not sign - else - sign - in - make ~sign t - - let equal a b = a.lit_sign = b.lit_sign && T.Term.equal a.lit_term b.lit_term - - let hash a = - let sign = a.lit_sign in - CCHash.combine3 2 (CCHash.bool sign) (T.Term.hash a.lit_term) - - let pp out l = - if l.lit_sign then - T.Term.pp out l.lit_term - else - Format.fprintf out "(@[@<1>¬@ %a@])" T.Term.pp l.lit_term - - let norm_sign l = - if l.lit_sign then - l, true - else - neg l, false -end diff --git a/src/lit/dune b/src/lit/dune deleted file mode 100644 index dbfc89b0..00000000 --- a/src/lit/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_lit) - (public_name sidekick.lit) - (synopsis "Implementation of literals for Sidekick") - (libraries containers sidekick.core sidekick.util) - (flags :standard -warn-error -a+8 -open Sidekick_util)) From 1e1b0f352d722329333f7dffc51c65730ce3af23 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:17:55 -0400 Subject: [PATCH 050/174] feat(simplify): add sidekick_simplify library --- src/simplify/dune | 6 +++ src/simplify/sidekick_simplify.ml | 80 ++++++++++++++++++++++++++++++ src/simplify/sidekick_simplify.mli | 39 +++++++++++++++ 3 files changed, 125 insertions(+) create mode 100644 src/simplify/dune create mode 100644 src/simplify/sidekick_simplify.ml create mode 100644 src/simplify/sidekick_simplify.mli diff --git a/src/simplify/dune b/src/simplify/dune new file mode 100644 index 00000000..fa4a9b50 --- /dev/null +++ b/src/simplify/dune @@ -0,0 +1,6 @@ +(library + (name Sidekick_simplify) + (public_name sidekick.simplify) + (synopsis "Simplifier") + (libraries containers iter sidekick.core sidekick.util) + (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/simplify/sidekick_simplify.ml b/src/simplify/sidekick_simplify.ml new file mode 100644 index 00000000..2daa4114 --- /dev/null +++ b/src/simplify/sidekick_simplify.ml @@ -0,0 +1,80 @@ +open Sidekick_core + +open struct + module P = Proof_trace + module Rule_ = Proof_core +end + +type t = { + tst: Term.store; + proof: Proof_trace.t; + mutable hooks: hook list; + (* store [t --> u by step_ids] in the cache. + We use a bag for the proof steps because it gives us structural + sharing of subproofs. *) + cache: (Term.t * Proof_step.id Bag.t) Term.Tbl.t; +} + +and hook = t -> Term.t -> (Term.t * Proof_step.id Iter.t) option + +let create tst ~proof : t = + { tst; proof; hooks = []; cache = Term.Tbl.create 32 } + +let[@inline] tst self = self.tst +let[@inline] proof self = self.proof +let add_hook self f = self.hooks <- f :: self.hooks +let clear self = Term.Tbl.clear self.cache + +let normalize (self : t) (t : Term.t) : (Term.t * Proof_step.id) option = + (* compute and cache normal form of [t] *) + let rec loop t : Term.t * _ Bag.t = + match Term.Tbl.find self.cache t with + | res -> res + | exception Not_found -> + let steps_u = ref Bag.empty in + let u = aux_rec ~steps:steps_u t self.hooks in + Term.Tbl.add self.cache t (u, !steps_u); + u, !steps_u + and loop_add ~steps t = + let u, pr_u = loop t in + steps := Bag.append !steps pr_u; + u + (* try each function in [hooks] successively, and rewrite subterms *) + and aux_rec ~steps t hooks : Term.t = + match hooks with + | [] -> + let u = + Term.map_shallow self.tst ~f:(fun _inb u -> loop_add ~steps u) t + in + if Term.equal t u then + t + else + loop_add ~steps u + | h :: hooks_tl -> + (match h self t with + | None -> aux_rec ~steps t hooks_tl + | Some (u, _) when Term.equal t u -> aux_rec ~steps t hooks_tl + | Some (u, pr_u) -> + let bag_u = Bag.of_iter pr_u in + steps := Bag.append !steps bag_u; + let v, pr_v = loop u in + (* fixpoint *) + steps := Bag.append !steps pr_v; + v) + in + let u, pr_u = loop t in + if Term.equal t u then + None + else ( + (* proof: [sub_proofs |- t=u] by CC + subproof *) + let step = + P.add_step self.proof + @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) + in + Some (u, step) + ) + +let normalize_t self t = + match normalize self t with + | Some (u, pr_u) -> u, Some pr_u + | None -> t, None diff --git a/src/simplify/sidekick_simplify.mli b/src/simplify/sidekick_simplify.mli new file mode 100644 index 00000000..1c3abf1a --- /dev/null +++ b/src/simplify/sidekick_simplify.mli @@ -0,0 +1,39 @@ +(** Term simplifier *) + +open Sidekick_core + +type t + +val tst : t -> Term.store + +val create : Term.store -> proof:Proof_trace.t -> t +(** Create a simplifier *) + +val clear : t -> unit +(** Reset internal cache, etc. *) + +val proof : t -> Proof_trace.t +(** Access proof *) + +type hook = t -> Term.t -> (Term.t * Proof_step.id Iter.t) option +(** Given a Term.t, try to simplify it. Return [None] if it didn't change. + + A simple example could be a hook that takes a Term.t [t], + and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, + returns [Some (const (x+y))], and [None] otherwise. + + The simplifier will take care of simplifying the resulting Term.t further, + caching (so that work is not duplicated in subterms), etc. + *) + +val add_hook : t -> hook -> unit + +val normalize : t -> Term.t -> (Term.t * Proof_step.id) option +(** Normalize a Term.t using all the hooks. This performs + a fixpoint, i.e. it only stops when no hook applies anywhere inside + the Term.t. *) + +val normalize_t : t -> Term.t -> Term.t * Proof_step.id option +(** Normalize a Term.t using all the hooks, along with a proof that the + simplification is correct. + returns [t, ø] if no simplification occurred. *) From 6e1da96e7e04a39bc8a5e8ceee600a892fad2e3c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:18:18 -0400 Subject: [PATCH 051/174] include solver directly in Sidekick_sat --- src/sat/Sidekick_sat.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/sat/Sidekick_sat.ml b/src/sat/Sidekick_sat.ml index 89987049..f5f68767 100644 --- a/src/sat/Sidekick_sat.ml +++ b/src/sat/Sidekick_sat.ml @@ -2,3 +2,4 @@ include Sigs module Solver = Solver +include Solver From 05faac97e7a02785df49867a192e11870ecd1f12 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:18:30 -0400 Subject: [PATCH 052/174] refactor(smt): remove functor, split into modules --- src/smt/dune | 2 +- src/smt/model.ml | 4 ++ src/smt/model.mli | 18 +++++++ src/smt/sigs.ml | 1 + src/smt/simplify.ml | 81 ------------------------------- src/smt/simplify.mli | 39 --------------- src/smt/solver.ml | 25 +++++----- src/smt/solver.mli | 27 ++--------- src/smt/solver_internal.ml | 97 +++++++++++++++++++++---------------- src/smt/solver_internal.mli | 30 +++++++++++- 10 files changed, 125 insertions(+), 199 deletions(-) create mode 100644 src/smt/model.mli delete mode 100644 src/smt/simplify.ml delete mode 100644 src/smt/simplify.mli diff --git a/src/smt/dune b/src/smt/dune index 0e86c9da..f6d84486 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.sat sidekick.simplify) (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/smt/model.ml b/src/smt/model.ml index 34cba314..d7f0ad6b 100644 --- a/src/smt/model.ml +++ b/src/smt/model.ml @@ -22,3 +22,7 @@ let pp out = function 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 new file mode 100644 index 00000000..bcabd13c --- /dev/null +++ b/src/smt/model.mli @@ -0,0 +1,18 @@ +(** 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/sigs.ml b/src/smt/sigs.ml index fb0ba9b6..20ee7b04 100644 --- a/src/smt/sigs.ml +++ b/src/smt/sigs.ml @@ -13,6 +13,7 @@ *) include Sidekick_core +module Simplify = Sidekick_simplify module CC = Sidekick_cc.CC module E_node = Sidekick_cc.E_node module CC_expl = Sidekick_cc.Expl diff --git a/src/smt/simplify.ml b/src/smt/simplify.ml deleted file mode 100644 index 2bbd3da8..00000000 --- a/src/smt/simplify.ml +++ /dev/null @@ -1,81 +0,0 @@ -open Sidekick_core -open Sigs - -open struct - module P = Proof_trace - module Rule_ = Proof_core -end - -type t = { - tst: term_store; - proof: proof_trace; - mutable hooks: hook list; - (* store [t --> u by step_ids] in the cache. - We use a bag for the proof steps because it gives us structural - sharing of subproofs. *) - cache: (Term.t * step_id Bag.t) Term.Tbl.t; -} - -and hook = t -> term -> (term * step_id Iter.t) option - -let create tst ~proof : t = - { tst; proof; hooks = []; cache = Term.Tbl.create 32 } - -let[@inline] tst self = self.tst -let[@inline] proof self = self.proof -let add_hook self f = self.hooks <- f :: self.hooks -let clear self = Term.Tbl.clear self.cache - -let normalize (self : t) (t : Term.t) : (Term.t * step_id) option = - (* compute and cache normal form of [t] *) - let rec loop t : Term.t * _ Bag.t = - match Term.Tbl.find self.cache t with - | res -> res - | exception Not_found -> - let steps_u = ref Bag.empty in - let u = aux_rec ~steps:steps_u t self.hooks in - Term.Tbl.add self.cache t (u, !steps_u); - u, !steps_u - and loop_add ~steps t = - let u, pr_u = loop t in - steps := Bag.append !steps pr_u; - u - (* try each function in [hooks] successively, and rewrite subterms *) - and aux_rec ~steps t hooks : Term.t = - match hooks with - | [] -> - let u = - Term.map_shallow self.tst ~f:(fun _inb u -> loop_add ~steps u) t - in - if Term.equal t u then - t - else - loop_add ~steps u - | h :: hooks_tl -> - (match h self t with - | None -> aux_rec ~steps t hooks_tl - | Some (u, _) when Term.equal t u -> aux_rec ~steps t hooks_tl - | Some (u, pr_u) -> - let bag_u = Bag.of_iter pr_u in - steps := Bag.append !steps bag_u; - let v, pr_v = loop u in - (* fixpoint *) - steps := Bag.append !steps pr_v; - v) - in - let u, pr_u = loop t in - if Term.equal t u then - None - else ( - (* proof: [sub_proofs |- t=u] by CC + subproof *) - let step = - P.add_step self.proof - @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) - in - Some (u, step) - ) - -let normalize_t self t = - match normalize self t with - | Some (u, pr_u) -> u, Some pr_u - | None -> t, None diff --git a/src/smt/simplify.mli b/src/smt/simplify.mli deleted file mode 100644 index 4ecccd29..00000000 --- a/src/smt/simplify.mli +++ /dev/null @@ -1,39 +0,0 @@ -(** Term simplifier *) - -open Sidekick_core -open Sigs - -type t - -val tst : t -> term_store - -val clear : t -> unit -(** Reset internal cache, etc. *) - -val proof : t -> proof_trace -(** Access proof *) - -type hook = t -> term -> (term * step_id Iter.t) option -(** Given a term, try to simplify it. Return [None] if it didn't change. - - A simple example could be a hook that takes a term [t], - and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, - returns [Some (const (x+y))], and [None] otherwise. - - The simplifier will take care of simplifying the resulting term further, - caching (so that work is not duplicated in subterms), etc. - *) - -val add_hook : t -> hook -> unit - -val normalize : t -> term -> (term * step_id) option -(** Normalize a term using all the hooks. This performs - a fixpoint, i.e. it only stops when no hook applies anywhere inside - the term. *) - -val normalize_t : t -> term -> term * step_id option -(** Normalize a term using all the hooks, along with a proof that the - simplification is correct. - returns [t, ø] if no simplification occurred. *) - -val create : Term.store -> proof:Proof_trace.t -> t diff --git a/src/smt/solver.ml b/src/smt/solver.ml index f4741fb8..670a5630 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -1,6 +1,7 @@ open Sigs open struct + module SI = Solver_internal module P = Proof_trace module Rule_ = Proof_core end @@ -30,7 +31,7 @@ end end) *) -module Sat_solver = Sidekick_sat.Make_cdcl_t (Solver_internal) +module Sat_solver = Sidekick_sat (** the parametrized SAT Solver *) (** {2 Result} *) @@ -100,7 +101,7 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = si; proof; last_res = None; - solver = Sat_solver.create ~proof ?size ~stat si; + solver = Sat_solver.create ~proof ?size ~stat (SI.to_sat_plugin si); stat; count_clause = Stat.mk_int stat "solver.add-clause"; count_solve = Stat.mk_int stat "solver.solve"; @@ -127,11 +128,11 @@ let reset_last_res_ self = self.last_res <- None (* preprocess clause, return new proof *) let preprocess_clause_ (self : t) (c : lit array) (pr : step_id) : lit array * step_id = - Solver_internal.preprocess_clause_iarray_ self.si c pr + Solver_internal.preprocess_clause_array self.si c pr let mk_lit_t (self : t) ?sign (t : term) : lit = let lit = Lit.atom ?sign t in - let lit, _ = Solver_internal.simplify_and_preproc_lit_ self.si lit in + let lit, _ = Solver_internal.simplify_and_preproc_lit self.si lit in lit (** {2 Main} *) @@ -171,16 +172,14 @@ let add_clause (self : t) (c : lit array) (proof : step_id) : unit = let add_clause_l self c p = add_clause self (CCArray.of_list c) p let assert_terms self c = - let c = CCList.map (fun t -> Lit.atom (tst self) t) c in + let c = CCList.map Lit.atom c in let pr_c = - P.add_step self.proof @@ A.Rule_sat.sat_input_clause (Iter.of_list c) + P.add_step self.proof @@ Proof_sat.sat_input_clause (Iter.of_list c) in add_clause_l self c pr_c let assert_term self t = assert_terms self [ t ] -exception Resource_exhausted = Sidekick_sat.Resource_exhausted - let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) ?(should_stop = fun _ _ -> false) ~assumptions (self : t) : res = Profile.with_ "smt-solver.solve" @@ fun () -> @@ -194,14 +193,14 @@ let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) if should_stop self !resource_counter then raise_notrace Resource_exhausted in - self.si.on_progress <- on_progress; + Event.on ~f:on_progress (SI.on_progress self.si); let res = match Stat.incr self.count_solve; Sat_solver.solve ~on_progress ~assumptions (solver self) with - | Sat_solver.Sat _ when not self.si.complete -> + | Sat_solver.Sat _ when not (SI.is_complete self.si) -> Log.debugf 1 (fun k -> k "(@[sidekick.smt-solver: SAT@ actual: UNKNOWN@ :reason \ @@ -212,14 +211,14 @@ let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) Log.debugf 5 (fun k -> let ppc out n = - Fmt.fprintf out "{@[class@ %a@]}" (Util.pp_iter N.pp) - (N.iter_class n) + Fmt.fprintf out "{@[class@ %a@]}" (Util.pp_iter 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 self.si.last_model with + match SI.last_model self.si with | Some m -> m | None -> assert false in diff --git a/src/smt/solver.mli b/src/smt/solver.mli index b645adb6..97628abd 100644 --- a/src/smt/solver.mli +++ b/src/smt/solver.mli @@ -14,32 +14,15 @@ type t val registry : t -> Registry.t (** A solver contains a registry so that theories can share data *) -type theory = Theory.t -type 'a theory_p = 'a Theory.p - val mk_theory : name:string -> create_and_setup:(Solver_internal.t -> 'th) -> ?push_level:('th -> unit) -> ?pop_levels:('th -> int -> unit) -> unit -> - theory + Theory.t (** Helper to create a theory. *) -(** Models - - A model can be produced when the solver is found to be in a - satisfiable state after a call to {!solve}. *) -module Model : sig - 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 -end - (* TODO *) module Unknown : sig type t @@ -65,7 +48,7 @@ val create : ?size:[ `Big | `Tiny | `Small ] -> (* TODO? ?config:Config.t -> *) proof:proof_trace -> - theories:theory list -> + theories:Theory.t list -> Term.store -> unit -> t @@ -82,15 +65,15 @@ val create : @param theories theories to load from the start. Other theories can be added using {!add_theory}. *) -val add_theory : t -> theory -> unit +val add_theory : t -> Theory.t -> unit (** Add a theory to the solver. This should be called before any call to {!solve} or to {!add_clause} and the likes (otherwise the theory will have a partial view of the problem). *) -val add_theory_p : t -> 'a theory_p -> 'a +val add_theory_p : t -> 'a Theory.p -> 'a (** Add the given theory and obtain its state *) -val add_theory_l : t -> theory list -> unit +val add_theory_l : t -> Theory.t list -> unit val mk_lit_t : t -> ?sign:bool -> term -> lit (** [mk_lit_t _ ~sign t] returns [lit'], diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index db0995e1..35d28732 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -1,7 +1,6 @@ open Sigs module Proof_rules = Sidekick_core.Proof_sat module P_core_rules = Sidekick_core.Proof_core -module N = Sidekick_cc.E_node module Ty = Term open struct @@ -46,7 +45,7 @@ type t = { cc: CC.t; (** congruence closure *) proof: proof_trace; (** proof logger *) registry: Registry.t; - mutable on_progress: unit -> unit; + on_progress: (unit, unit) Event.Emitter.t; mutable on_partial_check: (t -> theory_actions -> lit Iter.t -> unit) list; mutable on_final_check: (t -> theory_actions -> lit Iter.t -> unit) list; mutable on_th_combination: @@ -69,7 +68,10 @@ type t = { } and preprocess_hook = t -> preprocess_actions -> term -> unit -and model_ask_hook = recurse:(t -> N.t -> term) -> t -> N.t -> term option + +and model_ask_hook = + recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option + and model_completion_hook = t -> add:(term -> term -> unit) -> unit type solver = t @@ -172,8 +174,7 @@ let preprocess_term_ (self : t) (t0 : term) : unit = preproc_rec_ t0 (* simplify literal, then preprocess the result *) -let simplify_and_preproc_lit_ (self : t) (lit : Lit.t) : Lit.t * step_id option - = +let simplify_and_preproc_lit (self : t) (lit : Lit.t) : Lit.t * step_id option = let t = Lit.term lit in let sign = Lit.sign lit in let u, pr = @@ -191,7 +192,7 @@ let simplify_and_preproc_lit_ (self : t) (lit : Lit.t) : Lit.t * step_id option let push_decision (self : t) (acts : theory_actions) (lit : lit) : unit = let (module A) = acts in (* make sure the literal is preprocessed *) - let lit, _ = simplify_and_preproc_lit_ self lit in + let lit, _ = simplify_and_preproc_lit self lit in let sign = Lit.sign lit in A.add_decision_lit (Lit.abs lit) sign @@ -210,7 +211,7 @@ module Preprocess_clause (A : ARR) = struct (* simplify a literal, then preprocess it *) let[@inline] simp_lit lit = - let lit, pr = simplify_and_preproc_lit_ self lit in + let lit, pr = simplify_and_preproc_lit self lit in Option.iter (fun pr -> steps := pr :: !steps) pr; lit in @@ -233,8 +234,8 @@ end module PC_list = Preprocess_clause (CCList) module PC_arr = Preprocess_clause (CCArray) -let preprocess_clause_ = PC_list.top -let preprocess_clause_iarray_ = PC_arr.top +let preprocess_clause = PC_list.top +let preprocess_clause_array = PC_arr.top module type PERFORM_ACTS = sig type t @@ -250,7 +251,7 @@ module Perform_delayed (A : PERFORM_ACTS) = struct let act = Queue.pop self.delayed_actions in match act with | DA_add_clause { c; pr = pr_c; keep } -> - let c', pr_c' = preprocess_clause_ self c pr_c in + let c', pr_c' = preprocess_clause self c pr_c in A.add_clause self acts ~keep c' pr_c' | DA_add_lit { default_pol; lit } -> preprocess_term_ self (Lit.term lit); @@ -270,11 +271,11 @@ module Perform_delayed_th = Perform_delayed (struct end) let[@inline] add_clause_temp self _acts c (proof : step_id) : unit = - let c, proof = preprocess_clause_ self c proof in + let c, proof = preprocess_clause self c proof in delayed_add_clause self ~keep:false c proof let[@inline] add_clause_permanent self _acts c (proof : step_id) : unit = - let c, proof = preprocess_clause_ self c proof in + let c, proof = preprocess_clause self c proof in delayed_add_clause self ~keep:true c proof let[@inline] mk_lit _ ?sign t : lit = Lit.atom ?sign t @@ -284,7 +285,7 @@ let[@inline] add_lit self _acts ?default_pol lit = let add_lit_t self _acts ?sign t = let lit = Lit.atom ?sign t in - let lit, _ = simplify_and_preproc_lit_ self lit in + let lit, _ = simplify_and_preproc_lit self lit in delayed_add_lit self lit let on_final_check self f = self.on_final_check <- f :: self.on_final_check @@ -292,6 +293,7 @@ let on_final_check self f = self.on_final_check <- f :: self.on_final_check let on_partial_check self f = self.on_partial_check <- f :: self.on_partial_check +let on_progress self = Event.of_emitter self.on_progress let on_cc_new_term self f = Event.on (CC.on_new_term (cc self)) ~f let on_cc_pre_merge self f = Event.on (CC.on_pre_merge (cc self)) ~f let on_cc_post_merge self f = Event.on (CC.on_post_merge (cc self)) ~f @@ -301,11 +303,13 @@ let on_cc_is_subterm self f = Event.on (CC.on_is_subterm (cc self)) ~f let cc_add_term self t = CC.add_term (cc self) t let cc_mem_term self t = CC.mem_term (cc self) t let cc_find self n = CC.find (cc self) n +let is_complete self = self.complete +let last_model self = self.last_model let cc_are_equal self t1 t2 = let n1 = cc_add_term self t1 in let n2 = cc_add_term self t2 in - N.equal (cc_find self n1) (cc_find self n2) + E_node.equal (cc_find self n1) (cc_find self n2) let cc_resolve_expl self e : lit list * _ = let r = CC.explain_expl (cc self) e in @@ -337,19 +341,6 @@ let rec pop_lvls_ n = function r.pop_levels r.st n; pop_lvls_ n r.next -let push_level (self : t) : unit = - self.level <- 1 + self.level; - CC.push_level (cc self); - push_lvl_ self.th_states - -let pop_levels (self : t) n : unit = - self.last_model <- None; - self.level <- self.level - n; - CC.pop_levels (cc self) n; - pop_lvls_ n self.th_states - -let n_levels self = self.level - (** {2 Model construction and theory combination} *) (* make model from the congruence closure *) @@ -372,7 +363,7 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = CC.get_model_for_each_class cc (fun (_, ts, v) -> Iter.iter (fun n -> - let t = N.term n in + let t = E_node.term n in M.replace model t v) ts); *) @@ -390,20 +381,20 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = List.iter complete_with model_complete; (* compute a value for [n]. *) - let rec val_for_class (n : N.t) : term = - Log.debugf 5 (fun k -> k "val-for-term %a" N.pp n); + let rec val_for_class (n : E_node.t) : term = + Log.debugf 5 (fun k -> k "val-for-term %a" E_node.pp n); let repr = CC.find cc n in - Log.debugf 5 (fun k -> k "val-for-term.repr %a" N.pp repr); + Log.debugf 5 (fun k -> k "val-for-term.repr %a" E_node.pp repr); (* see if a value is found already (always the case if it's a boolean) *) - match M.get model (N.term repr) with + match M.get model (E_node.term repr) with | Some t_val -> Log.debugf 5 (fun k -> k "cached val is %a" Term.pp_debug t_val); t_val | None -> (* try each model hook *) let rec try_hooks_ = function - | [] -> N.term repr + | [] -> E_node.term repr | h :: hooks -> (match h ~recurse:(fun _ n -> val_for_class n) self repr with | None -> try_hooks_ hooks @@ -415,15 +406,15 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = (* FIXME: the more complete version? match (* look for a value in the model for any term in the class *) - N.iter_class repr - |> Iter.find_map (fun n -> M.get model (N.term n)) + E_node.iter_class repr + |> Iter.find_map (fun n -> M.get model (E_node.term n)) with | Some v -> v | None -> try_hooks_ model_ask_hooks *) in - M.replace model (N.term repr) t_val; + M.replace model (E_node.term repr) t_val; (* be sure to cache the value *) Log.debugf 5 (fun k -> k "val is %a" Term.pp_debug t_val); t_val @@ -433,11 +424,11 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = CC.all_classes cc (fun repr -> let t_val = val_for_class repr in (* value for this class *) - N.iter_class repr (fun u -> - let t_u = N.term u in - if (not (N.equal u repr)) && not (Term.equal t_u t_val) then + E_node.iter_class repr (fun u -> + let t_u = E_node.term u in + if (not (E_node.equal u repr)) && not (Term.equal t_u t_val) then M.replace model t_u t_val)); - Model.Map model + Model.Internal_.of_tbl model (* do theory combination using the congruence closure. Each theory can merge classes, *) @@ -557,7 +548,7 @@ let check_ ~final (self : t) (acts : sat_acts) = in let iter = iter_atoms_ acts in Log.debugf 5 (fun k -> k "(smt-solver.assume :len %d)" (Iter.length iter)); - self.on_progress (); + Event.emit self.on_progress (); assert_lits_ ~final self acts iter; Profile.exit pb @@ -569,6 +560,28 @@ let[@inline] partial_check (self : t) (acts : Sidekick_sat.acts) : unit = let[@inline] final_check (self : t) (acts : Sidekick_sat.acts) : unit = check_ ~final:true self acts +let push_level self : unit = + self.level <- 1 + self.level; + CC.push_level (cc self); + push_lvl_ self.th_states + +let pop_levels self n : unit = + self.last_model <- None; + self.level <- self.level - n; + CC.pop_levels (cc self) n; + pop_lvls_ n self.th_states + +let n_levels self = self.level + +let to_sat_plugin (self : t) : (module Sidekick_sat.PLUGIN) = + (module struct + let has_theory = true + let push_level () = push_level self + let pop_levels n = pop_levels self n + let partial_check acts = partial_check self acts + let final_check acts = final_check self acts + end) + let declare_pb_is_incomplete self = if self.complete then Log.debug 1 "(solver.declare-pb-is-incomplete)"; self.complete <- false @@ -587,7 +600,7 @@ let create (module A : ARG) ~stat ~proof (tst : Term.store) () : t = stat; simp = Simplify.create tst ~proof; last_model = None; - on_progress = (fun () -> ()); + on_progress = Event.Emitter.create (); preprocess = []; model_ask = []; model_complete = []; diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index 508df6fc..72a28d30 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -35,12 +35,14 @@ include Sidekick_sigs.BACKTRACKABLE0 with type t := t (** {3 Interface to SAT} *) -include Sidekick_sat.PLUGIN_CDCL_T with type t := t +val to_sat_plugin : t -> (module Sidekick_sat.PLUGIN) (** {3 Simplifiers} *) type simplify_hook = Simplify.hook +val simplifier : t -> Simplify.t + val add_simplifier : t -> Simplify.hook -> unit (** Add a simplifier hook for preprocessing. *) @@ -90,6 +92,12 @@ type preprocess_hook = t -> preprocess_actions -> term -> unit val on_preprocess : t -> preprocess_hook -> unit (** Add a hook that will be called when terms are preprocessed *) +val preprocess_clause : t -> lit list -> step_id -> lit list * step_id +val preprocess_clause_array : t -> lit array -> step_id -> lit array * step_id + +val simplify_and_preproc_lit : t -> lit -> lit * step_id option +(** Simplify literal then preprocess it *) + (** {3 hooks for the theory} *) val raise_conflict : t -> theory_actions -> lit list -> step_id -> 'a @@ -245,6 +253,26 @@ val on_model : ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit (** Add model production/completion hooks. *) +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 + +(** {2 Delayed actions} *) + +module type PERFORM_ACTS = sig + type t + + val add_clause : solver -> t -> keep:bool -> lit list -> step_id -> unit + val add_lit : solver -> t -> ?default_pol:bool -> lit -> unit +end + +module Perform_delayed (A : PERFORM_ACTS) : sig + val top : t -> A.t -> unit +end + val add_theory_state : st:'a -> push_level:('a -> unit) -> From df9fa1150701b92b22bad781a9b242f29f4d7158 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 21:51:46 -0400 Subject: [PATCH 053/174] refactor(th-lra): adapt to new code --- src/th-lra/dune | 7 + src/th-lra/sidekick_arith_lra.ml | 810 +++++++++++++++++++++++++++++++ 2 files changed, 817 insertions(+) create mode 100644 src/th-lra/dune create mode 100644 src/th-lra/sidekick_arith_lra.ml diff --git a/src/th-lra/dune b/src/th-lra/dune new file mode 100644 index 00000000..9b4b555e --- /dev/null +++ b/src/th-lra/dune @@ -0,0 +1,7 @@ +(library + (name sidekick_arith_lra) + (public_name sidekick.arith-lra) + (synopsis "Solver for LRA (real arithmetic)") + (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util) + (libraries containers sidekick.arith sidekick.simplex sidekick.cc + sidekick.smt-solver)) diff --git a/src/th-lra/sidekick_arith_lra.ml b/src/th-lra/sidekick_arith_lra.ml new file mode 100644 index 00000000..5c05ceff --- /dev/null +++ b/src/th-lra/sidekick_arith_lra.ml @@ -0,0 +1,810 @@ +(** Linear Rational Arithmetic *) + +(* Reference: + http://smtlib.cs.uiowa.edu/logics-all.shtml#QF_LRA *) + +open Sidekick_core +module SMT = Sidekick_smt_solver +module Predicate = Sidekick_simplex.Predicate +module Linear_expr = Sidekick_simplex.Linear_expr +module Linear_expr_intf = Sidekick_simplex.Linear_expr_intf + +module type INT = Sidekick_arith.INT +module type RATIONAL = Sidekick_arith.RATIONAL + +module S_op = Sidekick_simplex.Op + +type term = Term.t +type ty = Term.t +type pred = Linear_expr_intf.bool_op = Leq | Geq | Lt | Gt | Eq | Neq +type op = Linear_expr_intf.op = Plus | Minus + +type ('num, 'a) lra_view = + | LRA_pred of pred * 'a * 'a + | LRA_op of op * 'a * 'a + | LRA_mult of 'num * 'a + | LRA_const of 'num + | LRA_other of 'a + +let map_view f (l : _ lra_view) : _ lra_view = + match l with + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (n, f a) + | LRA_const q -> LRA_const q + | LRA_other x -> LRA_other (f x) + +module type ARG = sig + module Z : INT + module Q : RATIONAL with type bigint = Z.t + + val view_as_lra : Term.t -> (Q.t, Term.t) lra_view + (** Project the Term.t into the theory view *) + + val mk_lra : Term.store -> (Q.t, Term.t) lra_view -> Term.t + (** Make a Term.t from the given theory view *) + + val ty_lra : Term.store -> ty + + val has_ty_real : Term.t -> bool + (** Does this term have the type [Real] *) + + val lemma_lra : Lit.t Iter.t -> Proof_term.t + + module Gensym : sig + type t + + val create : Term.store -> t + val tst : t -> Term.store + val copy : t -> t + + val fresh_term : t -> pre:string -> ty -> term + (** Make a fresh term of the given type *) + end +end + +module type S = sig + module A : ARG + + (* + module SimpVar : Sidekick_simplex.VAR with type lit = A.Lit.t + module LE_ : Linear_expr_intf.S with module Var = SimpVar + module LE = LE_.Expr + *) + + module SimpSolver : Sidekick_simplex.S + (** Simplexe *) + + type state + + val create : ?stat:Stat.t -> SMT.Solver_internal.t -> state + + (* TODO: be able to declare some variables as ints *) + + (* + val simplex : state -> Simplex.t + *) + + val k_state : state SMT.Registry.key + (** Key to access the state from outside, + available when the theory has been setup *) + + val theory : SMT.Theory.t +end + +module Make (A : ARG) = (* : S with module A = A *) struct + module A = A + module SI = SMT.Solver_internal + open Sidekick_cc + + open struct + module Pr = Proof_trace + end + + module Tag = struct + type t = Lit of Lit.t | CC_eq of E_node.t * E_node.t + + let pp out = function + | Lit l -> Fmt.fprintf out "(@[lit %a@])" Lit.pp l + | CC_eq (n1, n2) -> + Fmt.fprintf out "(@[cc-eq@ %a@ %a@])" E_node.pp n1 E_node.pp n2 + + let to_lits si = function + | Lit l -> [ l ] + | CC_eq (n1, n2) -> + let r = CC.explain_eq (SI.cc si) n1 n2 in + (* FIXME + assert (not (SI.CC.Resolved_expl.is_semantic r)); + *) + r.lits + end + + module SimpVar : Linear_expr.VAR with type t = Term.t and type lit = Tag.t = + struct + type t = Term.t + + let pp = Term.pp_debug + let compare = Term.compare + + type lit = Tag.t + + let pp_lit = Tag.pp + + let not_lit = function + | Tag.Lit l -> Some (Tag.Lit (Lit.neg l)) + | _ -> None + end + + module LE_ = Linear_expr.Make (A.Q) (SimpVar) + module LE = LE_.Expr + + module SimpSolver = Sidekick_simplex.Make (struct + module Z = A.Z + module Q = A.Q + module Var = SimpVar + + let mk_lit _ _ _ = assert false + end) + + module Subst = SimpSolver.Subst + module Comb_map = CCMap.Make (LE_.Comb) + + (* turn the term into a linear expression. Apply [f] on leaves. *) + let rec as_linexp (t : Term.t) : LE.t = + let open LE.Infix in + match A.view_as_lra t with + | LRA_other _ -> LE.monomial1 t + | LRA_pred _ -> + Error.errorf "type error: in linexp, LRA predicate %a" Term.pp_debug t + | LRA_op (op, t1, t2) -> + let t1 = as_linexp t1 in + let t2 = as_linexp t2 in + (match op with + | Plus -> t1 + t2 + | Minus -> t1 - t2) + | LRA_mult (n, x) -> + let t = as_linexp x in + LE.(n * t) + | LRA_const q -> LE.of_const q + + (* monoid to track linear expressions in congruence classes, to clash on merge *) + module Monoid_exprs = struct + let name = "lra.const" + + type single = { le: LE.t; n: E_node.t } + type t = single list + + let pp_single out { le = _; n } = E_node.pp out n + + let pp out self = + match self with + | [] -> () + | [ x ] -> pp_single out x + | _ -> Fmt.fprintf out "(@[exprs@ %a@])" (Util.pp_list pp_single) self + + let of_term _cc n t = + match A.view_as_lra t with + | LRA_const _ | LRA_op _ | LRA_mult _ -> + let le = as_linexp t in + Some [ { n; le } ], [] + | LRA_other _ | LRA_pred _ -> None, [] + + exception Confl of Expl.t + + (* merge lists. If two linear expressions equal up to a constant are + merged, conflict. *) + let merge _cc n1 l1 n2 l2 expl_12 : _ result = + try + let i = Iter.(product (of_list l1) (of_list l2)) in + i (fun (s1, s2) -> + let le = LE.(s1.le - s2.le) in + if LE.is_const le && not (LE.is_zero le) then ( + (* conflict: [le+c = le + d] is impossible *) + let expl = + let open Expl in + mk_list [ mk_merge s1.n n1; mk_merge s2.n n2; expl_12 ] + in + raise (Confl expl) + )); + Ok (List.rev_append l1 l2, []) + with Confl expl -> Error (CC.Handler_action.Conflict expl) + end + + module ST_exprs = Sidekick_cc.Plugin.Make (Monoid_exprs) + + type state = { + tst: Term.store; + proof: Proof_trace.t; + gensym: A.Gensym.t; + in_model: unit Term.Tbl.t; (* terms to add to model *) + encoded_eqs: unit Term.Tbl.t; + (* [a=b] gets clause [a = b <=> (a >= b /\ a <= b)] *) + needs_th_combination: unit Term.Tbl.t; + (* terms that require theory combination *) + simp_preds: (Term.t * S_op.t * A.Q.t) Term.Tbl.t; + (* term -> its simplex meaning *) + simp_defined: LE.t Term.Tbl.t; + (* (rational) terms that are equal to a linexp *) + st_exprs: ST_exprs.t; + mutable encoded_le: Term.t Comb_map.t; (* [le] -> var encoding [le] *) + simplex: SimpSolver.t; + mutable last_res: SimpSolver.result option; + } + + let create ?(stat = Stat.create ()) (si : SI.t) : state = + let proof = SI.proof si in + let tst = SI.tst si in + { + tst; + proof; + in_model = Term.Tbl.create 8; + st_exprs = ST_exprs.create_and_setup (SI.cc si); + gensym = A.Gensym.create tst; + simp_preds = Term.Tbl.create 32; + simp_defined = Term.Tbl.create 16; + encoded_eqs = Term.Tbl.create 8; + needs_th_combination = Term.Tbl.create 8; + encoded_le = Comb_map.empty; + simplex = SimpSolver.create ~stat (); + last_res = None; + } + + let[@inline] reset_res_ (self : state) : unit = self.last_res <- None + let[@inline] n_levels self : int = ST_exprs.n_levels self.st_exprs + + let push_level self = + ST_exprs.push_level self.st_exprs; + SimpSolver.push_level self.simplex; + () + + let pop_levels self n = + reset_res_ self; + ST_exprs.pop_levels self.st_exprs n; + SimpSolver.pop_levels self.simplex n; + () + + let fresh_term self ~pre ty = A.Gensym.fresh_term self.gensym ~pre ty + + let fresh_lit (self : state) ~mk_lit ~pre : Lit.t = + let t = fresh_term ~pre self (Term.bool self.tst) in + mk_lit t + + let pp_pred_def out (p, l1, l2) : unit = + Fmt.fprintf out "(@[%a@ :l1 %a@ :l2 %a@])" Predicate.pp p LE.pp l1 LE.pp l2 + + let[@inline] t_const self n : Term.t = A.mk_lra self.tst (LRA_const n) + let[@inline] t_zero self : Term.t = t_const self A.Q.zero + + let[@inline] is_const_ t = + match A.view_as_lra t with + | LRA_const _ -> true + | _ -> false + + let[@inline] as_const_ t = + match A.view_as_lra t with + | LRA_const n -> Some n + | _ -> None + + let[@inline] is_zero t = + match A.view_as_lra t with + | LRA_const n -> A.Q.(n = zero) + | _ -> false + + let t_of_comb (self : state) (comb : LE_.Comb.t) ~(init : Term.t) : Term.t = + let[@inline] ( + ) a b = A.mk_lra self.tst (LRA_op (Plus, a, b)) in + let[@inline] ( * ) a b = A.mk_lra self.tst (LRA_mult (a, b)) in + + let cur = ref init in + LE_.Comb.iter + (fun t c -> + let tc = + if A.Q.(c = of_int 1) then + t + else + c * t + in + cur := + if is_zero !cur then + tc + else + !cur + tc) + comb; + !cur + + (* encode back into a term *) + let t_of_linexp (self : state) (le : LE.t) : Term.t = + let comb = LE.comb le in + let const = LE.const le in + t_of_comb self comb ~init:(A.mk_lra self.tst (LRA_const const)) + + (* return a variable that is equal to [le_comb] in the simplex. *) + let var_encoding_comb ~pre self (le_comb : LE_.Comb.t) : Term.t = + assert (not (LE_.Comb.is_empty le_comb)); + match LE_.Comb.as_singleton le_comb with + | Some (c, x) when A.Q.(c = one) -> x (* trivial linexp *) + | _ -> + (match Comb_map.find le_comb self.encoded_le with + | x -> x (* already encoded that *) + | exception Not_found -> + (* new variable to represent [le_comb] *) + let proxy = fresh_term self ~pre (A.ty_lra self.tst) in + (* TODO: define proxy *) + self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; + Log.debugf 50 (fun k -> + k "(@[lra.encode-linexp@ `@[%a@]`@ :into-var %a@])" LE_.Comb.pp + le_comb Term.pp_debug proxy); + + LE_.Comb.iter (fun v _ -> SimpSolver.add_var self.simplex v) le_comb; + SimpSolver.define self.simplex proxy (LE_.Comb.to_list le_comb); + proxy) + + let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = + let pr = Pr.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in + let pr = + match using with + | None -> pr + | Some using -> + Pr.add_step PA.proof + @@ Proof_core.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using + in + PA.add_clause lits pr + + let s_op_of_pred pred : S_op.t = + match pred with + | Eq | Neq -> assert false (* unreachable *) + | Leq -> S_op.Leq + | Lt -> S_op.Lt + | Geq -> S_op.Geq + | Gt -> S_op.Gt + + (* TODO: refactor that and {!var_encoding_comb} *) + (* turn a linear expression into a single constant and a coeff. + This might define a side variable in the simplex. *) + let le_comb_to_singleton_ (self : state) (le_comb : LE_.Comb.t) : + Term.t * A.Q.t = + match LE_.Comb.as_singleton le_comb with + | Some (coeff, v) -> v, coeff + | None -> + (* non trivial linexp, give it a fresh name in the simplex *) + (match Comb_map.get le_comb self.encoded_le with + | Some x -> x, A.Q.one (* already encoded that *) + | None -> + let proxy = fresh_term self ~pre:"_le_comb" (A.ty_lra self.tst) in + + self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; + LE_.Comb.iter (fun v _ -> SimpSolver.add_var self.simplex v) le_comb; + SimpSolver.define self.simplex proxy (LE_.Comb.to_list le_comb); + + Log.debugf 50 (fun k -> + k "(@[lra.encode-linexp.to-term@ `@[%a@]`@ :new-t %a@])" LE_.Comb.pp + le_comb Term.pp_debug proxy); + + proxy, A.Q.one) + + (* look for subterms of type Real, for they will need theory combination *) + let on_subterm (self : state) (t : Term.t) : unit = + Log.debugf 50 (fun k -> k "(@[lra.cc-on-subterm@ %a@])" Term.pp_debug t); + match A.view_as_lra t with + | LRA_other _ when not (A.has_ty_real t) -> () + | LRA_pred _ | LRA_const _ -> () + | LRA_op _ | LRA_other _ | LRA_mult _ -> + if not (Term.Tbl.mem self.needs_th_combination t) then ( + Log.debugf 5 (fun k -> + k "(@[lra.needs-th-combination@ %a@])" Term.pp_debug t); + Term.Tbl.add self.needs_th_combination t () + ) + + (* preprocess linear expressions away *) + let preproc_lra (self : state) si (module PA : SI.PREPROCESS_ACTS) + (t : Term.t) : unit = + Log.debugf 50 (fun k -> k "(@[lra.preprocess@ %a@])" Term.pp_debug t); + let tst = SI.tst si in + + (* tell the CC this term exists *) + let declare_term_to_cc ~sub t = + Log.debugf 50 (fun k -> + k "(@[lra.declare-term-to-cc@ %a@])" Term.pp_debug t); + ignore (CC.add_term (SI.cc si) t : E_node.t); + if sub then on_subterm self t + in + + match A.view_as_lra t with + | _ when Term.Tbl.mem self.simp_preds t -> + () (* already turned into a simplex predicate *) + | LRA_pred (((Eq | Neq) as pred), t1, t2) when is_const_ t1 && is_const_ t2 + -> + (* comparison of constants: can decide right now *) + (match A.view_as_lra t1, A.view_as_lra t2 with + | LRA_const n1, LRA_const n2 -> + let is_eq = pred = Eq in + let t_is_true = is_eq = A.Q.equal n1 n2 in + let lit = PA.mk_lit ~sign:t_is_true t in + add_clause_lra_ (module PA) [ lit ] + | _ -> assert false) + | LRA_pred ((Eq | Neq), t1, t2) -> + (* equality: just punt to [t1 = t2 <=> (t1 <= t2 /\ t1 >= t2)] *) + let _, t = Term.abs t in + if not (Term.Tbl.mem self.encoded_eqs t) then ( + let u1 = A.mk_lra tst (LRA_pred (Leq, t1, t2)) in + let u2 = A.mk_lra tst (LRA_pred (Geq, t1, t2)) in + + Term.Tbl.add self.encoded_eqs t (); + + (* encode [t <=> (u1 /\ u2)] *) + let lit_t = PA.mk_lit t in + let lit_u1 = PA.mk_lit u1 in + let lit_u2 = PA.mk_lit u2 in + add_clause_lra_ (module PA) [ Lit.neg lit_t; lit_u1 ]; + add_clause_lra_ (module PA) [ Lit.neg lit_t; lit_u2 ]; + add_clause_lra_ (module PA) [ Lit.neg lit_u1; Lit.neg lit_u2; lit_t ] + ) + | LRA_pred (pred, t1, t2) -> + let l1 = as_linexp t1 in + let l2 = as_linexp t2 in + let le = LE.(l1 - l2) in + let le_comb, le_const = LE.comb le, LE.const le in + let le_const = A.Q.neg le_const in + let op = s_op_of_pred pred in + + (* now we have [le_comb op le_const] *) + + (* obtain a single variable for the linear combination *) + let v, c_v = le_comb_to_singleton_ self le_comb in + declare_term_to_cc ~sub:false v; + LE_.Comb.iter (fun v _ -> declare_term_to_cc ~sub:true v) le_comb; + + (* turn into simplex constraint. For example, + [c . v <= const] becomes a direct simplex constraint [v <= const/c] + (beware the sign) *) + + (* make sure to swap sides if multiplying with a negative coeff *) + let q = A.Q.(le_const / c_v) in + let op = + if A.Q.(c_v < zero) then + S_op.neg_sign op + else + op + in + + let lit = PA.mk_lit t in + let constr = SimpSolver.Constraint.mk v op q in + SimpSolver.declare_bound self.simplex constr (Tag.Lit lit); + Term.Tbl.add self.simp_preds t (v, op, q); + + Log.debugf 50 (fun k -> + k "(@[lra.preproc@ :t %a@ :to-constr %a@])" Term.pp_debug t + SimpSolver.Constraint.pp constr) + | LRA_op _ | LRA_mult _ -> + if not (Term.Tbl.mem self.simp_defined t) then ( + (* we define these terms so their value in the model make sense *) + let le = as_linexp t in + Term.Tbl.add self.simp_defined t le + ) + | LRA_const _n -> () + | LRA_other t when A.has_ty_real t -> () + | LRA_other _ -> () + + let simplify (self : state) (_recurse : _) (t : Term.t) : + (Term.t * Proof_step.id Iter.t) option = + let proof_eq t u = + Pr.add_step self.proof + @@ A.lemma_lra (Iter.return (Lit.atom (Term.eq self.tst t u))) + in + let proof_bool t ~sign:b = + let lit = Lit.atom ~sign:b t in + Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) + in + + match A.view_as_lra t with + | LRA_op _ | LRA_mult _ -> + let le = as_linexp t in + if LE.is_const le then ( + let c = LE.const le in + let u = A.mk_lra self.tst (LRA_const c) in + let pr = proof_eq t u in + Some (u, Iter.return pr) + ) else ( + let u = t_of_linexp self le in + if t != u then ( + let pr = proof_eq t u in + Some (u, Iter.return pr) + ) else + None + ) + | LRA_pred ((Eq | Neq), _, _) -> + (* never change equalities, it can affect theory combination *) + None + | LRA_pred (pred, l1, l2) -> + let le = LE.(as_linexp l1 - as_linexp l2) in + + if LE.is_const le then ( + let c = LE.const le in + let is_true = + match pred with + | Leq -> A.Q.(c <= zero) + | Geq -> A.Q.(c >= zero) + | Lt -> A.Q.(c < zero) + | Gt -> A.Q.(c > zero) + | Eq -> A.Q.(c = zero) + | Neq -> A.Q.(c <> zero) + in + let u = Term.bool_val self.tst is_true in + let pr = proof_bool t ~sign:is_true in + Some (u, Iter.return pr) + ) else ( + (* le <= const *) + let u = + A.mk_lra self.tst + (LRA_pred + ( pred, + t_of_comb self (LE.comb le) ~init:(t_zero self), + t_const self (A.Q.neg @@ LE.const le) )) + in + + if t != u then ( + let pr = proof_eq t u in + Some (u, Iter.return pr) + ) else + None + ) + | _ -> None + + (* raise conflict from certificate *) + let fail_with_cert si acts cert : 'a = + Profile.with1 "lra.simplex.check-cert" SimpSolver._check_cert cert; + let confl = + SimpSolver.Unsat_cert.lits cert + |> CCList.flat_map (Tag.to_lits si) + |> List.rev_map Lit.neg + in + let pr = Pr.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) in + SI.raise_conflict si acts confl pr + + let on_propagate_ si acts lit ~reason = + match lit with + | Tag.Lit lit -> + (* TODO: more detailed proof certificate *) + SI.propagate si acts lit ~reason:(fun () -> + let lits = CCList.flat_map (Tag.to_lits si) reason in + let pr = + Pr.add_step (SI.proof si) + @@ A.lemma_lra Iter.(cons lit (of_list lits)) + in + CCList.flat_map (Tag.to_lits si) reason, pr) + | _ -> () + + (** Check satisfiability of simplex, and sets [self.last_res] *) + let check_simplex_ self si acts : SimpSolver.Subst.t = + Log.debugf 5 (fun k -> + k "(@[lra.check-simplex@ :n-vars %d :n-rows %d@])" + (SimpSolver.n_vars self.simplex) + (SimpSolver.n_rows self.simplex)); + let res = + Profile.with_ "lra.simplex.solve" @@ fun () -> + SimpSolver.check self.simplex ~on_propagate:(on_propagate_ si acts) + in + Log.debug 5 "(lra.check-simplex.done)"; + self.last_res <- Some res; + match res with + | SimpSolver.Sat m -> m + | SimpSolver.Unsat cert -> + Log.debugf 10 (fun k -> + k "(@[lra.check.unsat@ :cert %a@])" SimpSolver.Unsat_cert.pp cert); + fail_with_cert si acts cert + + (* TODO: trivial propagations *) + + let add_local_eq_t (self : state) si acts t1 t2 ~tag : unit = + Log.debugf 20 (fun k -> + k "(@[lra.add-local-eq@ %a@ %a@])" Term.pp_debug t1 Term.pp_debug t2); + reset_res_ self; + let t1, t2 = + if Term.compare t1 t2 > 0 then + t2, t1 + else + t1, t2 + in + + let le = LE.(as_linexp t1 - as_linexp t2) in + let le_comb, le_const = LE.comb le, LE.const le in + let le_const = A.Q.neg le_const in + + if LE_.Comb.is_empty le_comb then ( + if A.Q.(le_const <> zero) then ( + (* [c=0] when [c] is not 0 *) + let lit = Lit.atom ~sign:false @@ Term.eq self.tst t1 t2 in + let pr = Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) in + SI.add_clause_permanent si acts [ lit ] pr + ) + ) else ( + let v = var_encoding_comb ~pre:"le_local_eq" self le_comb in + try + let c1 = SimpSolver.Constraint.geq v le_const in + SimpSolver.add_constraint self.simplex c1 tag + ~on_propagate:(on_propagate_ si acts); + let c2 = SimpSolver.Constraint.leq v le_const in + SimpSolver.add_constraint self.simplex c2 tag + ~on_propagate:(on_propagate_ si acts) + with SimpSolver.E_unsat cert -> fail_with_cert si acts cert + ) + + let add_local_eq (self : state) si acts n1 n2 : unit = + let t1 = E_node.term n1 in + let t2 = E_node.term n2 in + add_local_eq_t self si acts t1 t2 ~tag:(Tag.CC_eq (n1, n2)) + + (* evaluate a term directly, as a variable *) + let eval_in_subst_ subst t = + match A.view_as_lra t with + | LRA_const n -> n + | _ -> Subst.eval subst t |> Option.value ~default:A.Q.zero + + (* evaluate a linear expression *) + let eval_le_in_subst_ subst (le : LE.t) = LE.eval (eval_in_subst_ subst) le + + (* FIXME: rename, this is more "provide_model_to_cc" *) + let do_th_combination (self : state) _si _acts : _ Iter.t = + Log.debug 1 "(lra.do-th-combinations)"; + let model = + match self.last_res with + | Some (SimpSolver.Sat m) -> m + | _ -> assert false + in + + let vals = Subst.to_iter model |> Term.Tbl.of_iter in + + (* also include terms that occur under function symbols, if they're + not in the model already *) + Term.Tbl.iter + (fun t () -> + if not (Term.Tbl.mem vals t) then ( + let v = eval_in_subst_ model t in + Term.Tbl.add vals t v + )) + self.needs_th_combination; + + (* also consider subterms that are linear expressions, + and evaluate them using the value of each variable + in that linear expression. For example a term [a + 2b] + is evaluated as [eval(a) + 2 × eval(b)]. *) + Term.Tbl.iter + (fun t le -> + if not (Term.Tbl.mem vals t) then ( + let v = eval_le_in_subst_ model le in + Term.Tbl.add vals t v + )) + self.simp_defined; + + (* return whole model *) + Term.Tbl.to_iter vals |> Iter.map (fun (t, v) -> t, t_const self v) + + (* partial checks is where we add literals from the trail to the + simplex. *) + let partial_check_ self si acts trail : unit = + Profile.with_ "lra.partial-check" @@ fun () -> + reset_res_ self; + let changed = ref false in + + let examine_lit lit = + let sign = Lit.sign lit in + let lit_t = Lit.term lit in + match Term.Tbl.get self.simp_preds lit_t, A.view_as_lra lit_t with + | Some (v, op, q), _ -> + Log.debugf 50 (fun k -> + k "(@[lra.partial-check.add@ :lit %a@ :lit-t %a@])" Lit.pp lit + Term.pp_debug lit_t); + + (* need to account for the literal's sign *) + let op = + if sign then + op + else + S_op.not_ op + in + + (* assert new constraint to Simplex *) + let constr = SimpSolver.Constraint.mk v op q in + Log.debugf 10 (fun k -> + k "(@[lra.partial-check.assert@ %a@])" SimpSolver.Constraint.pp + constr); + changed := true; + (try + SimpSolver.add_var self.simplex v; + SimpSolver.add_constraint self.simplex constr (Tag.Lit lit) + ~on_propagate:(on_propagate_ si acts) + with SimpSolver.E_unsat cert -> + Log.debugf 10 (fun k -> + k "(@[lra.partial-check.unsat@ :cert %a@])" + SimpSolver.Unsat_cert.pp cert); + fail_with_cert si acts cert) + | None, LRA_pred (Eq, t1, t2) when sign -> + add_local_eq_t self si acts t1 t2 ~tag:(Tag.Lit lit) + | None, LRA_pred (Neq, t1, t2) when not sign -> + add_local_eq_t self si acts t1 t2 ~tag:(Tag.Lit lit) + | None, _ -> () + in + + Iter.iter examine_lit trail; + + (* incremental check *) + if !changed then ignore (check_simplex_ self si acts : SimpSolver.Subst.t); + () + + let final_check_ (self : state) si (acts : SI.theory_actions) + (_trail : _ Iter.t) : unit = + Log.debug 5 "(th-lra.final-check)"; + Profile.with_ "lra.final-check" @@ fun () -> + reset_res_ self; + + (* add equalities between linear-expressions merged in the congruence closure *) + ST_exprs.iter_all self.st_exprs (fun (_, l) -> + Iter.diagonal_l l (fun (s1, s2) -> add_local_eq self si acts s1.n s2.n)); + + (* TODO: jiggle model to reduce the number of variables that + have the same value *) + let model = check_simplex_ self si acts in + Log.debugf 20 (fun k -> k "(@[lra.model@ %a@])" SimpSolver.Subst.pp model); + Log.debug 5 "(lra: solver returns SAT)"; + () + + (* help generating model *) + let model_ask_ (self : state) ~recurse:_ _si n : _ option = + let t = E_node.term n in + match self.last_res with + | Some (SimpSolver.Sat m) -> + Log.debugf 50 (fun k -> k "(@[lra.model-ask@ %a@])" Term.pp_debug t); + (match A.view_as_lra t with + | LRA_const n -> Some n (* always eval constants to themselves *) + | _ -> SimpSolver.V_map.get t m) + |> Option.map (t_const self) + | _ -> None + + (* help generating model *) + let model_complete_ (self : state) _si ~add : unit = + Log.debugf 30 (fun k -> k "(lra.model-complete)"); + match self.last_res with + | Some (SimpSolver.Sat m) when Term.Tbl.length self.in_model > 0 -> + Log.debugf 50 (fun k -> + k "(@[lra.in_model@ %a@])" + (Util.pp_iter Term.pp_debug) + (Term.Tbl.keys self.in_model)); + + let add_t t () = + match SimpSolver.V_map.get t m with + | None -> () + | Some u -> add t (t_const self u) + in + Term.Tbl.iter add_t self.in_model + | _ -> () + + let k_state = SMT.Registry.create_key () + + let create_and_setup si = + Log.debug 2 "(th-lra.setup)"; + let stat = SI.stats si in + let st = create ~stat si in + SMT.Registry.set (SI.registry si) k_state st; + SI.add_simplifier si (simplify st); + SI.on_preprocess si (preproc_lra st); + SI.on_final_check si (final_check_ st); + SI.on_partial_check si (partial_check_ st); + SI.on_model si ~ask:(model_ask_ st) ~complete:(model_complete_ st); + SI.on_cc_is_subterm si (fun (_, _, t) -> + on_subterm st t; + []); + SI.on_cc_pre_merge si (fun (_cc, n1, n2, expl) -> + match as_const_ (E_node.term n1), as_const_ (E_node.term n2) with + | Some q1, Some q2 when A.Q.(q1 <> q2) -> + (* classes with incompatible constants *) + Log.debugf 30 (fun k -> + k "(@[lra.merge-incompatible-consts@ %a@ %a@])" E_node.pp n1 + E_node.pp n2); + Error (CC.Handler_action.Conflict expl) + | _ -> Ok []); + SI.on_th_combination si (do_th_combination st); + st + + let theory = + SMT.Solver.mk_theory ~name:"th-lra" ~create_and_setup ~push_level + ~pop_levels () +end From 0d0751b7d2631b51ec9128553a5075bff6dd09dc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:01:29 -0400 Subject: [PATCH 054/174] refactor(theories): remove functors --- src/th-bool-static/Sidekick_th_bool_static.ml | 182 ++------- .../Sidekick_th_bool_static.mli | 11 + src/th-bool-static/dune | 3 +- src/th-bool-static/intf.ml | 65 ++++ src/th-cstor/Sidekick_th_cstor.ml | 57 ++- src/th-cstor/dune | 3 +- src/th-data/Sidekick_th_data.ml | 358 +++++++++--------- src/th-data/Sidekick_th_data.mli | 9 +- src/th-data/dune | 5 +- src/th-data/th_intf.ml | 81 ++-- src/th-lra/intf.ml | 59 +++ src/th-lra/sidekick_arith_lra.ml | 171 +++------ src/th-lra/sidekick_arith_lra.mli | 26 ++ 13 files changed, 502 insertions(+), 528 deletions(-) create mode 100644 src/th-bool-static/Sidekick_th_bool_static.mli create mode 100644 src/th-bool-static/intf.ml create mode 100644 src/th-lra/intf.ml create mode 100644 src/th-lra/sidekick_arith_lra.mli diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index b986cc83..f18edbfd 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -1,146 +1,43 @@ -(** Theory of boolean formulas. +open Sidekick_core +module Intf = Intf +open Intf +module SI = SMT.Solver_internal +module T = Term - This handles formulas containing "and", "or", "=>", "if-then-else", etc. - *) +module type ARG = Intf.ARG -open Sidekick_sigs_smt +module Make (A : ARG) : sig + val theory : SMT.theory +end = struct + type state = { tst: T.store; gensym: A.Gensym.t } -(** Boolean-oriented view of terms *) -type ('a, 'args) bool_view = - | B_bool of bool - | B_not of 'a - | B_and of 'args - | B_or of 'args - | B_imply of 'args * 'a - | B_equiv of 'a * 'a - | B_xor of 'a * 'a - | B_eq of 'a * 'a - | B_neq of 'a * 'a - | B_ite of 'a * 'a * 'a - | B_opaque_bool of 'a (* do not enter *) - | B_atom of 'a - -module type PROOF_RULES = sig - type rule - type term - type lit - - val lemma_bool_tauto : lit Iter.t -> rule - (** Boolean tautology lemma (clause) *) - - val lemma_bool_c : string -> term list -> rule - (** Basic boolean logic lemma for a clause [|- c]. - [proof_bool_c b name cs] is the rule designated by [name]. *) - - val lemma_bool_equiv : term -> term -> rule - (** Boolean tautology lemma (equivalence) *) - - val lemma_ite_true : ite:term -> rule - (** lemma [a ==> ite a b c = b] *) - - val lemma_ite_false : ite:term -> rule - (** lemma [¬a ==> ite a b c = c] *) -end - -(** Argument to the theory *) -module type ARG = sig - module S : SOLVER - - type term = S.T.Term.t - - val view_as_bool : term -> (term, term Iter.t) bool_view - (** Project the term into the boolean view. *) - - val mk_bool : S.T.Term.store -> (term, term array) bool_view -> term - (** Make a term from the given boolean view. *) - - module P : - PROOF_RULES - with type rule := S.Proof_trace.A.rule - and type lit := S.Lit.t - and type term := S.T.Term.t - - (** Fresh symbol generator. - - The theory needs to be able to create new terms with fresh names, - to be used as placeholders for complex formulas during Tseitin - encoding. *) - module Gensym : sig - type t - - val create : S.T.Term.store -> t - (** New (stateful) generator instance. *) - - val fresh_term : t -> pre:string -> S.T.Ty.t -> term - (** Make a fresh term of the given type *) - end -end - -(** Signature *) -module type S = sig - module A : ARG - - type state - - val create : A.S.T.Term.store -> A.S.T.Ty.store -> state - - val simplify : state -> A.S.Solver_internal.simplify_hook - (** Simplify given term *) - - val cnf : state -> A.S.Solver_internal.preprocess_hook - (** preprocesses formulas by giving them names and - adding clauses to equate the name with the boolean formula. *) - - val theory : A.S.theory - (** A theory that can be added to the solver {!A.S}. - - This theory does most of its work during preprocessing, - turning boolean formulas into SAT clauses via - the {{: https://en.wikipedia.org/wiki/Tseytin_transformation} - Tseitin encoding} . *) -end - -module Make (A : ARG) : S with module A = A = struct - module A = A - module Ty = A.S.T.Ty - module T = A.S.T.Term - module Lit = A.S.Solver_internal.Lit - module SI = A.S.Solver_internal - - (* utils *) - open struct - module Pr = A.S.Proof_trace - end - - type state = { tst: T.store; ty_st: Ty.store; gensym: A.Gensym.t } - - let create tst ty_st : state = { tst; ty_st; gensym = A.Gensym.create tst } + let create tst : state = { tst; gensym = A.Gensym.create tst } let[@inline] not_ tst t = A.mk_bool tst (B_not t) let[@inline] eq tst a b = A.mk_bool tst (B_eq (a, b)) let is_true t = - match T.as_bool t with + match T.as_bool_val t with | Some true -> true | _ -> false let is_false t = - match T.as_bool t with + match T.as_bool_val t with | Some false -> true | _ -> false - let simplify (self : state) (simp : SI.Simplify.t) (t : T.t) : - (T.t * SI.step_id Iter.t) option = + let simplify (self : state) (simp : Simplify.t) (t : T.t) : + (T.t * Proof_step.id Iter.t) option = let tst = self.tst in - let proof = SI.Simplify.proof simp in + let proof = Simplify.proof simp in let steps = ref [] in let add_step_ s = steps := s :: !steps in - let mk_step_ r = Pr.add_step proof r in + let mk_step_ r = Proof_trace.add_step proof r in let add_step_eq a b ~using ~c0 : unit = add_step_ @@ mk_step_ - @@ SI.P_core_rules.lemma_rw_clause c0 ~using - ~res:(Iter.return (Lit.atom tst (A.mk_bool tst (B_eq (a, b))))) + @@ Proof_core.lemma_rw_clause c0 ~using + ~res:(Iter.return (Lit.atom (A.mk_bool tst (B_eq (a, b))))) in let[@inline] ret u = Some (u, Iter.of_list !steps) in @@ -152,35 +49,35 @@ module Make (A : ARG) : S with module A = A = struct match A.view_as_bool t with | B_bool _ -> None - | B_not u when is_true u -> ret_bequiv t (T.bool tst false) - | B_not u when is_false u -> ret_bequiv t (T.bool tst true) + | B_not u when is_true u -> ret_bequiv t (T.false_ tst) + | B_not u when is_false u -> ret_bequiv t (T.true_ tst) | B_not _ -> None | B_opaque_bool _ -> None | B_and a -> if Iter.exists is_false a then - ret (T.bool tst false) + ret (T.false_ tst) else if Iter.for_all is_true a then - ret (T.bool tst true) + ret (T.true_ tst) else None | B_or a -> if Iter.exists is_true a then - ret (T.bool tst true) + ret (T.true_ tst) else if Iter.for_all is_false a then - ret (T.bool tst false) + ret (T.false_ tst) else None | B_imply (args, u) -> if Iter.exists is_false args then - ret (T.bool tst true) + ret (T.true_ tst) else if is_true u then - ret (T.bool tst true) + ret (T.true_ tst) else None | B_ite (a, b, c) -> (* directly simplify [a] so that maybe we never will simplify one of the branches *) - let a, prf_a = SI.Simplify.normalize_t simp a in + let a, prf_a = Simplify.normalize_t simp a in Option.iter add_step_ prf_a; (match A.view_as_bool a with | B_bool true -> @@ -201,27 +98,28 @@ module Make (A : ARG) : S with module A = A = struct | B_xor (a, b) when is_false b -> ret_bequiv t a | B_xor (a, b) when is_true b -> ret_bequiv t (not_ tst a) | B_equiv _ | B_xor _ -> None - | B_eq (a, b) when T.equal a b -> ret_bequiv t (T.bool tst true) - | B_neq (a, b) when T.equal a b -> ret_bequiv t (T.bool tst true) + | B_eq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) + | B_neq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) | B_eq _ | B_neq _ -> None | B_atom _ -> None let fresh_term self ~for_t ~pre ty = let u = A.Gensym.fresh_term self.gensym ~pre ty in Log.debugf 20 (fun k -> - k "(@[sidekick.bool.proxy@ :t %a@ :for %a@])" T.pp u T.pp for_t); - assert (Ty.equal ty (T.ty u)); + k "(@[sidekick.bool.proxy@ :t %a@ :for %a@])" T.pp_debug u T.pp_debug + for_t); + assert (Term.equal ty (T.ty u)); u let fresh_lit (self : state) ~for_t ~mk_lit ~pre : T.t * Lit.t = - let proxy = fresh_term ~for_t ~pre self (Ty.bool self.ty_st) in + let proxy = fresh_term ~for_t ~pre self (Term.bool self.tst) in proxy, mk_lit proxy (* TODO: polarity? *) let cnf (self : state) (si : SI.t) (module PA : SI.PREPROCESS_ACTS) (t : T.t) : unit = - Log.debugf 50 (fun k -> k "(@[th-bool.cnf@ %a@])" T.pp t); - let[@inline] mk_step_ r = Pr.add_step PA.proof r in + Log.debugf 50 (fun k -> k "(@[th-bool.cnf@ %a@])" T.pp_debug t); + let[@inline] mk_step_ r = Proof_trace.add_step PA.proof r in (* handle boolean equality *) let equiv_ _si ~is_xor ~t t_a t_b : unit = @@ -332,10 +230,14 @@ module Make (A : ARG) : S with module A = A = struct let create_and_setup si = Log.debug 2 "(th-bool.setup)"; - let st = create (SI.tst si) (SI.ty_st si) in + let st = create (SI.tst si) in SI.add_simplifier si (simplify st); SI.on_preprocess si (cnf st); st - let theory = A.S.mk_theory ~name:"th-bool" ~create_and_setup () + let theory = SMT.Solver.mk_theory ~name:"th-bool" ~create_and_setup () end + +let theory (module A : ARG) : SMT.theory = + let module M = Make (A) in + M.theory diff --git a/src/th-bool-static/Sidekick_th_bool_static.mli b/src/th-bool-static/Sidekick_th_bool_static.mli new file mode 100644 index 00000000..b83dc6c6 --- /dev/null +++ b/src/th-bool-static/Sidekick_th_bool_static.mli @@ -0,0 +1,11 @@ +(** Theory of boolean formulas. + + This handles formulas containing "and", "or", "=>", "if-then-else", etc. +*) + +module Intf = Intf +open Intf + +module type ARG = Intf.ARG + +val theory : (module ARG) -> SMT.Theory.t diff --git a/src/th-bool-static/dune b/src/th-bool-static/dune index 0cb1c59f..4a4dfc63 100644 --- a/src/th-bool-static/dune +++ b/src/th-bool-static/dune @@ -2,4 +2,5 @@ (name sidekick_th_bool_static) (public_name sidekick.th-bool-static) (flags :standard -open Sidekick_util) - (libraries sidekick.sigs.smt sidekick.util sidekick.cc.plugin)) + (libraries sidekick.core sidekick.smt-solver sidekick.util sidekick.simplify + sidekick.cc)) diff --git a/src/th-bool-static/intf.ml b/src/th-bool-static/intf.ml new file mode 100644 index 00000000..e25335a2 --- /dev/null +++ b/src/th-bool-static/intf.ml @@ -0,0 +1,65 @@ +open Sidekick_core +module SMT = Sidekick_smt_solver +module Simplify = Sidekick_simplify + +type term = Term.t +type ty = Term.t + +(** Boolean-oriented view of terms *) +type ('a, 'args) bool_view = + | B_bool of bool + | B_not of 'a + | B_and of 'args + | B_or of 'args + | B_imply of 'args * 'a + | B_equiv of 'a * 'a + | B_xor of 'a * 'a + | B_eq of 'a * 'a + | B_neq of 'a * 'a + | B_ite of 'a * 'a * 'a + | B_opaque_bool of 'a (* do not enter *) + | B_atom of 'a + +module type PROOF_RULES = sig + val lemma_bool_tauto : Lit.t Iter.t -> Proof_term.t + (** Boolean tautology lemma (clause) *) + + val lemma_bool_c : string -> term list -> Proof_term.t + (** Basic boolean logic lemma for a clause [|- c]. + [proof_bool_c b name cs] is the Proof_term.t designated by [name]. *) + + val lemma_bool_equiv : term -> term -> Proof_term.t + (** Boolean tautology lemma (equivalence) *) + + val lemma_ite_true : ite:term -> Proof_term.t + (** lemma [a ==> ite a b c = b] *) + + val lemma_ite_false : ite:term -> Proof_term.t + (** lemma [¬a ==> ite a b c = c] *) +end + +(** Argument to the theory *) +module type ARG = sig + val view_as_bool : term -> (term, term Iter.t) bool_view + (** Project the term into the boolean view. *) + + val mk_bool : Term.store -> (term, term array) bool_view -> term + (** Make a term from the given boolean view. *) + + module P : PROOF_RULES + + (** Fresh symbol generator. + + The theory needs to be able to create new terms with fresh names, + to be used as placeholders for complex formulas during Tseitin + encoding. *) + module Gensym : sig + type t + + val create : Term.store -> t + (** New (stateful) generator instance. *) + + val fresh_term : t -> pre:string -> ty -> term + (** Make a fresh term of the given type *) + end +end diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index fb5035ac..67a4845a 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -1,55 +1,43 @@ -(** {1 Theory for constructors} *) - -open Sidekick_sigs_smt +open Sidekick_core +module SMT = Sidekick_smt_solver +module SI = SMT.Solver_internal +module T = Term type ('c, 't) cstor_view = T_cstor of 'c * 't array | T_other of 't let name = "th-cstor" module type ARG = sig - module S : SOLVER - - val view_as_cstor : S.T.Term.t -> (S.T.Fun.t, S.T.Term.t) cstor_view - val lemma_cstor : S.Lit.t Iter.t -> S.Proof_trace.A.rule + val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view + val lemma_cstor : Lit.t Iter.t -> Proof_term.t end -module type S = sig - module A : ARG - - val theory : A.S.theory -end - -module Make (A : ARG) : S with module A = A = struct - module A = A - module SI = A.S.Solver_internal - module T = A.S.T.Term - module N = SI.CC.E_node - module Fun = A.S.T.Fun - module Expl = SI.CC.Expl +module Make (A : ARG) : sig + val theory : SMT.theory +end = struct + open Sidekick_cc module Monoid = struct - module CC = SI.CC - (* associate to each class a unique constructor term in the class (if any) *) - type t = { t: T.t; n: N.t; cstor: Fun.t; args: N.t array } + type t = { t: T.t; n: E_node.t; cstor: Const.t; args: E_node.t array } let name = name let pp out (v : t) = - Fmt.fprintf out "(@[cstor %a@ :term %a@])" Fun.pp v.cstor T.pp v.t + Fmt.fprintf out "(@[cstor %a@ :term %a@])" Const.pp v.cstor T.pp_debug v.t (* attach data to constructor terms *) let of_term cc n (t : T.t) : _ option * _ = match A.view_as_cstor t with | T_cstor (cstor, args) -> - let args = CCArray.map (SI.CC.add_term cc) args in + let args = CCArray.map (CC.add_term cc) args in Some { n; t; cstor; args }, [] | _ -> None, [] let merge _cc n1 v1 n2 v2 e_n1_n2 : _ result = Log.debugf 5 (fun k -> - k "(@[%s.merge@ @[:c1 %a (t %a)@]@ @[:c2 %a (t %a)@]@])" name N.pp n1 - T.pp v1.t N.pp n2 T.pp v2.t); + k "(@[%s.merge@ @[:c1 %a (t %a)@]@ @[:c2 %a (t %a)@]@])" name + E_node.pp n1 T.pp_debug v1.t E_node.pp n2 T.pp_debug v2.t); (* build full explanation of why the constructor terms are equal *) (* FIXME: add a (fun p -> A.lemma_cstor p …) here. probably we need [Some a=Some b => a=b] as a lemma for inj, @@ -57,22 +45,22 @@ module Make (A : ARG) : S with module A = A = struct let expl = Expl.mk_list [ e_n1_n2; Expl.mk_merge n1 v1.n; Expl.mk_merge n2 v2.n ] in - if Fun.equal v1.cstor v2.cstor then ( + if Const.equal v1.cstor v2.cstor then ( (* same function: injectivity *) assert (CCArray.length v1.args = CCArray.length v2.args); let acts = CCArray.map2 - (fun u1 u2 -> SI.CC.Handler_action.Act_merge (u1, u2, expl)) + (fun u1 u2 -> CC.Handler_action.Act_merge (u1, u2, expl)) v1.args v2.args |> Array.to_list in Ok (v1, acts) ) else (* different function: disjointness *) - Error (SI.CC.Handler_action.Conflict expl) + Error (CC.Handler_action.Conflict expl) end - module ST = Sidekick_cc_plugin.Make (Monoid) + module ST = Sidekick_cc.Plugin.Make (Monoid) type t = ST.t @@ -85,5 +73,10 @@ module Make (A : ARG) : S with module A = A = struct let self = ST.create_and_setup ~size:32 (SI.cc si) in self - let theory = A.S.mk_theory ~name ~push_level ~pop_levels ~create_and_setup () + let theory = + SMT.Solver.mk_theory ~name ~push_level ~pop_levels ~create_and_setup () end + +let make (module A : ARG) : SMT.theory = + let module M = Make (A) in + M.theory diff --git a/src/th-cstor/dune b/src/th-cstor/dune index bd39edcf..45db9b7e 100644 --- a/src/th-cstor/dune +++ b/src/th-cstor/dune @@ -1,5 +1,6 @@ (library (name Sidekick_th_cstor) (public_name sidekick.th-cstor) - (libraries containers sidekick.sigs.smt sidekick.util sidekick.cc.plugin) + (libraries containers sidekick.core sidekick.smt-solver sidekick.util + sidekick.cc) (flags :standard -open Sidekick_util)) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 1c02d6be..bcaae31a 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -1,21 +1,12 @@ (** Theory for datatypes. *) +open Sidekick_core +open Sidekick_cc include Th_intf +module SI = SMT.Solver_internal let name = "th-data" -(** An abtract representation of a datatype *) -module type DATA_TY = sig - type t - type cstor - - val equal : t -> t -> bool - val finite : t -> bool - val set_finite : t -> bool -> unit - val view : t -> (cstor, t) data_ty_view - val cstor_args : cstor -> t Iter.t -end - (** {2 Cardinality of types} *) module C = struct @@ -51,23 +42,22 @@ module Compute_card (A : ARG) : sig type t val create : unit -> t - val base_cstor : t -> A.S.T.Ty.t -> A.Cstor.t option - val is_finite : t -> A.S.T.Ty.t -> bool + val base_cstor : t -> ty -> A.Cstor.t option + val is_finite : t -> ty -> bool end = struct - module Ty = A.S.T.Ty - module Ty_tbl = CCHashtbl.Make (Ty) + module Ty_tbl = Term.Tbl type ty_cell = { mutable card: C.t; mutable base_cstor: A.Cstor.t option } type t = { cards: ty_cell Ty_tbl.t } let create () : t = { cards = Ty_tbl.create 16 } - let find (self : t) (ty0 : Ty.t) : ty_cell = + let find (self : t) (ty0 : ty) : ty_cell = let dr_tbl = Ty_tbl.create 16 in (* to build [ty], do we need to build [ty0]? *) - let rec is_direct_recursion (ty : Ty.t) : bool = - Ty.equal ty0 ty + let rec is_direct_recursion (ty : ty) : bool = + Term.equal ty0 ty || try Ty_tbl.find dr_tbl ty with Not_found -> @@ -89,7 +79,7 @@ end = struct Iter.exists is_direct_recursion (A.Cstor.ty_args c) in - let rec get_cell (ty : Ty.t) : ty_cell = + let rec get_cell (ty : ty) : ty_cell = match Ty_tbl.find self.cards ty with | c -> c | exception Not_found -> @@ -131,8 +121,8 @@ end = struct in cell.card <- card; Log.debugf 5 (fun k -> - k "(@[th-data.card-ty@ %a@ :is %a@ :base-cstor %a@])" Ty.pp ty C.pp - card + k "(@[th-data.card-ty@ %a@ :is %a@ :base-cstor %a@])" Term.pp_debug + ty C.pp card (Fmt.Dump.option A.Cstor.pp) cell.base_cstor); cell @@ -149,103 +139,86 @@ end = struct | C.Infinite -> false end -module type S = sig - module A : ARG - - val theory : A.S.theory -end - -module Make (A : ARG) : S with module A = A = struct - module A = A - module SI = A.S.Solver_internal - module T = A.S.T.Term - module N = SI.CC.E_node - module Ty = A.S.T.Ty - module Expl = SI.CC.Expl +module Make (A : ARG) : sig + val theory : SMT.theory +end = struct module Card = Compute_card (A) - open struct - module Pr = SI.Proof_trace - end - (** Monoid mapping each class to the (unique) constructor it contains, if any *) module Monoid_cstor = struct - module CC = SI.CC - let name = "th-data.cstor" (* associate to each class a unique constructor term in the class (if any) *) - type t = { c_n: N.t; c_cstor: A.Cstor.t; c_args: N.t array } + type t = { c_n: E_node.t; c_cstor: A.Cstor.t; c_args: E_node.t array } let pp out (v : t) = Fmt.fprintf out "(@[%s@ :cstor %a@ :n %a@ :args [@[%a@]]@])" name - A.Cstor.pp v.c_cstor N.pp v.c_n (Util.pp_array N.pp) v.c_args + A.Cstor.pp v.c_cstor E_node.pp v.c_n (Util.pp_array E_node.pp) v.c_args (* attach data to constructor terms *) - let of_term cc n (t : T.t) : _ option * _ list = + let of_term cc n (t : Term.t) : _ option * _ list = match A.view_as_data t with | T_cstor (cstor, args) -> - let args = CCArray.map (SI.CC.add_term cc) args in + let args = CCArray.map (CC.add_term cc) args in Some { c_n = n; c_cstor = cstor; c_args = args }, [] | _ -> None, [] let merge cc n1 c1 n2 c2 e_n1_n2 : _ result = Log.debugf 5 (fun k -> - k "(@[%s.merge@ (@[:c1 %a@ %a@])@ (@[:c2 %a@ %a@])@])" name N.pp n1 pp - c1 N.pp n2 pp c2); + k "(@[%s.merge@ (@[:c1 %a@ %a@])@ (@[:c2 %a@ %a@])@])" name E_node.pp + n1 pp c1 E_node.pp n2 pp c2); let mk_expl t1 t2 pr = Expl.mk_theory t1 t2 [ - ( N.term n1, - N.term n2, + ( E_node.term n1, + E_node.term n2, [ e_n1_n2; Expl.mk_merge n1 c1.c_n; Expl.mk_merge n2 c2.c_n ] ); ] pr in - let proof = SI.CC.proof cc in + let proof = CC.proof cc in if A.Cstor.equal c1.c_cstor c2.c_cstor then ( (* same function: injectivity *) let expl_merge i = - let t1 = N.term c1.c_n in - let t2 = N.term c2.c_n in - mk_expl t1 t2 @@ Pr.add_step proof @@ A.P.lemma_cstor_inj t1 t2 i + let t1 = E_node.term c1.c_n in + let t2 = E_node.term c2.c_n in + mk_expl t1 t2 @@ Proof_trace.add_step proof + @@ A.P.lemma_cstor_inj t1 t2 i in assert (CCArray.length c1.c_args = CCArray.length c2.c_args); let acts = ref [] in Util.array_iteri2 c1.c_args c2.c_args ~f:(fun i u1 u2 -> - acts := - SI.CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts); + acts := CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts); Ok (c1, !acts) ) else ( (* different function: disjointness *) let expl = - let t1 = N.term c1.c_n and t2 = N.term c2.c_n in - mk_expl t1 t2 @@ Pr.add_step proof @@ A.P.lemma_cstor_distinct t1 t2 + let t1 = E_node.term c1.c_n and t2 = E_node.term c2.c_n in + mk_expl t1 t2 @@ Proof_trace.add_step proof + @@ A.P.lemma_cstor_distinct t1 t2 in - Error (SI.CC.Handler_action.Conflict expl) + Error (CC.Handler_action.Conflict expl) ) end (** Monoid mapping each class to the set of is-a/select of which it is the argument *) module Monoid_parents = struct - module CC = SI.CC - let name = "th-data.parents" type select = { - sel_n: N.t; + sel_n: E_node.t; sel_cstor: A.Cstor.t; sel_idx: int; - sel_arg: N.t; + sel_arg: E_node.t; } - type is_a = { is_a_n: N.t; is_a_cstor: A.Cstor.t; is_a_arg: N.t } + type is_a = { is_a_n: E_node.t; is_a_cstor: A.Cstor.t; is_a_arg: E_node.t } (* associate to each class a unique constructor term in the class (if any) *) type t = { @@ -255,10 +228,11 @@ module Make (A : ARG) : S with module A = A = struct let pp_select out s = Fmt.fprintf out "(@[sel[%d]-%a@ :n %a@])" s.sel_idx A.Cstor.pp s.sel_cstor - N.pp s.sel_n + E_node.pp s.sel_n let pp_is_a out s = - Fmt.fprintf out "(@[is-%a@ :n %a@])" A.Cstor.pp s.is_a_cstor N.pp s.is_a_n + Fmt.fprintf out "(@[is-%a@ :n %a@])" A.Cstor.pp s.is_a_cstor E_node.pp + s.is_a_n let pp out (v : t) = Fmt.fprintf out "(@[%s@ @[:sel [@[%a@]]@]@ @[:is-a [@[%a@]]@]@])" name @@ -266,10 +240,10 @@ module Make (A : ARG) : S with module A = A = struct v.parent_is_a (* attach data to constructor terms *) - let of_term cc n (t : T.t) : _ option * _ list = + let of_term cc n (t : Term.t) : _ option * _ list = match A.view_as_data t with | T_select (c, i, u) -> - let u = SI.CC.add_term cc u in + let u = CC.add_term cc u in let m_sel = { parent_select = @@ -279,7 +253,7 @@ module Make (A : ARG) : S with module A = A = struct in None, [ u, m_sel ] | T_is_a (c, u) -> - let u = SI.CC.add_term cc u in + let u = CC.add_term cc u in let m_sel = { parent_is_a = [ { is_a_n = n; is_a_cstor = c; is_a_arg = u } ]; @@ -289,31 +263,31 @@ module Make (A : ARG) : S with module A = A = struct None, [ u, m_sel ] | T_cstor _ | T_other _ -> None, [] - let merge cc n1 v1 n2 v2 _e : _ result = + let merge _cc n1 v1 n2 v2 _e : _ result = Log.debugf 5 (fun k -> - k "(@[%s.merge@ @[:c1 %a@ :v %a@]@ @[:c2 %a@ :v %a@]@])" name N.pp n1 - pp v1 N.pp n2 pp v2); + k "(@[%s.merge@ @[:c1 %a@ :v %a@]@ @[:c2 %a@ :v %a@]@])" name + E_node.pp n1 pp v1 E_node.pp n2 pp v2); let parent_is_a = v1.parent_is_a @ v2.parent_is_a in let parent_select = v1.parent_select @ v2.parent_select in Ok ({ parent_is_a; parent_select }, []) end - module ST_cstors = Sidekick_cc_plugin.Make (Monoid_cstor) - module ST_parents = Sidekick_cc_plugin.Make (Monoid_parents) - module N_tbl = Backtrackable_tbl.Make (N) + module ST_cstors = Sidekick_cc.Plugin.Make (Monoid_cstor) + module ST_parents = Sidekick_cc.Plugin.Make (Monoid_parents) + module N_tbl = Backtrackable_tbl.Make (E_node) type t = { - tst: T.store; - proof: SI.Proof_trace.t; + tst: Term.store; + proof: Proof_trace.t; cstors: ST_cstors.t; (* repr -> cstor for the class *) parents: ST_parents.t; (* repr -> parents for the class *) cards: Card.t; (* remember finiteness *) to_decide: unit N_tbl.t; (* set of terms to decide. *) to_decide_for_complete_model: unit N_tbl.t; (* infinite types but we need a cstor in model*) - case_split_done: unit T.Tbl.t; + case_split_done: unit Term.Tbl.t; (* set of terms for which case split is done *) - single_cstor_preproc_done: unit T.Tbl.t; (* preprocessed terms *) + single_cstor_preproc_done: unit Term.Tbl.t; (* preprocessed terms *) stat_acycl_conflict: int Stat.counter; (* TODO: bitfield for types with less than 62 cstors, to quickly detect conflict? *) } @@ -330,24 +304,25 @@ module Make (A : ARG) : S with module A = A = struct N_tbl.pop_levels self.to_decide n; () - let preprocess (self : t) si (acts : SI.preprocess_actions) (t : T.t) : unit = - let ty = T.ty t in + let preprocess (self : t) _si (acts : SI.preprocess_actions) (t : Term.t) : + unit = + let ty = Term.ty t in match A.view_as_data t, A.as_datatype ty with | T_cstor _, _ -> () | _, Ty_data { cstors; _ } -> (match Iter.take 2 cstors |> Iter.to_rev_list with - | [ cstor ] when not (T.Tbl.mem self.single_cstor_preproc_done t) -> + | [ cstor ] when not (Term.Tbl.mem self.single_cstor_preproc_done t) -> (* single cstor: assert [t = cstor (sel-c-0 t, …, sel-c n t)] *) Log.debugf 50 (fun k -> k "(@[%s.preprocess.single-cstor@ %a@ :ty %a@ :cstor %a@])" name - T.pp t Ty.pp ty A.Cstor.pp cstor); + Term.pp_debug t Term.pp_debug ty A.Cstor.pp cstor); let (module Act) = acts in let u = let sel_args = A.Cstor.ty_args cstor - |> Iter.mapi (fun i ty -> A.mk_sel self.tst cstor i t) + |> Iter.mapi (fun i _ty -> A.mk_sel self.tst cstor i t) |> Iter.to_array in A.mk_cstor self.tst cstor sel_args @@ -357,18 +332,20 @@ module Make (A : ARG) : S with module A = A = struct with exhaustiveness: [|- is-c(t)] *) let proof = let pr_isa = - Pr.add_step self.proof + Proof_trace.add_step self.proof @@ A.P.lemma_isa_split t (Iter.return @@ Act.mk_lit (A.mk_is_a self.tst cstor t)) and pr_eq_sel = - Pr.add_step self.proof @@ A.P.lemma_select_cstor ~cstor_t:u t + Proof_trace.add_step self.proof + @@ A.P.lemma_select_cstor ~cstor_t:u t in - Pr.add_step self.proof @@ SI.P_core_rules.proof_r1 pr_isa pr_eq_sel + Proof_trace.add_step self.proof + @@ Proof_core.proof_r1 pr_isa pr_eq_sel in - T.Tbl.add self.single_cstor_preproc_done t (); + Term.Tbl.add self.single_cstor_preproc_done t (); (* avoid loops *) - T.Tbl.add self.case_split_done t (); + Term.Tbl.add self.case_split_done t (); (* no need to decide *) Act.add_clause [ Act.mk_lit (A.mk_eq self.tst t u) ] proof @@ -376,16 +353,18 @@ module Make (A : ARG) : S with module A = A = struct | _ -> () (* remember terms of a datatype *) - let on_new_term_look_at_ty (self : t) n (t : T.t) : unit = - let ty = T.ty t in + let on_new_term_look_at_ty (self : t) n (t : Term.t) : unit = + let ty = Term.ty t in match A.as_datatype ty with | Ty_data _ -> Log.debugf 20 (fun k -> - k "(@[%s.on-new-term.has-data-ty@ %a@ :ty %a@])" name T.pp t Ty.pp ty); + k "(@[%s.on-new-term.has-data-ty@ %a@ :ty %a@])" name Term.pp_debug t + Term.pp_debug ty); if Card.is_finite self.cards ty && not (N_tbl.mem self.to_decide n) then ( (* must decide this term *) Log.debugf 20 (fun k -> - k "(@[%s.on-new-term.must-decide-finite-ty@ %a@])" name T.pp t); + k "(@[%s.on-new-term.must-decide-finite-ty@ %a@])" name + Term.pp_debug t); N_tbl.add self.to_decide n () ) else if (not (N_tbl.mem self.to_decide n)) @@ -395,13 +374,13 @@ module Make (A : ARG) : S with module A = A = struct N_tbl.add self.to_decide_for_complete_model n () | _ -> () - let on_new_term (self : t) ((cc, n, t) : _ * N.t * T.t) : _ list = + let on_new_term (self : t) ((cc, n, t) : _ * E_node.t * Term.t) : _ list = on_new_term_look_at_ty self n t; (* might have to decide [t] *) match A.view_as_data t with | T_is_a (c_t, u) -> - let n_u = SI.CC.add_term cc u in - let repr_u = SI.CC.find cc n_u in + let n_u = CC.add_term cc u in + let repr_u = CC.find cc n_u in (match ST_cstors.get self.cstors repr_u with | None -> (* needs to be decided *) @@ -413,41 +392,49 @@ module Make (A : ARG) : S with module A = A = struct k "(@[%s.on-new-term.is-a.reduce@ :t %a@ :to %B@ :n %a@ :sub-cstor \ %a@])" - name T.pp t is_true N.pp n Monoid_cstor.pp cstor); + name Term.pp_debug t is_true E_node.pp n Monoid_cstor.pp cstor); let pr = - Pr.add_step self.proof - @@ A.P.lemma_isa_cstor ~cstor_t:(N.term cstor.c_n) t + Proof_trace.add_step self.proof + @@ A.P.lemma_isa_cstor ~cstor_t:(E_node.term cstor.c_n) t in - let n_bool = SI.CC.n_bool cc is_true in + let n_bool = CC.n_bool cc is_true in let expl = Expl.( - mk_theory (N.term n) (N.term n_bool) - [ N.term n_u, N.term cstor.c_n, [ mk_merge n_u cstor.c_n ] ] + mk_theory (E_node.term n) (E_node.term n_bool) + [ + ( E_node.term n_u, + E_node.term cstor.c_n, + [ mk_merge n_u cstor.c_n ] ); + ] pr) in - let a = SI.CC.Handler_action.Act_merge (n, n_bool, expl) in + let a = CC.Handler_action.Act_merge (n, n_bool, expl) in [ a ]) | T_select (c_t, i, u) -> - let n_u = SI.CC.add_term cc u in - let repr_u = SI.CC.find cc n_u in + let n_u = CC.add_term cc u in + let repr_u = CC.find cc n_u in (match ST_cstors.get self.cstors repr_u with | Some cstor when A.Cstor.equal cstor.c_cstor c_t -> Log.debugf 5 (fun k -> k "(@[%s.on-new-term.select.reduce@ :n %a@ :sel get[%d]-%a@])" name - N.pp n i A.Cstor.pp c_t); + E_node.pp n i A.Cstor.pp c_t); assert (i < CCArray.length cstor.c_args); let u_i = CCArray.get cstor.c_args i in let pr = - Pr.add_step self.proof - @@ A.P.lemma_select_cstor ~cstor_t:(N.term cstor.c_n) t + Proof_trace.add_step self.proof + @@ A.P.lemma_select_cstor ~cstor_t:(E_node.term cstor.c_n) t in let expl = Expl.( - mk_theory (N.term n) (N.term u_i) - [ N.term n_u, N.term cstor.c_n, [ mk_merge n_u cstor.c_n ] ] + mk_theory (E_node.term n) (E_node.term u_i) + [ + ( E_node.term n_u, + E_node.term cstor.c_n, + [ mk_merge n_u cstor.c_n ] ); + ] pr) in - [ SI.CC.Handler_action.Act_merge (n, u_i, expl) ] + [ CC.Handler_action.Act_merge (n, u_i, expl) ] | Some _ -> [] | None -> (* needs to be decided *) @@ -455,12 +442,12 @@ module Make (A : ARG) : S with module A = A = struct []) | T_cstor _ | T_other _ -> [] - let cstors_of_ty (ty : Ty.t) : A.Cstor.t Iter.t = + let cstors_of_ty (ty : ty) : A.Cstor.t Iter.t = match A.as_datatype ty with | Ty_data { cstors } -> cstors | _ -> assert false - let on_pre_merge (self : t) (cc, n1, n2, expl) : _ result = + let on_pre_merge (self : t) (cc, n1, n2, _expl) : _ result = let acts = ref [] in let merge_is_a n1 (c1 : Monoid_cstor.t) n2 (is_a2 : Monoid_parents.is_a) = let is_true = A.Cstor.equal c1.c_cstor is_a2.is_a_cstor in @@ -468,18 +455,19 @@ module Make (A : ARG) : S with module A = A = struct k "(@[%s.on-merge.is-a.reduce@ %a@ :to %B@ :n1 %a@ :n2 %a@ \ :sub-cstor %a@])" - name Monoid_parents.pp_is_a is_a2 is_true N.pp n1 N.pp n2 + name Monoid_parents.pp_is_a is_a2 is_true E_node.pp n1 E_node.pp n2 Monoid_cstor.pp c1); let pr = - Pr.add_step self.proof - @@ A.P.lemma_isa_cstor ~cstor_t:(N.term c1.c_n) (N.term is_a2.is_a_n) + Proof_trace.add_step self.proof + @@ A.P.lemma_isa_cstor ~cstor_t:(E_node.term c1.c_n) + (E_node.term is_a2.is_a_n) in - let n_bool = SI.CC.n_bool cc is_true in + let n_bool = CC.n_bool cc is_true in let expl = - Expl.mk_theory (N.term is_a2.is_a_n) (N.term n_bool) + Expl.mk_theory (E_node.term is_a2.is_a_n) (E_node.term n_bool) [ - ( N.term n1, - N.term n2, + ( E_node.term n1, + E_node.term n2, [ Expl.mk_merge n1 c1.c_n; Expl.mk_merge n1 n2; @@ -488,7 +476,7 @@ module Make (A : ARG) : S with module A = A = struct ] pr in - let act = SI.CC.Handler_action.Act_merge (is_a2.is_a_n, n_bool, expl) in + let act = CC.Handler_action.Act_merge (is_a2.is_a_n, n_bool, expl) in acts := act :: !acts in let merge_select n1 (c1 : Monoid_cstor.t) n2 (sel2 : Monoid_parents.select) @@ -496,18 +484,19 @@ module Make (A : ARG) : S with module A = A = struct if A.Cstor.equal c1.c_cstor sel2.sel_cstor then ( Log.debugf 5 (fun k -> k "(@[%s.on-merge.select.reduce@ :n2 %a@ :sel get[%d]-%a@])" name - N.pp n2 sel2.sel_idx Monoid_cstor.pp c1); + E_node.pp n2 sel2.sel_idx Monoid_cstor.pp c1); assert (sel2.sel_idx < CCArray.length c1.c_args); let pr = - Pr.add_step self.proof - @@ A.P.lemma_select_cstor ~cstor_t:(N.term c1.c_n) (N.term sel2.sel_n) + Proof_trace.add_step self.proof + @@ A.P.lemma_select_cstor ~cstor_t:(E_node.term c1.c_n) + (E_node.term sel2.sel_n) in let u_i = CCArray.get c1.c_args sel2.sel_idx in let expl = - Expl.mk_theory (N.term sel2.sel_n) (N.term u_i) + Expl.mk_theory (E_node.term sel2.sel_n) (E_node.term u_i) [ - ( N.term n1, - N.term n2, + ( E_node.term n1, + E_node.term n2, [ Expl.mk_merge n1 c1.c_n; Expl.mk_merge n1 n2; @@ -516,7 +505,7 @@ module Make (A : ARG) : S with module A = A = struct ] pr in - let act = SI.CC.Handler_action.Act_merge (sel2.sel_n, u_i, expl) in + let act = CC.Handler_action.Act_merge (sel2.sel_n, u_i, expl) in acts := act :: !acts ) in @@ -528,7 +517,8 @@ module Make (A : ARG) : S with module A = A = struct k "(@[%s.pre-merge@ (@[:n1 %a@ :c1 %a@])@ (@[:n2 %a@ :p2 \ %a@])@])" - name N.pp n1 Monoid_cstor.pp c1 N.pp n2 Monoid_parents.pp p2); + name E_node.pp n1 Monoid_cstor.pp c1 E_node.pp n2 + Monoid_parents.pp p2); List.iter (fun is_a2 -> merge_is_a n1 c1 n2 is_a2) p2.parent_is_a; List.iter (fun s2 -> merge_select n1 c1 n2 s2) p2.parent_select in @@ -537,13 +527,13 @@ module Make (A : ARG) : S with module A = A = struct Ok !acts module Acyclicity_ = struct - type repr = N.t + type repr = E_node.t (* a node, corresponding to a class that has a constructor element. *) type node = { - repr: N.t; (* repr *) - cstor_n: N.t; (* the cstor node *) - cstor_args: (N.t * repr) list; (* arguments to [cstor_n] *) + repr: E_node.t; (* repr *) + cstor_n: E_node.t; (* the cstor node *) + cstor_args: (E_node.t * repr) list; (* arguments to [cstor_n] *) mutable flag: flag; } @@ -554,15 +544,17 @@ module Make (A : ARG) : S with module A = A = struct let pp_node out (n : node) = Fmt.fprintf out "(@[node@ :repr %a@ :cstor_n %a@ @[:cstor_args %a@]@])" - N.pp n.repr N.pp n.cstor_n - Fmt.(Dump.list @@ hvbox @@ pair ~sep:(return "@ --> ") N.pp N.pp) + E_node.pp n.repr E_node.pp n.cstor_n + Fmt.( + Dump.list @@ hvbox @@ pair ~sep:(return "@ --> ") E_node.pp E_node.pp) n.cstor_args - let pp_path = Fmt.Dump.(list @@ pair N.pp pp_node) + let pp_path = Fmt.Dump.(list @@ pair E_node.pp pp_node) let pp_graph out (g : graph) : unit = let pp_entry out (n, node) = - Fmt.fprintf out "@[<1>@[graph_node[%a]@]@ := %a@]" N.pp n pp_node node + Fmt.fprintf out "@[<1>@[graph_node[%a]@]@ := %a@]" E_node.pp n pp_node + node in if N_tbl.length g = 0 then Fmt.string out "(graph ø)" @@ -573,12 +565,12 @@ module Make (A : ARG) : S with module A = A = struct let g : graph = N_tbl.create ~size:32 () in let traverse_sub cstor : _ list = Util.array_to_list_map - (fun sub_n -> sub_n, SI.CC.find cc sub_n) + (fun sub_n -> sub_n, CC.find cc sub_n) cstor.Monoid_cstor.c_args in (* populate tbl with [repr->node] *) ST_cstors.iter_all self.cstors (fun (repr, cstor) -> - assert (N.is_root repr); + assert (E_node.is_root repr); assert (not @@ N_tbl.mem g repr); let node = { @@ -597,8 +589,8 @@ module Make (A : ARG) : S with module A = A = struct let g = mk_graph self cc in Log.debugf 50 (fun k -> k "(@[%s.acyclicity.graph@ %a@])" name pp_graph g); (* traverse the graph, looking for cycles *) - let rec traverse ~path (n : N.t) (r : repr) : unit = - assert (N.is_root r); + let rec traverse ~path (n : E_node.t) (r : repr) : unit = + assert (E_node.is_root r); match N_tbl.find g r with | exception Not_found -> () | { flag = Done; _ } -> () (* no need *) @@ -606,24 +598,24 @@ module Make (A : ARG) : S with module A = A = struct (* conflict: the [path] forms a cycle *) let path = (n, node) :: path in let pr = - Pr.add_step self.proof + Proof_trace.add_step self.proof @@ A.P.lemma_acyclicity (Iter.of_list path - |> Iter.map (fun (a, b) -> N.term a, N.term b.repr)) + |> Iter.map (fun (a, b) -> E_node.term a, E_node.term b.repr)) in let expl = let subs = CCList.map (fun (n, node) -> - ( N.term n, - N.term node.cstor_n, + ( E_node.term n, + E_node.term node.cstor_n, [ Expl.mk_merge node.cstor_n node.repr; Expl.mk_merge n node.repr; ] )) path in - Expl.mk_theory (N.term n) (N.term cstor_n) subs pr + Expl.mk_theory (E_node.term n) (E_node.term cstor_n) subs pr in Stat.incr self.stat_acycl_conflict; Log.debugf 5 (fun k -> @@ -631,7 +623,7 @@ module Make (A : ARG) : S with module A = A = struct expl pp_path path); let lits, pr = SI.cc_resolve_expl solver expl in (* negate lits *) - let c = List.rev_map SI.Lit.neg lits in + let c = List.rev_map Lit.neg lits in SI.raise_conflict solver acts c pr | { flag = New; _ } as node_r -> node_r.flag <- Open; @@ -645,11 +637,11 @@ module Make (A : ARG) : S with module A = A = struct () end - let check_is_a self solver acts trail = + let check_is_a self solver _acts trail = let check_lit lit = - let t = SI.Lit.term lit in + let t = Lit.term lit in match A.view_as_data t with - | T_is_a (c, u) when SI.Lit.sign lit -> + | T_is_a (c, u) when Lit.sign lit -> (* add [((_ is C) u) ==> u = C(sel-c-0 u, …, sel-c-k u)] *) let rhs = let args = @@ -660,43 +652,42 @@ module Make (A : ARG) : S with module A = A = struct A.mk_cstor self.tst c args in Log.debugf 50 (fun k -> - k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name T.pp u T.pp - rhs SI.Lit.pp lit); - let pr = Pr.add_step self.proof @@ A.P.lemma_isa_sel t in + k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name + Term.pp_debug u Term.pp_debug rhs Lit.pp lit); + let pr = Proof_trace.add_step self.proof @@ A.P.lemma_isa_sel t in (* merge [u] and [rhs] *) - SI.CC.merge_t (SI.cc solver) u rhs + CC.merge_t (SI.cc solver) u rhs (Expl.mk_theory u rhs - [ t, N.term (SI.CC.n_true @@ SI.cc solver), [ Expl.mk_lit lit ] ] + [ t, E_node.term (CC.n_true @@ SI.cc solver), [ Expl.mk_lit lit ] ] pr) | _ -> () in Iter.iter check_lit trail (* add clauses [\Or_c is-c(n)] and [¬(is-a n) ∨ ¬(is-b n)] *) - let decide_class_ (self : t) (solver : SI.t) acts (n : N.t) : unit = - let t = N.term n in + let decide_class_ (self : t) (solver : SI.t) acts (n : E_node.t) : unit = + let t = E_node.term n in (* [t] might have been expanded already, in case of duplicates in [l] *) - if not @@ T.Tbl.mem self.case_split_done t then ( - T.Tbl.add self.case_split_done t (); + if not @@ Term.Tbl.mem self.case_split_done t then ( + Term.Tbl.add self.case_split_done t (); let c = - cstors_of_ty (T.ty t) + cstors_of_ty (Term.ty t) |> Iter.map (fun c -> A.mk_is_a self.tst c t) |> Iter.map (fun t -> - let lit = SI.mk_lit solver acts t in + let lit = SI.mk_lit solver t in (* TODO: set default polarity, depending on n° of args? *) lit) |> Iter.to_rev_list in SI.add_clause_permanent solver acts c - (Pr.add_step self.proof @@ A.P.lemma_isa_split t (Iter.of_list c)); + (Proof_trace.add_step self.proof + @@ A.P.lemma_isa_split t (Iter.of_list c)); Iter.diagonal_l c (fun (l1, l2) -> let pr = - Pr.add_step self.proof - @@ A.P.lemma_isa_disj (SI.Lit.neg l1) (SI.Lit.neg l2) + Proof_trace.add_step self.proof + @@ A.P.lemma_isa_disj (Lit.neg l1) (Lit.neg l2) in - SI.add_clause_permanent solver acts - [ SI.Lit.neg l1; SI.Lit.neg l2 ] - pr) + SI.add_clause_permanent solver acts [ Lit.neg l1; Lit.neg l2 ] pr) ) (* on final check, check acyclicity, @@ -716,7 +707,7 @@ module Make (A : ARG) : S with module A = A = struct |> Iter.map (fun (n, _) -> SI.cc_find solver n) |> Iter.filter (fun n -> (not (ST_cstors.mem self.cstors n)) - && not (T.Tbl.mem self.case_split_done (N.term n))) + && not (Term.Tbl.mem self.case_split_done (E_node.term n))) |> Iter.to_rev_list in (match remaining_to_decide with @@ -727,7 +718,8 @@ module Make (A : ARG) : S with module A = A = struct () | l -> Log.debugf 10 (fun k -> - k "(@[%s.final-check.must-decide@ %a@])" name (Util.pp_list N.pp) l); + k "(@[%s.final-check.must-decide@ %a@])" name (Util.pp_list E_node.pp) + l); Profile.instant "data.case-split"; List.iter (decide_class_ self solver acts) l); @@ -736,21 +728,22 @@ module Make (A : ARG) : S with module A = A = struct N_tbl.to_iter self.to_decide_for_complete_model |> Iter.map (fun (n, _) -> SI.cc_find solver n) |> Iter.filter (fun n -> - (not (T.Tbl.mem self.case_split_done (N.term n))) + (not (Term.Tbl.mem self.case_split_done (E_node.term n))) && not (ST_cstors.mem self.cstors n)) |> Iter.head in match next_decision with | None -> () (* all decided *) | Some n -> - let t = N.term n in + let t = E_node.term n in Profile.instant "data.decide"; (* use a constructor that will not lead to an infinite loop *) let base_cstor = - match Card.base_cstor self.cards (T.ty t) with - | None -> Error.errorf "th-data:@ %a should have base cstor" N.pp n + match Card.base_cstor self.cards (Term.ty t) with + | None -> + Error.errorf "th-data:@ %a should have base cstor" E_node.pp n | Some c -> c in let cstor_app = @@ -763,16 +756,18 @@ module Make (A : ARG) : S with module A = A = struct in let t_eq_cstor = A.mk_eq self.tst t cstor_app in Log.debugf 20 (fun k -> - k "(@[th-data.final-check.model.decide-cstor@ %a@])" T.pp t_eq_cstor); - let lit = SI.mk_lit solver acts t_eq_cstor in + k "(@[th-data.final-check.model.decide-cstor@ %a@])" Term.pp_debug + t_eq_cstor); + let lit = SI.mk_lit solver t_eq_cstor in SI.push_decision solver acts lit ); () - let on_model_gen (self : t) ~recurse (si : SI.t) (n : N.t) : T.t option = + let on_model_gen (self : t) ~recurse (si : SI.t) (n : E_node.t) : + Term.t option = (* TODO: option to complete model or not (by picking sth at leaves)? *) let cc = SI.cc si in - let repr = SI.CC.find cc n in + let repr = CC.find cc n in match ST_cstors.get self.cstors repr with | None -> None | Some c -> @@ -791,8 +786,8 @@ module Make (A : ARG) : S with module A = A = struct parents = ST_parents.create_and_setup ~size:32 (SI.cc solver); to_decide = N_tbl.create ~size:16 (); to_decide_for_complete_model = N_tbl.create ~size:16 (); - single_cstor_preproc_done = T.Tbl.create 8; - case_split_done = T.Tbl.create 16; + single_cstor_preproc_done = Term.Tbl.create 8; + case_split_done = Term.Tbl.create 16; cards = Card.create (); stat_acycl_conflict = Stat.mk_int (SI.stats solver) "data.acycl.conflict"; @@ -807,5 +802,10 @@ module Make (A : ARG) : S with module A = A = struct SI.on_model solver ~ask:(on_model_gen self); self - let theory = A.S.mk_theory ~name ~push_level ~pop_levels ~create_and_setup () + let theory = + SMT.Solver.mk_theory ~name ~push_level ~pop_levels ~create_and_setup () end + +let make (module A : ARG) = + let module M = Make (A) in + M.theory diff --git a/src/th-data/Sidekick_th_data.mli b/src/th-data/Sidekick_th_data.mli index ce347744..3149f15a 100644 --- a/src/th-data/Sidekick_th_data.mli +++ b/src/th-data/Sidekick_th_data.mli @@ -2,11 +2,4 @@ include module type of Th_intf -module type S = sig - module A : ARG - - val theory : A.S.theory - (** A theory that can be added to {!A.S} to perform datatype reasoning. *) -end - -module Make (A : ARG) : S with module A = A +val make : (module ARG) -> SMT.theory diff --git a/src/th-data/dune b/src/th-data/dune index 8f959c7e..ecc7dbb3 100644 --- a/src/th-data/dune +++ b/src/th-data/dune @@ -1,7 +1,8 @@ (library (name Sidekick_th_data) (public_name sidekick.th-data) - (libraries containers sidekick.sigs.smt sidekick.util sidekick.cc.plugin) - (flags :standard -open Sidekick_util -w -27-32)) + (libraries containers sidekick.core sidekick.util sidekick.cc + sidekick.smt-solver) + (flags :standard -open Sidekick_util -w +32)) ; TODO get warning back diff --git a/src/th-data/th_intf.ml b/src/th-data/th_intf.ml index aa1360d4..1004e5b0 100644 --- a/src/th-data/th_intf.ml +++ b/src/th-data/th_intf.ml @@ -1,4 +1,7 @@ -open Sidekick_sigs_smt +open Sidekick_core +module SMT = Sidekick_smt_solver + +type ty = Term.t (** Datatype-oriented view of terms. @@ -19,46 +22,54 @@ type ('c, 'ty) data_ty_view = | Ty_other module type PROOF_RULES = sig - type term - type lit - type rule - - val lemma_isa_cstor : cstor_t:term -> term -> rule + val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t (** [lemma_isa_cstor (d …) (is-c t)] returns the clause [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) - val lemma_select_cstor : cstor_t:term -> term -> rule + val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t (** [lemma_select_cstor (c t1…tn) (sel-c-i t)] returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) - val lemma_isa_split : term -> lit Iter.t -> rule + val lemma_isa_split : Term.t -> Lit.t Iter.t -> Proof_term.t (** [lemma_isa_split t lits] is the proof of [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) - val lemma_isa_sel : term -> rule + val lemma_isa_sel : Term.t -> Proof_term.t (** [lemma_isa_sel (is-c t)] is the proof of [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) - val lemma_isa_disj : lit -> lit -> rule + val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.t (** [lemma_isa_disj (is-c t) (is-d t)] is the proof of [¬ (is-c t) \/ ¬ (is-c t)] *) - val lemma_cstor_inj : term -> term -> int -> rule + val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.t (** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of [c t1…tn = c u1…un |- ti = ui] *) - val lemma_cstor_distinct : term -> term -> rule + val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.t (** [lemma_isa_distinct (c …) (d …)] is the proof of the unit clause [|- (c …) ≠ (d …)] *) - val lemma_acyclicity : (term * term) Iter.t -> rule + val lemma_acyclicity : (Term.t * Term.t) Iter.t -> Proof_term.t (** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] by acyclicity. *) end -module type ARG = sig - module S : SOLVER +(* TODO: remove? or make compute_card use that? *) +(** An abtract representation of a datatype *) +module type DATA_TY = sig + type t + type cstor + + val equal : t -> t -> bool + val finite : t -> bool + val set_finite : t -> bool -> unit + val view : t -> (cstor, t) data_ty_view + val cstor_args : cstor -> t Iter.t +end + +module type ARG = sig (** Constructor symbols. A constructor is an injective symbol, part of a datatype (or "sum type"). @@ -68,43 +79,37 @@ module type ARG = sig type t (** Constructor *) - val ty_args : t -> S.T.Ty.t Iter.t + val ty_args : t -> ty Iter.t (** Type arguments, for a polymorphic constructor *) - val pp : t Fmt.printer - - val equal : t -> t -> bool - (** Comparison *) + include Sidekick_sigs.EQ with type t := t + include Sidekick_sigs.PRINT with type t := t end - val as_datatype : S.T.Ty.t -> (Cstor.t Iter.t, S.T.Ty.t) data_ty_view + val as_datatype : ty -> (Cstor.t Iter.t, ty) data_ty_view (** Try to view type as a datatype (with its constructors) *) - val view_as_data : S.T.Term.t -> (Cstor.t, S.T.Term.t) data_view - (** Try to view term as a datatype term *) + val view_as_data : Term.t -> (Cstor.t, Term.t) data_view + (** Try to view Term.t as a datatype Term.t *) - val mk_cstor : S.T.Term.store -> Cstor.t -> S.T.Term.t array -> S.T.Term.t - (** Make a constructor application term *) + val mk_cstor : Term.store -> Cstor.t -> Term.t array -> Term.t + (** Make a constructor application Term.t *) - val mk_is_a : S.T.Term.store -> Cstor.t -> S.T.Term.t -> S.T.Term.t - (** Make a [is-a] term *) + val mk_is_a : Term.store -> Cstor.t -> Term.t -> Term.t + (** Make a [is-a] Term.t *) - val mk_sel : S.T.Term.store -> Cstor.t -> int -> S.T.Term.t -> S.T.Term.t - (** Make a selector term *) + val mk_sel : Term.store -> Cstor.t -> int -> Term.t -> Term.t + (** Make a selector Term.t *) - val mk_eq : S.T.Term.store -> S.T.Term.t -> S.T.Term.t -> S.T.Term.t - (** Make a term equality *) + val mk_eq : Term.store -> Term.t -> Term.t -> Term.t + (** Make a Term.t equality *) - val ty_is_finite : S.T.Ty.t -> bool + val ty_is_finite : ty -> bool (** Is the given type known to be finite? For example a finite datatype (an "enum" in C parlance), or [Bool], or [Array Bool Bool]. *) - val ty_set_is_finite : S.T.Ty.t -> bool -> unit + val ty_set_is_finite : ty -> bool -> unit (** Modify the "finite" field (see {!ty_is_finite}) *) - module P : - PROOF_RULES - with type rule = S.Proof_trace.A.rule - and type term = S.T.Term.t - and type lit = S.Lit.t + module P : PROOF_RULES end diff --git a/src/th-lra/intf.ml b/src/th-lra/intf.ml new file mode 100644 index 00000000..c9b60c30 --- /dev/null +++ b/src/th-lra/intf.ml @@ -0,0 +1,59 @@ +open Sidekick_core +module SMT = Sidekick_smt_solver +module Predicate = Sidekick_simplex.Predicate +module Linear_expr = Sidekick_simplex.Linear_expr +module Linear_expr_intf = Sidekick_simplex.Linear_expr_intf + +module type INT = Sidekick_arith.INT +module type RATIONAL = Sidekick_arith.RATIONAL + +module S_op = Sidekick_simplex.Op + +type term = Term.t +type ty = Term.t +type pred = Linear_expr_intf.bool_op = Leq | Geq | Lt | Gt | Eq | Neq +type op = Linear_expr_intf.op = Plus | Minus + +type ('num, 'a) lra_view = + | LRA_pred of pred * 'a * 'a + | LRA_op of op * 'a * 'a + | LRA_mult of 'num * 'a + | LRA_const of 'num + | LRA_other of 'a + +let map_view f (l : _ lra_view) : _ lra_view = + match l with + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (n, f a) + | LRA_const q -> LRA_const q + | LRA_other x -> LRA_other (f x) + +module type ARG = sig + module Z : INT + module Q : RATIONAL with type bigint = Z.t + + val view_as_lra : Term.t -> (Q.t, Term.t) lra_view + (** Project the Term.t into the theory view *) + + val mk_lra : Term.store -> (Q.t, Term.t) lra_view -> Term.t + (** Make a Term.t from the given theory view *) + + val ty_lra : Term.store -> ty + + val has_ty_real : Term.t -> bool + (** Does this term have the type [Real] *) + + val lemma_lra : Lit.t Iter.t -> Proof_term.t + + module Gensym : sig + type t + + val create : Term.store -> t + val tst : t -> Term.store + val copy : t -> t + + val fresh_term : t -> pre:string -> ty -> term + (** Make a fresh term of the given type *) + end +end diff --git a/src/th-lra/sidekick_arith_lra.ml b/src/th-lra/sidekick_arith_lra.ml index 5c05ceff..80bd87cd 100644 --- a/src/th-lra/sidekick_arith_lra.ml +++ b/src/th-lra/sidekick_arith_lra.ml @@ -1,140 +1,49 @@ -(** Linear Rational Arithmetic *) - (* Reference: http://smtlib.cs.uiowa.edu/logics-all.shtml#QF_LRA *) open Sidekick_core -module SMT = Sidekick_smt_solver -module Predicate = Sidekick_simplex.Predicate -module Linear_expr = Sidekick_simplex.Linear_expr -module Linear_expr_intf = Sidekick_simplex.Linear_expr_intf +open Sidekick_cc +module Intf = Intf +open Intf +module SI = SMT.Solver_internal -module type INT = Sidekick_arith.INT -module type RATIONAL = Sidekick_arith.RATIONAL +module type ARG = Intf.ARG -module S_op = Sidekick_simplex.Op +module Tag = struct + type t = Lit of Lit.t | CC_eq of E_node.t * E_node.t -type term = Term.t -type ty = Term.t -type pred = Linear_expr_intf.bool_op = Leq | Geq | Lt | Gt | Eq | Neq -type op = Linear_expr_intf.op = Plus | Minus + let pp out = function + | Lit l -> Fmt.fprintf out "(@[lit %a@])" Lit.pp l + | CC_eq (n1, n2) -> + Fmt.fprintf out "(@[cc-eq@ %a@ %a@])" E_node.pp n1 E_node.pp n2 -type ('num, 'a) lra_view = - | LRA_pred of pred * 'a * 'a - | LRA_op of op * 'a * 'a - | LRA_mult of 'num * 'a - | LRA_const of 'num - | LRA_other of 'a - -let map_view f (l : _ lra_view) : _ lra_view = - match l with - | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) - | LRA_op (p, a, b) -> LRA_op (p, f a, f b) - | LRA_mult (n, a) -> LRA_mult (n, f a) - | LRA_const q -> LRA_const q - | LRA_other x -> LRA_other (f x) - -module type ARG = sig - module Z : INT - module Q : RATIONAL with type bigint = Z.t - - val view_as_lra : Term.t -> (Q.t, Term.t) lra_view - (** Project the Term.t into the theory view *) - - val mk_lra : Term.store -> (Q.t, Term.t) lra_view -> Term.t - (** Make a Term.t from the given theory view *) - - val ty_lra : Term.store -> ty - - val has_ty_real : Term.t -> bool - (** Does this term have the type [Real] *) - - val lemma_lra : Lit.t Iter.t -> Proof_term.t - - module Gensym : sig - type t - - val create : Term.store -> t - val tst : t -> Term.store - val copy : t -> t - - val fresh_term : t -> pre:string -> ty -> term - (** Make a fresh term of the given type *) - end + let to_lits si = function + | Lit l -> [ l ] + | CC_eq (n1, n2) -> + let r = CC.explain_eq (SI.cc si) n1 n2 in + (* FIXME + assert (not (SI.CC.Resolved_expl.is_semantic r)); + *) + r.lits end -module type S = sig - module A : ARG +module SimpVar : Linear_expr.VAR with type t = Term.t and type lit = Tag.t = +struct + type t = Term.t - (* - module SimpVar : Sidekick_simplex.VAR with type lit = A.Lit.t - module LE_ : Linear_expr_intf.S with module Var = SimpVar - module LE = LE_.Expr - *) + let pp = Term.pp_debug + let compare = Term.compare - module SimpSolver : Sidekick_simplex.S - (** Simplexe *) + type lit = Tag.t - type state + let pp_lit = Tag.pp - val create : ?stat:Stat.t -> SMT.Solver_internal.t -> state - - (* TODO: be able to declare some variables as ints *) - - (* - val simplex : state -> Simplex.t - *) - - val k_state : state SMT.Registry.key - (** Key to access the state from outside, - available when the theory has been setup *) - - val theory : SMT.Theory.t + let not_lit = function + | Tag.Lit l -> Some (Tag.Lit (Lit.neg l)) + | _ -> None end module Make (A : ARG) = (* : S with module A = A *) struct - module A = A - module SI = SMT.Solver_internal - open Sidekick_cc - - open struct - module Pr = Proof_trace - end - - module Tag = struct - type t = Lit of Lit.t | CC_eq of E_node.t * E_node.t - - let pp out = function - | Lit l -> Fmt.fprintf out "(@[lit %a@])" Lit.pp l - | CC_eq (n1, n2) -> - Fmt.fprintf out "(@[cc-eq@ %a@ %a@])" E_node.pp n1 E_node.pp n2 - - let to_lits si = function - | Lit l -> [ l ] - | CC_eq (n1, n2) -> - let r = CC.explain_eq (SI.cc si) n1 n2 in - (* FIXME - assert (not (SI.CC.Resolved_expl.is_semantic r)); - *) - r.lits - end - - module SimpVar : Linear_expr.VAR with type t = Term.t and type lit = Tag.t = - struct - type t = Term.t - - let pp = Term.pp_debug - let compare = Term.compare - - type lit = Tag.t - - let pp_lit = Tag.pp - - let not_lit = function - | Tag.Lit l -> Some (Tag.Lit (Lit.neg l)) - | _ -> None - end - module LE_ = Linear_expr.Make (A.Q) (SimpVar) module LE = LE_.Expr @@ -339,12 +248,12 @@ module Make (A : ARG) = (* : S with module A = A *) struct proxy) let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = - let pr = Pr.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in + let pr = Proof_trace.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in let pr = match using with | None -> pr | Some using -> - Pr.add_step PA.proof + Proof_trace.add_step PA.proof @@ Proof_core.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using in PA.add_clause lits pr @@ -487,12 +396,12 @@ module Make (A : ARG) = (* : S with module A = A *) struct let simplify (self : state) (_recurse : _) (t : Term.t) : (Term.t * Proof_step.id Iter.t) option = let proof_eq t u = - Pr.add_step self.proof + Proof_trace.add_step self.proof @@ A.lemma_lra (Iter.return (Lit.atom (Term.eq self.tst t u))) in let proof_bool t ~sign:b = let lit = Lit.atom ~sign:b t in - Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) + Proof_trace.add_step self.proof @@ A.lemma_lra (Iter.return lit) in match A.view_as_lra t with @@ -557,7 +466,9 @@ module Make (A : ARG) = (* : S with module A = A *) struct |> CCList.flat_map (Tag.to_lits si) |> List.rev_map Lit.neg in - let pr = Pr.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) in + let pr = + Proof_trace.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) + in SI.raise_conflict si acts confl pr let on_propagate_ si acts lit ~reason = @@ -567,7 +478,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct SI.propagate si acts lit ~reason:(fun () -> let lits = CCList.flat_map (Tag.to_lits si) reason in let pr = - Pr.add_step (SI.proof si) + Proof_trace.add_step (SI.proof si) @@ A.lemma_lra Iter.(cons lit (of_list lits)) in CCList.flat_map (Tag.to_lits si) reason, pr) @@ -613,7 +524,9 @@ module Make (A : ARG) = (* : S with module A = A *) struct if A.Q.(le_const <> zero) then ( (* [c=0] when [c] is not 0 *) let lit = Lit.atom ~sign:false @@ Term.eq self.tst t1 t2 in - let pr = Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) in + let pr = + Proof_trace.add_step self.proof @@ A.lemma_lra (Iter.return lit) + in SI.add_clause_permanent si acts [ lit ] pr ) ) else ( @@ -808,3 +721,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct SMT.Solver.mk_theory ~name:"th-lra" ~create_and_setup ~push_level ~pop_levels () end + +let theory (module A : ARG) : SMT.theory = + let module M = Make (A) in + M.theory diff --git a/src/th-lra/sidekick_arith_lra.mli b/src/th-lra/sidekick_arith_lra.mli new file mode 100644 index 00000000..fdb34b33 --- /dev/null +++ b/src/th-lra/sidekick_arith_lra.mli @@ -0,0 +1,26 @@ +(** Linear Rational Arithmetic *) + +module Intf = Intf +open Intf + +module type ARG = Intf.ARG + +(* TODO + type state + + val k_state : state SMT.Registry.key + (** Key to access the state from outside, + available when the theory has been setup *) + + val create : (module ARG) -> ?stat:Stat.t -> SMT.Solver_internal.t -> state + + (* TODO: be able to declare some variables as ints *) + + (* + val simplex : state -> Simplex.t + *) + + val theory_of_state : state -> SMT.Theory.t +*) + +val theory : (module ARG) -> SMT.Theory.t From 0ff5ac9a3f819109754207e1fc581e577f7fa499 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:03:57 -0400 Subject: [PATCH 055/174] refactor(th-lra): rename to th-lra --- src/th-lra/dune | 4 ++-- src/th-lra/{sidekick_arith_lra.ml => sidekick_th_lra.ml} | 0 src/th-lra/{sidekick_arith_lra.mli => sidekick_th_lra.mli} | 0 3 files changed, 2 insertions(+), 2 deletions(-) rename src/th-lra/{sidekick_arith_lra.ml => sidekick_th_lra.ml} (100%) rename src/th-lra/{sidekick_arith_lra.mli => sidekick_th_lra.mli} (100%) diff --git a/src/th-lra/dune b/src/th-lra/dune index 9b4b555e..ff4f18bf 100644 --- a/src/th-lra/dune +++ b/src/th-lra/dune @@ -1,6 +1,6 @@ (library - (name sidekick_arith_lra) - (public_name sidekick.arith-lra) + (name sidekick_th_lra) + (public_name sidekick.th-lra) (synopsis "Solver for LRA (real arithmetic)") (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util) (libraries containers sidekick.arith sidekick.simplex sidekick.cc diff --git a/src/th-lra/sidekick_arith_lra.ml b/src/th-lra/sidekick_th_lra.ml similarity index 100% rename from src/th-lra/sidekick_arith_lra.ml rename to src/th-lra/sidekick_th_lra.ml diff --git a/src/th-lra/sidekick_arith_lra.mli b/src/th-lra/sidekick_th_lra.mli similarity index 100% rename from src/th-lra/sidekick_arith_lra.mli rename to src/th-lra/sidekick_th_lra.mli From 36204c5e5efa7d8329781e2826fcd917d9bc3619 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:04:49 -0400 Subject: [PATCH 056/174] refactor some more --- src/algos/lra/dune | 7 - src/algos/lra/sidekick_arith_lra.ml | 819 ------------------ src/core-logic/t_builtins.ml | 6 + src/core-logic/t_builtins.mli | 2 + src/sigs/smt/Sidekick_sigs_smt.ml | 606 ------------- src/sigs/smt/dune | 8 - src/smt-solver/Sidekick_smt_solver.ml | 1156 ------------------------- src/smt-solver/dune | 6 - src/smt-solver/th_key.ml.bak | 145 ---- src/smt/Sidekick_smt_solver.ml | 5 +- src/th-cstor/Sidekick_th_cstor.mli | 13 + 11 files changed, 25 insertions(+), 2748 deletions(-) delete mode 100644 src/algos/lra/dune delete mode 100644 src/algos/lra/sidekick_arith_lra.ml delete mode 100644 src/sigs/smt/Sidekick_sigs_smt.ml delete mode 100644 src/sigs/smt/dune delete mode 100644 src/smt-solver/Sidekick_smt_solver.ml delete mode 100644 src/smt-solver/dune delete mode 100644 src/smt-solver/th_key.ml.bak create mode 100644 src/th-cstor/Sidekick_th_cstor.mli diff --git a/src/algos/lra/dune b/src/algos/lra/dune deleted file mode 100644 index 3e1f839c..00000000 --- a/src/algos/lra/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name sidekick_arith_lra) - (public_name sidekick.arith-lra) - (synopsis "Solver for LRA (real arithmetic)") - (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util) - (libraries containers sidekick.sigs.smt sidekick.arith sidekick.simplex - sidekick.cc.plugin)) diff --git a/src/algos/lra/sidekick_arith_lra.ml b/src/algos/lra/sidekick_arith_lra.ml deleted file mode 100644 index ee3b990a..00000000 --- a/src/algos/lra/sidekick_arith_lra.ml +++ /dev/null @@ -1,819 +0,0 @@ -(** Linear Rational Arithmetic *) - -(* Reference: - http://smtlib.cs.uiowa.edu/logics-all.shtml#QF_LRA *) - -open Sidekick_sigs_smt -module Predicate = Sidekick_simplex.Predicate -module Linear_expr = Sidekick_simplex.Linear_expr -module Linear_expr_intf = Sidekick_simplex.Linear_expr_intf - -module type INT = Sidekick_arith.INT -module type RATIONAL = Sidekick_arith.RATIONAL - -module S_op = Sidekick_simplex.Op - -type pred = Linear_expr_intf.bool_op = Leq | Geq | Lt | Gt | Eq | Neq -type op = Linear_expr_intf.op = Plus | Minus - -type ('num, 'a) lra_view = - | LRA_pred of pred * 'a * 'a - | LRA_op of op * 'a * 'a - | LRA_mult of 'num * 'a - | LRA_const of 'num - | LRA_other of 'a - -let map_view f (l : _ lra_view) : _ lra_view = - match l with - | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) - | LRA_op (p, a, b) -> LRA_op (p, f a, f b) - | LRA_mult (n, a) -> LRA_mult (n, f a) - | LRA_const q -> LRA_const q - | LRA_other x -> LRA_other (f x) - -module type ARG = sig - module S : SOLVER - module Z : INT - module Q : RATIONAL with type bigint = Z.t - - type term = S.T.Term.t - type ty = S.T.Ty.t - - val view_as_lra : term -> (Q.t, term) lra_view - (** Project the term into the theory view *) - - val mk_bool : S.T.Term.store -> bool -> term - - val mk_lra : S.T.Term.store -> (Q.t, term) lra_view -> term - (** Make a term from the given theory view *) - - val ty_lra : S.T.Term.store -> ty - - val mk_eq : S.T.Term.store -> term -> term -> term - (** syntactic equality *) - - val has_ty_real : term -> bool - (** Does this term have the type [Real] *) - - val lemma_lra : S.Lit.t Iter.t -> S.Proof_trace.A.rule - - module Gensym : sig - type t - - val create : S.T.Term.store -> t - val tst : t -> S.T.Term.store - val copy : t -> t - - val fresh_term : t -> pre:string -> S.T.Ty.t -> term - (** Make a fresh term of the given type *) - end -end - -module type S = sig - module A : ARG - - (* - module SimpVar : Sidekick_simplex.VAR with type lit = A.S.Lit.t - module LE_ : Linear_expr_intf.S with module Var = SimpVar - module LE = LE_.Expr - *) - - module SimpSolver : Sidekick_simplex.S - (** Simplexe *) - - type state - - val create : ?stat:Stat.t -> A.S.Solver_internal.t -> state - - (* TODO: be able to declare some variables as ints *) - - (* - val simplex : state -> Simplex.t - *) - - val k_state : state A.S.Solver_internal.Registry.key - (** Key to access the state from outside, - available when the theory has been setup *) - - val theory : A.S.theory -end - -module Make (A : ARG) : S with module A = A = struct - module A = A - module Ty = A.S.T.Ty - module T = A.S.T.Term - module Lit = A.S.Solver_internal.Lit - module SI = A.S.Solver_internal - module N = SI.CC.E_node - - open struct - module Pr = SI.Proof_trace - end - - module Tag = struct - type t = Lit of Lit.t | CC_eq of N.t * N.t - - let pp out = function - | Lit l -> Fmt.fprintf out "(@[lit %a@])" Lit.pp l - | CC_eq (n1, n2) -> Fmt.fprintf out "(@[cc-eq@ %a@ %a@])" N.pp n1 N.pp n2 - - let to_lits si = function - | Lit l -> [ l ] - | CC_eq (n1, n2) -> - let r = SI.CC.explain_eq (SI.cc si) n1 n2 in - (* FIXME - assert (not (SI.CC.Resolved_expl.is_semantic r)); - *) - r.lits - end - - module SimpVar : Linear_expr.VAR with type t = A.term and type lit = Tag.t = - struct - type t = A.term - - let pp = A.S.T.Term.pp - let compare = A.S.T.Term.compare - - type lit = Tag.t - - let pp_lit = Tag.pp - - let not_lit = function - | Tag.Lit l -> Some (Tag.Lit (Lit.neg l)) - | _ -> None - end - - module LE_ = Linear_expr.Make (A.Q) (SimpVar) - module LE = LE_.Expr - - module SimpSolver = Sidekick_simplex.Make (struct - module Z = A.Z - module Q = A.Q - module Var = SimpVar - - let mk_lit _ _ _ = assert false - end) - - module Subst = SimpSolver.Subst - module Comb_map = CCMap.Make (LE_.Comb) - - (* turn the term into a linear expression. Apply [f] on leaves. *) - let rec as_linexp (t : T.t) : LE.t = - let open LE.Infix in - match A.view_as_lra t with - | LRA_other _ -> LE.monomial1 t - | LRA_pred _ -> - Error.errorf "type error: in linexp, LRA predicate %a" T.pp t - | LRA_op (op, t1, t2) -> - let t1 = as_linexp t1 in - let t2 = as_linexp t2 in - (match op with - | Plus -> t1 + t2 - | Minus -> t1 - t2) - | LRA_mult (n, x) -> - let t = as_linexp x in - LE.(n * t) - | LRA_const q -> LE.of_const q - - (* monoid to track linear expressions in congruence classes, to clash on merge *) - module Monoid_exprs = struct - module CC = SI.CC - - let name = "lra.const" - - type single = { le: LE.t; n: N.t } - type t = single list - - let pp_single out { le = _; n } = N.pp out n - - let pp out self = - match self with - | [] -> () - | [ x ] -> pp_single out x - | _ -> Fmt.fprintf out "(@[exprs@ %a@])" (Util.pp_list pp_single) self - - let of_term _cc n t = - match A.view_as_lra t with - | LRA_const _ | LRA_op _ | LRA_mult _ -> - let le = as_linexp t in - Some [ { n; le } ], [] - | LRA_other _ | LRA_pred _ -> None, [] - - exception Confl of SI.CC.Expl.t - - (* merge lists. If two linear expressions equal up to a constant are - merged, conflict. *) - let merge _cc n1 l1 n2 l2 expl_12 : _ result = - try - let i = Iter.(product (of_list l1) (of_list l2)) in - i (fun (s1, s2) -> - let le = LE.(s1.le - s2.le) in - if LE.is_const le && not (LE.is_zero le) then ( - (* conflict: [le+c = le + d] is impossible *) - let expl = - let open SI.CC.Expl in - mk_list [ mk_merge s1.n n1; mk_merge s2.n n2; expl_12 ] - in - raise (Confl expl) - )); - Ok (List.rev_append l1 l2, []) - with Confl expl -> Error (SI.CC.Handler_action.Conflict expl) - end - - module ST_exprs = Sidekick_cc_plugin.Make (Monoid_exprs) - - type state = { - tst: T.store; - ty_st: Ty.store; - proof: SI.Proof_trace.t; - gensym: A.Gensym.t; - in_model: unit T.Tbl.t; (* terms to add to model *) - encoded_eqs: unit T.Tbl.t; - (* [a=b] gets clause [a = b <=> (a >= b /\ a <= b)] *) - needs_th_combination: unit T.Tbl.t; - (* terms that require theory combination *) - simp_preds: (T.t * S_op.t * A.Q.t) T.Tbl.t; - (* term -> its simplex meaning *) - simp_defined: LE.t T.Tbl.t; - (* (rational) terms that are equal to a linexp *) - st_exprs: ST_exprs.t; - mutable encoded_le: T.t Comb_map.t; (* [le] -> var encoding [le] *) - simplex: SimpSolver.t; - mutable last_res: SimpSolver.result option; - } - - let create ?(stat = Stat.create ()) (si : SI.t) : state = - let proof = SI.proof si in - let tst = SI.tst si in - let ty_st = SI.ty_st si in - { - tst; - ty_st; - proof; - in_model = T.Tbl.create 8; - st_exprs = ST_exprs.create_and_setup (SI.cc si); - gensym = A.Gensym.create tst; - simp_preds = T.Tbl.create 32; - simp_defined = T.Tbl.create 16; - encoded_eqs = T.Tbl.create 8; - needs_th_combination = T.Tbl.create 8; - encoded_le = Comb_map.empty; - simplex = SimpSolver.create ~stat (); - last_res = None; - } - - let[@inline] reset_res_ (self : state) : unit = self.last_res <- None - let[@inline] n_levels self : int = ST_exprs.n_levels self.st_exprs - - let push_level self = - ST_exprs.push_level self.st_exprs; - SimpSolver.push_level self.simplex; - () - - let pop_levels self n = - reset_res_ self; - ST_exprs.pop_levels self.st_exprs n; - SimpSolver.pop_levels self.simplex n; - () - - let fresh_term self ~pre ty = A.Gensym.fresh_term self.gensym ~pre ty - - let fresh_lit (self : state) ~mk_lit ~pre : Lit.t = - let t = fresh_term ~pre self (Ty.bool self.ty_st) in - mk_lit t - - let pp_pred_def out (p, l1, l2) : unit = - Fmt.fprintf out "(@[%a@ :l1 %a@ :l2 %a@])" Predicate.pp p LE.pp l1 LE.pp l2 - - let[@inline] t_const self n : T.t = A.mk_lra self.tst (LRA_const n) - let[@inline] t_zero self : T.t = t_const self A.Q.zero - - let[@inline] is_const_ t = - match A.view_as_lra t with - | LRA_const _ -> true - | _ -> false - - let[@inline] as_const_ t = - match A.view_as_lra t with - | LRA_const n -> Some n - | _ -> None - - let[@inline] is_zero t = - match A.view_as_lra t with - | LRA_const n -> A.Q.(n = zero) - | _ -> false - - let t_of_comb (self : state) (comb : LE_.Comb.t) ~(init : T.t) : T.t = - let[@inline] ( + ) a b = A.mk_lra self.tst (LRA_op (Plus, a, b)) in - let[@inline] ( * ) a b = A.mk_lra self.tst (LRA_mult (a, b)) in - - let cur = ref init in - LE_.Comb.iter - (fun t c -> - let tc = - if A.Q.(c = of_int 1) then - t - else - c * t - in - cur := - if is_zero !cur then - tc - else - !cur + tc) - comb; - !cur - - (* encode back into a term *) - let t_of_linexp (self : state) (le : LE.t) : T.t = - let comb = LE.comb le in - let const = LE.const le in - t_of_comb self comb ~init:(A.mk_lra self.tst (LRA_const const)) - - (* return a variable that is equal to [le_comb] in the simplex. *) - let var_encoding_comb ~pre self (le_comb : LE_.Comb.t) : T.t = - assert (not (LE_.Comb.is_empty le_comb)); - match LE_.Comb.as_singleton le_comb with - | Some (c, x) when A.Q.(c = one) -> x (* trivial linexp *) - | _ -> - (match Comb_map.find le_comb self.encoded_le with - | x -> x (* already encoded that *) - | exception Not_found -> - (* new variable to represent [le_comb] *) - let proxy = fresh_term self ~pre (A.ty_lra self.tst) in - (* TODO: define proxy *) - self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; - Log.debugf 50 (fun k -> - k "(@[lra.encode-linexp@ `@[%a@]`@ :into-var %a@])" LE_.Comb.pp - le_comb T.pp proxy); - - LE_.Comb.iter (fun v _ -> SimpSolver.add_var self.simplex v) le_comb; - SimpSolver.define self.simplex proxy (LE_.Comb.to_list le_comb); - proxy) - - let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = - let pr = Pr.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in - let pr = - match using with - | None -> pr - | Some using -> - Pr.add_step PA.proof - @@ SI.P_core_rules.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using - in - PA.add_clause lits pr - - let s_op_of_pred pred : S_op.t = - match pred with - | Eq | Neq -> assert false (* unreachable *) - | Leq -> S_op.Leq - | Lt -> S_op.Lt - | Geq -> S_op.Geq - | Gt -> S_op.Gt - - (* TODO: refactor that and {!var_encoding_comb} *) - (* turn a linear expression into a single constant and a coeff. - This might define a side variable in the simplex. *) - let le_comb_to_singleton_ (self : state) (le_comb : LE_.Comb.t) : T.t * A.Q.t - = - match LE_.Comb.as_singleton le_comb with - | Some (coeff, v) -> v, coeff - | None -> - (* non trivial linexp, give it a fresh name in the simplex *) - (match Comb_map.get le_comb self.encoded_le with - | Some x -> x, A.Q.one (* already encoded that *) - | None -> - let proxy = fresh_term self ~pre:"_le_comb" (A.ty_lra self.tst) in - - self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; - LE_.Comb.iter (fun v _ -> SimpSolver.add_var self.simplex v) le_comb; - SimpSolver.define self.simplex proxy (LE_.Comb.to_list le_comb); - - Log.debugf 50 (fun k -> - k "(@[lra.encode-linexp.to-term@ `@[%a@]`@ :new-t %a@])" LE_.Comb.pp - le_comb T.pp proxy); - - proxy, A.Q.one) - - (* look for subterms of type Real, for they will need theory combination *) - let on_subterm (self : state) (t : T.t) : unit = - Log.debugf 50 (fun k -> k "(@[lra.cc-on-subterm@ %a@])" T.pp t); - match A.view_as_lra t with - | LRA_other _ when not (A.has_ty_real t) -> () - | LRA_pred _ | LRA_const _ -> () - | LRA_op _ | LRA_other _ | LRA_mult _ -> - if not (T.Tbl.mem self.needs_th_combination t) then ( - Log.debugf 5 (fun k -> k "(@[lra.needs-th-combination@ %a@])" T.pp t); - T.Tbl.add self.needs_th_combination t () - ) - - (* preprocess linear expressions away *) - let preproc_lra (self : state) si (module PA : SI.PREPROCESS_ACTS) (t : T.t) : - unit = - Log.debugf 50 (fun k -> k "(@[lra.preprocess@ %a@])" T.pp t); - let tst = SI.tst si in - - (* tell the CC this term exists *) - let declare_term_to_cc ~sub t = - Log.debugf 50 (fun k -> k "(@[lra.declare-term-to-cc@ %a@])" T.pp t); - ignore (SI.CC.add_term (SI.cc si) t : N.t); - if sub then on_subterm self t - in - - match A.view_as_lra t with - | _ when T.Tbl.mem self.simp_preds t -> - () (* already turned into a simplex predicate *) - | LRA_pred (((Eq | Neq) as pred), t1, t2) when is_const_ t1 && is_const_ t2 - -> - (* comparison of constants: can decide right now *) - (match A.view_as_lra t1, A.view_as_lra t2 with - | LRA_const n1, LRA_const n2 -> - let is_eq = pred = Eq in - let t_is_true = is_eq = A.Q.equal n1 n2 in - let lit = PA.mk_lit ~sign:t_is_true t in - add_clause_lra_ (module PA) [ lit ] - | _ -> assert false) - | LRA_pred ((Eq | Neq), t1, t2) -> - (* equality: just punt to [t1 = t2 <=> (t1 <= t2 /\ t1 >= t2)] *) - let t, _ = T.abs tst t in - if not (T.Tbl.mem self.encoded_eqs t) then ( - let u1 = A.mk_lra tst (LRA_pred (Leq, t1, t2)) in - let u2 = A.mk_lra tst (LRA_pred (Geq, t1, t2)) in - - T.Tbl.add self.encoded_eqs t (); - - (* encode [t <=> (u1 /\ u2)] *) - let lit_t = PA.mk_lit t in - let lit_u1 = PA.mk_lit u1 in - let lit_u2 = PA.mk_lit u2 in - add_clause_lra_ (module PA) [ SI.Lit.neg lit_t; lit_u1 ]; - add_clause_lra_ (module PA) [ SI.Lit.neg lit_t; lit_u2 ]; - add_clause_lra_ - (module PA) - [ SI.Lit.neg lit_u1; SI.Lit.neg lit_u2; lit_t ] - ) - | LRA_pred (pred, t1, t2) -> - let l1 = as_linexp t1 in - let l2 = as_linexp t2 in - let le = LE.(l1 - l2) in - let le_comb, le_const = LE.comb le, LE.const le in - let le_const = A.Q.neg le_const in - let op = s_op_of_pred pred in - - (* now we have [le_comb op le_const] *) - - (* obtain a single variable for the linear combination *) - let v, c_v = le_comb_to_singleton_ self le_comb in - declare_term_to_cc ~sub:false v; - LE_.Comb.iter (fun v _ -> declare_term_to_cc ~sub:true v) le_comb; - - (* turn into simplex constraint. For example, - [c . v <= const] becomes a direct simplex constraint [v <= const/c] - (beware the sign) *) - - (* make sure to swap sides if multiplying with a negative coeff *) - let q = A.Q.(le_const / c_v) in - let op = - if A.Q.(c_v < zero) then - S_op.neg_sign op - else - op - in - - let lit = PA.mk_lit t in - let constr = SimpSolver.Constraint.mk v op q in - SimpSolver.declare_bound self.simplex constr (Tag.Lit lit); - T.Tbl.add self.simp_preds t (v, op, q); - - Log.debugf 50 (fun k -> - k "(@[lra.preproc@ :t %a@ :to-constr %a@])" T.pp t - SimpSolver.Constraint.pp constr) - | LRA_op _ | LRA_mult _ -> - if not (T.Tbl.mem self.simp_defined t) then ( - (* we define these terms so their value in the model make sense *) - let le = as_linexp t in - T.Tbl.add self.simp_defined t le - ) - | LRA_const _n -> () - | LRA_other t when A.has_ty_real t -> () - | LRA_other _ -> () - - let simplify (self : state) (_recurse : _) (t : T.t) : - (T.t * SI.step_id Iter.t) option = - let proof_eq t u = - Pr.add_step self.proof - @@ A.lemma_lra (Iter.return (SI.Lit.atom self.tst (A.mk_eq self.tst t u))) - in - let proof_bool t ~sign:b = - let lit = SI.Lit.atom ~sign:b self.tst t in - Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) - in - - match A.view_as_lra t with - | LRA_op _ | LRA_mult _ -> - let le = as_linexp t in - if LE.is_const le then ( - let c = LE.const le in - let u = A.mk_lra self.tst (LRA_const c) in - let pr = proof_eq t u in - Some (u, Iter.return pr) - ) else ( - let u = t_of_linexp self le in - if t != u then ( - let pr = proof_eq t u in - Some (u, Iter.return pr) - ) else - None - ) - | LRA_pred ((Eq | Neq), _, _) -> - (* never change equalities, it can affect theory combination *) - None - | LRA_pred (pred, l1, l2) -> - let le = LE.(as_linexp l1 - as_linexp l2) in - - if LE.is_const le then ( - let c = LE.const le in - let is_true = - match pred with - | Leq -> A.Q.(c <= zero) - | Geq -> A.Q.(c >= zero) - | Lt -> A.Q.(c < zero) - | Gt -> A.Q.(c > zero) - | Eq -> A.Q.(c = zero) - | Neq -> A.Q.(c <> zero) - in - let u = A.mk_bool self.tst is_true in - let pr = proof_bool t ~sign:is_true in - Some (u, Iter.return pr) - ) else ( - (* le <= const *) - let u = - A.mk_lra self.tst - (LRA_pred - ( pred, - t_of_comb self (LE.comb le) ~init:(t_zero self), - t_const self (A.Q.neg @@ LE.const le) )) - in - - if t != u then ( - let pr = proof_eq t u in - Some (u, Iter.return pr) - ) else - None - ) - | _ -> None - - (* raise conflict from certificate *) - let fail_with_cert si acts cert : 'a = - Profile.with1 "lra.simplex.check-cert" SimpSolver._check_cert cert; - let confl = - SimpSolver.Unsat_cert.lits cert - |> CCList.flat_map (Tag.to_lits si) - |> List.rev_map SI.Lit.neg - in - let pr = Pr.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) in - SI.raise_conflict si acts confl pr - - let on_propagate_ si acts lit ~reason = - match lit with - | Tag.Lit lit -> - (* TODO: more detailed proof certificate *) - SI.propagate si acts lit ~reason:(fun () -> - let lits = CCList.flat_map (Tag.to_lits si) reason in - let pr = - Pr.add_step (SI.proof si) - @@ A.lemma_lra Iter.(cons lit (of_list lits)) - in - CCList.flat_map (Tag.to_lits si) reason, pr) - | _ -> () - - (** Check satisfiability of simplex, and sets [self.last_res] *) - let check_simplex_ self si acts : SimpSolver.Subst.t = - Log.debugf 5 (fun k -> - k "(@[lra.check-simplex@ :n-vars %d :n-rows %d@])" - (SimpSolver.n_vars self.simplex) - (SimpSolver.n_rows self.simplex)); - let res = - Profile.with_ "lra.simplex.solve" @@ fun () -> - SimpSolver.check self.simplex ~on_propagate:(on_propagate_ si acts) - in - Log.debug 5 "(lra.check-simplex.done)"; - self.last_res <- Some res; - match res with - | SimpSolver.Sat m -> m - | SimpSolver.Unsat cert -> - Log.debugf 10 (fun k -> - k "(@[lra.check.unsat@ :cert %a@])" SimpSolver.Unsat_cert.pp cert); - fail_with_cert si acts cert - - (* TODO: trivial propagations *) - - let add_local_eq_t (self : state) si acts t1 t2 ~tag : unit = - Log.debugf 20 (fun k -> k "(@[lra.add-local-eq@ %a@ %a@])" T.pp t1 T.pp t2); - reset_res_ self; - let t1, t2 = - if T.compare t1 t2 > 0 then - t2, t1 - else - t1, t2 - in - - let le = LE.(as_linexp t1 - as_linexp t2) in - let le_comb, le_const = LE.comb le, LE.const le in - let le_const = A.Q.neg le_const in - - if LE_.Comb.is_empty le_comb then ( - if A.Q.(le_const <> zero) then ( - (* [c=0] when [c] is not 0 *) - let lit = SI.Lit.neg @@ SI.mk_lit si acts @@ A.mk_eq self.tst t1 t2 in - let pr = Pr.add_step self.proof @@ A.lemma_lra (Iter.return lit) in - SI.add_clause_permanent si acts [ lit ] pr - ) - ) else ( - let v = var_encoding_comb ~pre:"le_local_eq" self le_comb in - try - let c1 = SimpSolver.Constraint.geq v le_const in - SimpSolver.add_constraint self.simplex c1 tag - ~on_propagate:(on_propagate_ si acts); - let c2 = SimpSolver.Constraint.leq v le_const in - SimpSolver.add_constraint self.simplex c2 tag - ~on_propagate:(on_propagate_ si acts) - with SimpSolver.E_unsat cert -> fail_with_cert si acts cert - ) - - let add_local_eq (self : state) si acts n1 n2 : unit = - let t1 = N.term n1 in - let t2 = N.term n2 in - add_local_eq_t self si acts t1 t2 ~tag:(Tag.CC_eq (n1, n2)) - - (* evaluate a term directly, as a variable *) - let eval_in_subst_ subst t = - match A.view_as_lra t with - | LRA_const n -> n - | _ -> Subst.eval subst t |> Option.value ~default:A.Q.zero - - (* evaluate a linear expression *) - let eval_le_in_subst_ subst (le : LE.t) = LE.eval (eval_in_subst_ subst) le - - (* FIXME: rename, this is more "provide_model_to_cc" *) - let do_th_combination (self : state) _si _acts : _ Iter.t = - Log.debug 1 "(lra.do-th-combinations)"; - let model = - match self.last_res with - | Some (SimpSolver.Sat m) -> m - | _ -> assert false - in - - let vals = Subst.to_iter model |> T.Tbl.of_iter in - - (* also include terms that occur under function symbols, if they're - not in the model already *) - T.Tbl.iter - (fun t () -> - if not (T.Tbl.mem vals t) then ( - let v = eval_in_subst_ model t in - T.Tbl.add vals t v - )) - self.needs_th_combination; - - (* also consider subterms that are linear expressions, - and evaluate them using the value of each variable - in that linear expression. For example a term [a + 2b] - is evaluated as [eval(a) + 2 × eval(b)]. *) - T.Tbl.iter - (fun t le -> - if not (T.Tbl.mem vals t) then ( - let v = eval_le_in_subst_ model le in - T.Tbl.add vals t v - )) - self.simp_defined; - - (* return whole model *) - T.Tbl.to_iter vals |> Iter.map (fun (t, v) -> t, t_const self v) - - (* partial checks is where we add literals from the trail to the - simplex. *) - let partial_check_ self si acts trail : unit = - Profile.with_ "lra.partial-check" @@ fun () -> - reset_res_ self; - let changed = ref false in - - let examine_lit lit = - let sign = SI.Lit.sign lit in - let lit_t = SI.Lit.term lit in - match T.Tbl.get self.simp_preds lit_t, A.view_as_lra lit_t with - | Some (v, op, q), _ -> - Log.debugf 50 (fun k -> - k "(@[lra.partial-check.add@ :lit %a@ :lit-t %a@])" SI.Lit.pp lit - T.pp lit_t); - - (* need to account for the literal's sign *) - let op = - if sign then - op - else - S_op.not_ op - in - - (* assert new constraint to Simplex *) - let constr = SimpSolver.Constraint.mk v op q in - Log.debugf 10 (fun k -> - k "(@[lra.partial-check.assert@ %a@])" SimpSolver.Constraint.pp - constr); - changed := true; - (try - SimpSolver.add_var self.simplex v; - SimpSolver.add_constraint self.simplex constr (Tag.Lit lit) - ~on_propagate:(on_propagate_ si acts) - with SimpSolver.E_unsat cert -> - Log.debugf 10 (fun k -> - k "(@[lra.partial-check.unsat@ :cert %a@])" - SimpSolver.Unsat_cert.pp cert); - fail_with_cert si acts cert) - | None, LRA_pred (Eq, t1, t2) when sign -> - add_local_eq_t self si acts t1 t2 ~tag:(Tag.Lit lit) - | None, LRA_pred (Neq, t1, t2) when not sign -> - add_local_eq_t self si acts t1 t2 ~tag:(Tag.Lit lit) - | None, _ -> () - in - - Iter.iter examine_lit trail; - - (* incremental check *) - if !changed then ignore (check_simplex_ self si acts : SimpSolver.Subst.t); - () - - let final_check_ (self : state) si (acts : SI.theory_actions) - (_trail : _ Iter.t) : unit = - Log.debug 5 "(th-lra.final-check)"; - Profile.with_ "lra.final-check" @@ fun () -> - reset_res_ self; - - (* add equalities between linear-expressions merged in the congruence closure *) - ST_exprs.iter_all self.st_exprs (fun (_, l) -> - Iter.diagonal_l l (fun (s1, s2) -> add_local_eq self si acts s1.n s2.n)); - - (* TODO: jiggle model to reduce the number of variables that - have the same value *) - let model = check_simplex_ self si acts in - Log.debugf 20 (fun k -> k "(@[lra.model@ %a@])" SimpSolver.Subst.pp model); - Log.debug 5 "(lra: solver returns SAT)"; - () - - (* help generating model *) - let model_ask_ (self : state) ~recurse:_ _si n : _ option = - let t = N.term n in - match self.last_res with - | Some (SimpSolver.Sat m) -> - Log.debugf 50 (fun k -> k "(@[lra.model-ask@ %a@])" T.pp t); - (match A.view_as_lra t with - | LRA_const n -> Some n (* always eval constants to themselves *) - | _ -> SimpSolver.V_map.get t m) - |> Option.map (t_const self) - | _ -> None - - (* help generating model *) - let model_complete_ (self : state) _si ~add : unit = - Log.debugf 30 (fun k -> k "(lra.model-complete)"); - match self.last_res with - | Some (SimpSolver.Sat m) when T.Tbl.length self.in_model > 0 -> - Log.debugf 50 (fun k -> - k "(@[lra.in_model@ %a@])" (Util.pp_iter T.pp) - (T.Tbl.keys self.in_model)); - - let add_t t () = - match SimpSolver.V_map.get t m with - | None -> () - | Some u -> add t (t_const self u) - in - T.Tbl.iter add_t self.in_model - | _ -> () - - let k_state = SI.Registry.create_key () - - let create_and_setup si = - Log.debug 2 "(th-lra.setup)"; - let stat = SI.stats si in - let st = create ~stat si in - SI.Registry.set (SI.registry si) k_state st; - SI.add_simplifier si (simplify st); - SI.on_preprocess si (preproc_lra st); - SI.on_final_check si (final_check_ st); - SI.on_partial_check si (partial_check_ st); - SI.on_model si ~ask:(model_ask_ st) ~complete:(model_complete_ st); - SI.on_cc_is_subterm si (fun (_, _, t) -> - on_subterm st t; - []); - SI.on_cc_pre_merge si (fun (_cc, n1, n2, expl) -> - match as_const_ (N.term n1), as_const_ (N.term n2) with - | Some q1, Some q2 when A.Q.(q1 <> q2) -> - (* classes with incompatible constants *) - Log.debugf 30 (fun k -> - k "(@[lra.merge-incompatible-consts@ %a@ %a@])" N.pp n1 N.pp n2); - Error (SI.CC.Handler_action.Conflict expl) - | _ -> Ok []); - SI.on_th_combination si (do_th_combination st); - st - - let theory = - A.S.mk_theory ~name:"th-lra" ~create_and_setup ~push_level ~pop_levels () -end diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml index 3bc09bd0..b5b1e923 100644 --- a/src/core-logic/t_builtins.ml +++ b/src/core-logic/t_builtins.ml @@ -88,3 +88,9 @@ let rec abs t = let sign, v = abs u in Stdlib.not sign, v | _ -> true, t + +let as_bool_val t = + match Term.view t with + | Term.E_const { c_view = C_true; _ } -> Some true + | Term.E_const { c_view = C_false; _ } -> Some false + | _ -> None diff --git a/src/core-logic/t_builtins.mli b/src/core-logic/t_builtins.mli index 8ae490ee..5ffd27b3 100644 --- a/src/core-logic/t_builtins.mli +++ b/src/core-logic/t_builtins.mli @@ -31,3 +31,5 @@ val abs : t -> bool * t The idea is that we want to turn [not a] into [(false, a)], or [(a != b)] into [(false, a=b)]. For terms without a negation this should return [(true, t)]. *) + +val as_bool_val : t -> bool option diff --git a/src/sigs/smt/Sidekick_sigs_smt.ml b/src/sigs/smt/Sidekick_sigs_smt.ml deleted file mode 100644 index ddeb5b71..00000000 --- a/src/sigs/smt/Sidekick_sigs_smt.ml +++ /dev/null @@ -1,606 +0,0 @@ -(** Signature for the main SMT solver types. - - Theories and concrete solvers rely on an environment that defines - several important types: - - - sorts - - terms (to represent logic expressions and formulas) - - a congruence closure instance - - a bridge to some SAT solver - - In this module we collect signatures defined elsewhere and define - the module types for the main SMT solver. -*) - -module type TERM = Sidekick_sigs_term.S -module type LIT = Sidekick_sigs_lit.S -module type PROOF_TRACE = Sidekick_sigs_proof_trace.S - -module type SAT_PROOF_RULES = Sidekick_sigs_proof_sat.S -(** Signature for SAT-solver proof emission. *) - -module type PROOF_CORE = Sidekick_sigs_proof_core.S -(** Proofs of unsatisfiability. *) - -(** Registry to extract values *) -module type REGISTRY = sig - type t - type 'a key - - val create_key : unit -> 'a key - (** Call this statically, typically at program initialization, for - each distinct key. *) - - val create : unit -> t - val get : t -> 'a key -> 'a option - val set : t -> 'a key -> 'a -> unit -end - -(** A view of the solver from a theory's point of view. - - Theories should interact with the solver via this module, to assert - new lemmas, propagate literals, access the congruence closure, etc. *) -module type SOLVER_INTERNAL = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - type ty = T.Ty.t - type term = T.Term.t - type value = T.Term.t - type lit = Lit.t - type term_store = T.Term.store - type ty_store = T.Ty.store - type clause_pool - type proof_trace = Proof_trace.t - type step_id = Proof_trace.A.step_id - - type t - (** {3 Main type for a solver} *) - - type solver = t - - val tst : t -> term_store - val ty_st : t -> ty_store - val stats : t -> Stat.t - - val proof : t -> proof_trace - (** Access the proof object *) - - (** {3 Registry} *) - - module Registry : REGISTRY - - val registry : t -> Registry.t - (** A solver contains a registry so that theories can share data *) - - (** {3 Exported Proof rules} *) - - module P_core_rules : - Sidekick_sigs_proof_core.S - with type rule = Proof_trace.A.rule - and type step_id = Proof_trace.A.step_id - and type term = term - and type lit = lit - - (** {3 Actions for the theories} *) - - type theory_actions - (** Handle that the theories can use to perform actions. *) - - (** {3 Congruence Closure} *) - - (** Congruence closure instance *) - module CC : - Sidekick_sigs_cc.S - with module T = T - and module Lit = Lit - and module Proof_trace = Proof_trace - - val cc : t -> CC.t - (** Congruence closure for this solver *) - - (** {3 Simplifiers} *) - - (* TODO: move into its own library *) - - (** Simplify terms *) - module Simplify : sig - type t - - val tst : t -> term_store - val ty_st : t -> ty_store - - val clear : t -> unit - (** Reset internal cache, etc. *) - - val proof : t -> proof_trace - (** Access proof *) - - type hook = t -> term -> (term * step_id Iter.t) option - (** Given a term, try to simplify it. Return [None] if it didn't change. - - A simple example could be a hook that takes a term [t], - and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, - returns [Some (const (x+y))], and [None] otherwise. - - The simplifier will take care of simplifying the resulting term further, - caching (so that work is not duplicated in subterms), etc. - *) - - val normalize : t -> term -> (term * step_id) option - (** Normalize a term using all the hooks. This performs - a fixpoint, i.e. it only stops when no hook applies anywhere inside - the term. *) - - val normalize_t : t -> term -> term * step_id option - (** Normalize a term using all the hooks, along with a proof that the - simplification is correct. - returns [t, ø] if no simplification occurred. *) - end - - type simplify_hook = Simplify.hook - - val add_simplifier : t -> Simplify.hook -> unit - (** Add a simplifier hook for preprocessing. *) - - val simplify_t : t -> term -> (term * step_id) option - (** Simplify input term, returns [Some u] if some - simplification occurred. *) - - val simp_t : t -> term -> term * step_id option - (** [simp_t si t] returns [u] even if no simplification occurred - (in which case [t == u] syntactically). - It emits [|- t=u]. - (see {!simplifier}) *) - - (** {3 Preprocessors} - These preprocessors turn mixed, raw literals (possibly simplified) into - literals suitable for reasoning. - Typically some clauses are also added to the solver. *) - - (* TODO: move into its own sig + library *) - module type PREPROCESS_ACTS = sig - val proof : proof_trace - - val mk_lit : ?sign:bool -> term -> lit - (** [mk_lit t] creates a new literal for a boolean term [t]. *) - - val add_clause : lit list -> step_id -> unit - (** pushes a new clause into the SAT solver. *) - - val add_lit : ?default_pol:bool -> lit -> unit - (** Ensure the literal will be decided/handled by the SAT solver. *) - end - - type preprocess_actions = (module PREPROCESS_ACTS) - (** Actions available to the preprocessor *) - - type preprocess_hook = t -> preprocess_actions -> term -> unit - (** Given a term, preprocess it. - - The idea is to add literals and clauses to help define the meaning of - the term, if needed. For example for boolean formulas, clauses - for their Tseitin encoding can be added, with the formula acting - as its own proxy symbol. - - @param preprocess_actions actions available during preprocessing. - *) - - val on_preprocess : t -> preprocess_hook -> unit - (** Add a hook that will be called when terms are preprocessed *) - - (** {3 hooks for the theory} *) - - val raise_conflict : t -> theory_actions -> lit list -> step_id -> 'a - (** Give a conflict clause to the solver *) - - val push_decision : t -> theory_actions -> lit -> unit - (** Ask the SAT solver to decide the given literal in an extension of the - current trail. This is useful for theory combination. - If the SAT solver backtracks, this (potential) decision is removed - and forgotten. *) - - val propagate : - t -> theory_actions -> lit -> reason:(unit -> lit list * step_id) -> unit - (** Propagate a boolean using a unit clause. - [expl => lit] must be a theory lemma, that is, a T-tautology *) - - val propagate_l : t -> theory_actions -> lit -> lit list -> step_id -> unit - (** Propagate a boolean using a unit clause. - [expl => lit] must be a theory lemma, that is, a T-tautology *) - - val add_clause_temp : t -> theory_actions -> lit list -> step_id -> unit - (** Add local clause to the SAT solver. This clause will be - removed when the solver backtracks. *) - - val add_clause_permanent : t -> theory_actions -> lit list -> step_id -> unit - (** Add toplevel clause to the SAT solver. This clause will - not be backtracked. *) - - val mk_lit : t -> theory_actions -> ?sign:bool -> term -> lit - (** Create a literal. This automatically preprocesses the term. *) - - val add_lit : t -> theory_actions -> ?default_pol:bool -> lit -> unit - (** Add the given literal to the SAT solver, so it gets assigned - a boolean value. - @param default_pol default polarity for the corresponding atom *) - - val add_lit_t : t -> theory_actions -> ?sign:bool -> term -> unit - (** Add the given (signed) bool term to the SAT solver, so it gets assigned - a boolean value *) - - val cc_find : t -> CC.E_node.t -> CC.E_node.t - (** Find representative of the node *) - - val cc_are_equal : t -> term -> term -> bool - (** Are these two terms equal in the congruence closure? *) - - val cc_resolve_expl : t -> CC.Expl.t -> lit list * step_id - - (* - val cc_raise_conflict_expl : t -> theory_actions -> CC.Expl.t -> 'a - (** Raise a conflict with the given congruence closure explanation. - it must be a theory tautology that [expl ==> absurd]. - To be used in theories. *) - - val cc_merge : - t -> theory_actions -> CC.E_node.t -> CC.E_node.t -> CC.Expl.t -> unit - (** Merge these two nodes in the congruence closure, given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val cc_merge_t : t -> theory_actions -> term -> term -> CC.Expl.t -> unit - (** Merge these two terms in the congruence closure, given this explanation. - See {!cc_merge} *) - *) - - val cc_add_term : t -> term -> CC.E_node.t - (** Add/retrieve congruence closure node for this term. - To be used in theories *) - - val cc_mem_term : t -> term -> bool - (** Return [true] if the term is explicitly in the congruence closure. - To be used in theories *) - - val on_cc_pre_merge : - t -> - (CC.t * CC.E_node.t * CC.E_node.t * CC.Expl.t -> - CC.Handler_action.or_conflict) -> - unit - (** Callback for when two classes containing data for this key are merged (called before) *) - - val on_cc_post_merge : - t -> (CC.t * CC.E_node.t * CC.E_node.t -> CC.Handler_action.t list) -> unit - (** Callback for when two classes containing data for this key are merged (called after)*) - - val on_cc_new_term : - t -> (CC.t * CC.E_node.t * term -> CC.Handler_action.t list) -> unit - (** Callback to add data on terms when they are added to the congruence - closure *) - - val on_cc_is_subterm : - t -> (CC.t * CC.E_node.t * term -> CC.Handler_action.t list) -> unit - (** Callback for when a term is a subterm of another term in the - congruence closure *) - - val on_cc_conflict : t -> (CC.ev_on_conflict -> unit) -> unit - (** Callback called on every CC conflict *) - - val on_cc_propagate : - t -> - (CC.t * lit * (unit -> lit list * step_id) -> CC.Handler_action.t list) -> - unit - (** Callback called on every CC propagation *) - - val on_partial_check : - t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit - (** Register callbacked to be called with the slice of literals - newly added on the trail. - - This is called very often and should be efficient. It doesn't have - to be complete, only correct. It's given only the slice of - the trail consisting in new literals. *) - - val on_final_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit - (** Register callback to be called during the final check. - - Must be complete (i.e. must raise a conflict if the set of literals is - not satisfiable) and can be expensive. The function - is given the whole trail. - *) - - val on_th_combination : - t -> (t -> theory_actions -> (term * value) Iter.t) -> unit - (** Add a hook called during theory combination. - The hook must return an iterator of pairs [(t, v)] - which mean that term [t] has value [v] in the model. - - Terms with the same value (according to {!Term.equal}) will be - merged in the CC; if two terms with different values are merged, - we get a semantic conflict and must pick another model. *) - - val declare_pb_is_incomplete : t -> unit - (** Declare that, in some theory, the problem is outside the logic fragment - that is decidable (e.g. if we meet proper NIA formulas). - The solver will not reply "SAT" from now on. *) - - (** {3 Model production} *) - - type model_ask_hook = - recurse:(t -> CC.E_node.t -> term) -> t -> CC.E_node.t -> term option - (** A model-production hook to query values from a theory. - - It takes the solver, a class, and returns - a term for this class. For example, an arithmetic theory - might detect that a class contains a numeric constant, and return - this constant as a model value. - - If no hook assigns a value to a class, a fake value is created for it. - *) - - type model_completion_hook = t -> add:(term -> term -> unit) -> unit - (** A model production hook, for the theory to add values. - The hook is given a [add] function to add bindings to the model. *) - - val on_model : - ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit - (** Add model production/completion hooks. *) -end - -(** User facing view of the solver. - - This is the solver a user of sidekick can see, after instantiating - everything. The user can add some theories, clauses, etc. and asks - the solver to check satisfiability. - - Theory implementors will mostly interact with {!SOLVER_INTERNAL}. *) -module type SOLVER = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - (** Internal solver, available to theories. *) - module Solver_internal : - SOLVER_INTERNAL - with module T = T - and module Lit = Lit - and module Proof_trace = Proof_trace - - type t - (** The solver's state. *) - - type solver = t - type term = T.Term.t - type ty = T.Ty.t - type lit = Lit.t - type proof_trace = Proof_trace.t - type step_id = Proof_trace.A.step_id - - (** {3 Value registry} *) - - module Registry : REGISTRY - - val registry : t -> Registry.t - (** A solver contains a registry so that theories can share data *) - - (** {3 A theory} - - Theories are abstracted over the concrete implementation of the solver, - so they can work with any implementation. - - Typically a theory should be a functor taking an argument containing - a [SOLVER_INTERNAL] or even a full [SOLVER], - and some additional views on terms, literals, etc. - that are specific to the theory (e.g. to map terms to linear - expressions). - The theory can then be instantiated on any kind of solver for any - term representation that also satisfies the additional theory-specific - requirements. Instantiated theories (ie values of type {!SOLVER.theory}) - can be added to the solver. - *) - module type THEORY = sig - type t - (** The theory's state *) - - val name : string - (** Name of the theory (ideally, unique and short) *) - - val create_and_setup : Solver_internal.t -> t - (** Instantiate the theory's state for the given (internal) solver, - register callbacks, create keys, etc. - - Called once for every solver this theory is added to. *) - - val push_level : t -> unit - (** Push backtracking level. When the corresponding pop is called, - the theory's state should be restored to a state {b equivalent} - to what it was just before [push_level]. - - it does not have to be exactly the same state, it just needs to - be equivalent. *) - - val pop_levels : t -> int -> unit - (** [pop_levels theory n] pops [n] backtracking levels, - restoring [theory] to its state before calling [push_level] n times. *) - end - - type theory = (module THEORY) - (** A theory that can be used for this particular solver. *) - - type 'a theory_p = (module THEORY with type t = 'a) - (** A theory that can be used for this particular solver, with state - of type ['a]. *) - - val mk_theory : - name:string -> - create_and_setup:(Solver_internal.t -> 'th) -> - ?push_level:('th -> unit) -> - ?pop_levels:('th -> int -> unit) -> - unit -> - theory - (** Helper to create a theory. *) - - (** Models - - A model can be produced when the solver is found to be in a - satisfiable state after a call to {!solve}. *) - module Model : sig - 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 - end - - (* TODO *) - module Unknown : sig - type t - - val pp : t CCFormat.printer - - (* - type unknown = - | U_timeout - | U_incomplete - *) - end - - (** {3 Main API} *) - - val stats : t -> Stat.t - val tst : t -> T.Term.store - val ty_st : t -> T.Ty.store - val proof : t -> proof_trace - - val create : - ?stat:Stat.t -> - ?size:[ `Big | `Tiny | `Small ] -> - (* TODO? ?config:Config.t -> *) - proof:proof_trace -> - theories:theory list -> - T.Term.store -> - T.Ty.store -> - unit -> - t - (** Create a new solver. - - It needs a term state and a type state to manipulate terms and types. - All terms and types interacting with this solver will need to come - from these exact states. - - @param store_proof if true, proofs from the SAT solver and theories - are retained and potentially accessible after {!solve} - returns UNSAT. - @param size influences the size of initial allocations. - @param theories theories to load from the start. Other theories - can be added using {!add_theory}. *) - - val add_theory : t -> theory -> unit - (** Add a theory to the solver. This should be called before - any call to {!solve} or to {!add_clause} and the likes (otherwise - the theory will have a partial view of the problem). *) - - val add_theory_p : t -> 'a theory_p -> 'a - (** Add the given theory and obtain its state *) - - val add_theory_l : t -> theory list -> unit - - val mk_lit_t : t -> ?sign:bool -> term -> lit - (** [mk_lit_t _ ~sign t] returns [lit'], - where [lit'] is [preprocess(lit)] and [lit] is - an internal representation of [± t]. - - The proof of [|- lit = lit'] is directly added to the solver's proof. *) - - val add_clause : t -> lit array -> step_id -> unit - (** [add_clause solver cs] adds a boolean clause to the solver. - Subsequent calls to {!solve} will need to satisfy this clause. *) - - val add_clause_l : t -> lit list -> step_id -> unit - (** Add a clause to the solver, given as a list. *) - - val assert_terms : t -> term list -> unit - (** Helper that turns each term into an atom, before adding the result - to the solver as an assertion *) - - val assert_term : t -> term -> unit - (** Helper that turns the term into an atom, before adding the result - to the solver as a unit clause assertion *) - - (** Result of solving for the current set of clauses *) - type res = - | Sat of Model.t (** Satisfiable *) - | Unsat of { - unsat_core: unit -> lit Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_step_id: unit -> step_id option; - (** Proof step for the empty clause *) - } (** Unsatisfiable *) - | Unknown of Unknown.t - (** Unknown, obtained after a timeout, memory limit, etc. *) - - (* TODO: API to push/pop/clear assumptions, in addition to ~assumptions param *) - - val solve : - ?on_exit:(unit -> unit) list -> - ?check:bool -> - ?on_progress:(t -> unit) -> - ?should_stop:(t -> int -> bool) -> - assumptions:lit list -> - t -> - res - (** [solve s] checks the satisfiability of the clauses added so far to [s]. - @param check if true, the model is checked before returning. - @param on_progress called regularly during solving. - @param assumptions a set of atoms held to be true. The unsat core, - if any, will be a subset of [assumptions]. - @param should_stop a callback regularly called with the solver, - and with a number of "steps" done since last call. The exact notion - of step is not defined, but is guaranteed to increase regularly. - The function should return [true] if it judges solving - must stop (returning [Unknown]), [false] if solving can proceed. - @param on_exit functions to be run before this returns *) - - val last_res : t -> res option - (** Last result, if any. Some operations will erase this (e.g. {!assert_term}). *) - - val push_assumption : t -> lit -> unit - (** Pushes an assumption onto the assumption stack. It will remain - there until it's pop'd by {!pop_assumptions}. *) - - val pop_assumptions : t -> int -> unit - (** [pop_assumptions solver n] removes [n] assumptions from the stack. - It removes the assumptions that were the most - recently added via {!push_assumptions}. - Note that {!check_sat_propagations_only} can call this if it meets - a conflict. *) - - type propagation_result = - | PR_sat - | PR_conflict of { backtracked: int } - | PR_unsat of { unsat_core: unit -> lit Iter.t } - - val check_sat_propagations_only : - assumptions:lit list -> t -> propagation_result - (** [check_sat_propagations_only solver] uses assumptions (including - the [assumptions] parameter, and atoms previously added via {!push_assumptions}) - and boolean+theory propagation to quickly assess satisfiability. - It is not complete; calling {!solve} is required to get an accurate - result. - @returns one of: - - - [PR_sat] if the current state seems satisfiable - - [PR_conflict {backtracked=n}] if a conflict was found and resolved, - leading to backtracking [n] levels of assumptions - - [PR_unsat …] if the assumptions were found to be unsatisfiable, with - the given core. - *) - - (* TODO: allow on_progress to return a bool to know whether to stop? *) - - val pp_stats : t CCFormat.printer - (** Print some statistics. What it prints exactly is unspecified. *) -end diff --git a/src/sigs/smt/dune b/src/sigs/smt/dune deleted file mode 100644 index 063ba7ce..00000000 --- a/src/sigs/smt/dune +++ /dev/null @@ -1,8 +0,0 @@ -(library - (name sidekick_sigs_smt) - (public_name sidekick.sigs.smt) - (synopsis "Signatures for the SMT solver") - (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.sigs sidekick.sigs.term - sidekick.sigs.lit sidekick.sigs.proof-trace sidekick.sigs.proof.core - sidekick.sigs.proof.sat sidekick.util sidekick.sigs.cc)) diff --git a/src/smt-solver/Sidekick_smt_solver.ml b/src/smt-solver/Sidekick_smt_solver.ml deleted file mode 100644 index c44b5f83..00000000 --- a/src/smt-solver/Sidekick_smt_solver.ml +++ /dev/null @@ -1,1156 +0,0 @@ -(** Core of the SMT solver using Sidekick_sat - - Sidekick_sat (in src/sat/) is a modular SAT solver in - pure OCaml. - - This builds a SMT solver on top of it. -*) - -(** Argument to pass to the functor {!Make} in order to create a - new Msat-based SMT solver. *) -module type ARG = sig - open Sidekick_core - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - type step_id = Proof_trace.A.step_id - type rule = Proof_trace.A.rule - - module Rule_core : - Sidekick_sigs_proof_core.S - with type term = T.Term.t - and type lit = Lit.t - and type step_id = step_id - and type rule = rule - - module Rule_sat : - Sidekick_sigs_proof_sat.S - with type lit = Lit.t - and type step_id = step_id - and type rule = rule - - val view_as_cc : - T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) Sidekick_sigs_cc.View.t - - val mk_eq : T.Term.store -> T.Term.t -> T.Term.t -> T.Term.t - (** [mk_eq store t u] builds the term [t=u] *) - - val is_valid_literal : T.Term.t -> bool - (** Is this a valid boolean literal? (e.g. is it a closed term, not inside - a quantifier) *) -end - -module type S = Sidekick_sigs_smt.SOLVER - -module Registry : Sidekick_sigs_smt.REGISTRY = struct - (* registry keys *) - module type KEY = sig - type elt - - val id : int - - exception E of elt - end - - type 'a key = (module KEY with type elt = 'a) - type t = { tbl: exn Util.Int_tbl.t } [@@unboxed] - - let create () : t = { tbl = Util.Int_tbl.create 8 } - let n_ = ref 0 - - let create_key (type a) () : a key = - let id = !n_ in - incr n_; - let module K = struct - type elt = a - - exception E of a - - let id = id - end in - (module K) - - let get (type a) (self : t) (k : a key) : _ option = - let (module K : KEY with type elt = a) = k in - match Util.Int_tbl.get self.tbl K.id with - | Some (K.E x) -> Some x - | _ -> None - - let set (type a) (self : t) (k : a key) (v : a) : unit = - let (module K) = k in - Util.Int_tbl.replace self.tbl K.id (K.E v) -end - -(** Main functor to get a solver. *) -module Make (A : ARG) : - S - with module T = A.T - and module Lit = A.Lit - and module Proof_trace = A.Proof_trace = struct - module T = A.T - module Proof_trace = A.Proof_trace - module Lit = A.Lit - module Ty = T.Ty - module Term = T.Term - - open struct - module P = Proof_trace - module Rule_ = A.Rule_core - end - - type term = Term.t - type ty = Ty.t - type lit = Lit.t - type step_id = Proof_trace.A.step_id - type proof_trace = Proof_trace.t - - (* actions from the sat solver *) - type sat_acts = (lit, Proof_trace.t, step_id) Sidekick_sat.acts - - type th_combination_conflict = { - lits: lit list; - semantic: (bool * term * term) list; - (* set of semantic eqns/diseqns (ie true only in current model) *) - } - (** Conflict obtained during theory combination. It involves equalities - merged because of the current model so it's not a "true" conflict - and doesn't need to kill the current trail. *) - - (* the full argument to the congruence closure *) - module CC_arg = struct - module T = T - module Lit = Lit - module Proof_trace = Proof_trace - module Rule_core = A.Rule_core - - let view_as_cc = A.view_as_cc - - let[@inline] mk_lit_eq ?sign store t u = - A.Lit.atom ?sign store (A.mk_eq store t u) - end - - module CC = Sidekick_cc.Make (CC_arg) - module N = CC.E_node - - module Model = struct - 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 t Term.pp v - in - Fmt.fprintf out "(@[model@ %a@])" (Util.pp_iter pp_pair) - (Term.Tbl.to_iter tbl) - end - - (* delayed actions. We avoid doing them on the spot because, when - triggered by a theory, they might go back to the theory "too early". *) - type delayed_action = - | DA_add_clause of { c: lit list; pr: step_id; keep: bool } - | DA_add_lit of { default_pol: bool option; lit: lit } - - (* TODO - let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = - let (module A) = a in - - (module struct - module T = T - module Lit = Lit - - type nonrec lit = lit - type nonrec term = term - type nonrec proof_trace = Proof_trace.t - type nonrec step_id = step_id - - let proof_trace () = pr - let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr - - let[@inline] raise_semantic_conflict lits semantic = - raise (Semantic_conflict { lits; semantic }) - - let[@inline] propagate lit ~reason = - let reason = Sidekick_sat.Consequence reason in - A.propagate lit reason - end) - *) - - (** Internal solver, given to theories and to Msat *) - module Solver_internal = struct - module T = T - module Proof_trace = Proof_trace - module Proof_rules = A.Rule_sat - module P_core_rules = A.Rule_core - module Lit = Lit - module CC = CC - module N = CC.E_node - - type nonrec proof_trace = Proof_trace.t - type nonrec step_id = step_id - type term = Term.t - type value = term - type ty = Ty.t - type lit = Lit.t - type term_store = Term.store - type clause_pool - type ty_store = Ty.store - - type th_states = - | Ths_nil - | Ths_cons : { - st: 'a; - push_level: 'a -> unit; - pop_levels: 'a -> int -> unit; - next: th_states; - } - -> th_states - - type theory_actions = sat_acts - - module Simplify = struct - type t = { - tst: term_store; - ty_st: ty_store; - proof: proof_trace; - mutable hooks: hook list; - (* store [t --> u by step_ids] in the cache. - We use a bag for the proof steps because it gives us structural - sharing of subproofs. *) - cache: (Term.t * step_id Bag.t) Term.Tbl.t; - } - - and hook = t -> term -> (term * step_id Iter.t) option - - let create tst ty_st ~proof : t = - { tst; ty_st; proof; hooks = []; cache = Term.Tbl.create 32 } - - let[@inline] tst self = self.tst - let[@inline] ty_st self = self.ty_st - let[@inline] proof self = self.proof - let add_hook self f = self.hooks <- f :: self.hooks - let clear self = Term.Tbl.clear self.cache - - let normalize (self : t) (t : Term.t) : (Term.t * step_id) option = - (* compute and cache normal form of [t] *) - let rec loop t : Term.t * _ Bag.t = - match Term.Tbl.find self.cache t with - | res -> res - | exception Not_found -> - let steps_u = ref Bag.empty in - let u = aux_rec ~steps:steps_u t self.hooks in - Term.Tbl.add self.cache t (u, !steps_u); - u, !steps_u - and loop_add ~steps t = - let u, pr_u = loop t in - steps := Bag.append !steps pr_u; - u - (* try each function in [hooks] successively, and rewrite subterms *) - and aux_rec ~steps t hooks : Term.t = - match hooks with - | [] -> - let u = Term.map_shallow self.tst (loop_add ~steps) t in - if Term.equal t u then - t - else - loop_add ~steps u - | h :: hooks_tl -> - (match h self t with - | None -> aux_rec ~steps t hooks_tl - | Some (u, _) when Term.equal t u -> aux_rec ~steps t hooks_tl - | Some (u, pr_u) -> - let bag_u = Bag.of_iter pr_u in - steps := Bag.append !steps bag_u; - let v, pr_v = loop u in - (* fixpoint *) - steps := Bag.append !steps pr_v; - v) - in - let u, pr_u = loop t in - if Term.equal t u then - None - else ( - (* proof: [sub_proofs |- t=u] by CC + subproof *) - let step = - P.add_step self.proof - @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) - in - Some (u, step) - ) - - let normalize_t self t = - match normalize self t with - | Some (u, pr_u) -> u, Some pr_u - | None -> t, None - end - - type simplify_hook = Simplify.hook - - module type PREPROCESS_ACTS = sig - val proof : proof_trace - val mk_lit : ?sign:bool -> term -> lit - val add_clause : lit list -> step_id -> unit - val add_lit : ?default_pol:bool -> lit -> unit - end - - type preprocess_actions = (module PREPROCESS_ACTS) - - module Registry = Registry - - type t = { - tst: Term.store; (** state for managing terms *) - ty_st: Ty.store; - cc: CC.t lazy_t; (** congruence closure *) - proof: proof_trace; (** proof logger *) - registry: Registry.t; - mutable on_progress: unit -> unit; - mutable on_partial_check: - (t -> theory_actions -> lit Iter.t -> unit) list; - mutable on_final_check: (t -> theory_actions -> lit Iter.t -> unit) list; - mutable on_th_combination: - (t -> theory_actions -> (term * value) Iter.t) list; - mutable preprocess: preprocess_hook list; - mutable model_ask: model_ask_hook list; - mutable model_complete: model_completion_hook list; - simp: Simplify.t; - preprocessed: unit Term.Tbl.t; - delayed_actions: delayed_action Queue.t; - mutable last_model: Model.t option; - mutable th_states: th_states; (** Set of theories *) - mutable level: int; - mutable complete: bool; - stat: Stat.t; - count_axiom: int Stat.counter; - count_preprocess_clause: int Stat.counter; - count_conflict: int Stat.counter; - count_propagate: int Stat.counter; - } - - and preprocess_hook = t -> preprocess_actions -> term -> unit - and model_ask_hook = recurse:(t -> N.t -> term) -> t -> N.t -> term option - and model_completion_hook = t -> add:(term -> term -> unit) -> unit - - type solver = t - - let[@inline] cc (t : t) = Lazy.force t.cc - let[@inline] tst t = t.tst - let[@inline] ty_st t = t.ty_st - let[@inline] proof self = self.proof - let stats t = t.stat - - let[@inline] has_delayed_actions self = - not (Queue.is_empty self.delayed_actions) - - let registry self = self.registry - let simplifier self = self.simp - let simplify_t self (t : Term.t) : _ option = Simplify.normalize self.simp t - let simp_t self (t : Term.t) : Term.t * _ = Simplify.normalize_t self.simp t - let add_simplifier (self : t) f : unit = Simplify.add_hook self.simp f - - let on_th_combination self f = - self.on_th_combination <- f :: self.on_th_combination - - let on_preprocess self f = self.preprocess <- f :: self.preprocess - - let on_model ?ask ?complete self = - Option.iter (fun f -> self.model_ask <- f :: self.model_ask) ask; - Option.iter - (fun f -> self.model_complete <- f :: self.model_complete) - complete; - () - - let[@inline] raise_conflict self (acts : theory_actions) c proof : 'a = - let (module A) = acts in - Stat.incr self.count_conflict; - A.raise_conflict c proof - - let[@inline] propagate self (acts : theory_actions) p ~reason : unit = - let (module A) = acts in - Stat.incr self.count_propagate; - A.propagate p (Sidekick_sat.Consequence reason) - - let[@inline] propagate_l self acts p cs proof : unit = - propagate self acts p ~reason:(fun () -> cs, proof) - - let add_sat_clause_ self (acts : theory_actions) ~keep lits - (proof : step_id) : unit = - let (module A) = acts in - Stat.incr self.count_axiom; - A.add_clause ~keep lits proof - - let add_sat_lit_ _self ?default_pol (acts : theory_actions) (lit : Lit.t) : - unit = - let (module A) = acts in - A.add_lit ?default_pol lit - - let delayed_add_lit (self : t) ?default_pol (lit : Lit.t) : unit = - Queue.push (DA_add_lit { default_pol; lit }) self.delayed_actions - - let delayed_add_clause (self : t) ~keep (c : Lit.t list) (pr : step_id) : - unit = - Queue.push (DA_add_clause { c; pr; keep }) self.delayed_actions - - (* preprocess a term. We assume the term has been simplified already. *) - let preprocess_term_ (self : t) (t0 : term) : unit = - let module A = struct - let proof = self.proof - let mk_lit ?sign t : Lit.t = Lit.atom self.tst ?sign t - - let add_lit ?default_pol lit : unit = - delayed_add_lit self ?default_pol lit - - let add_clause c pr : unit = delayed_add_clause self ~keep:true c pr - end in - let acts = (module A : PREPROCESS_ACTS) in - - (* how to preprocess a term and its subterms *) - let rec preproc_rec_ t = - if not (Term.Tbl.mem self.preprocessed t) then ( - Term.Tbl.add self.preprocessed t (); - - (* process sub-terms first *) - Term.iter_shallow self.tst preproc_rec_ t; - - Log.debugf 50 (fun k -> k "(@[smt.preprocess@ %a@])" Term.pp t); - - (* signal boolean subterms, so as to decide them - in the SAT solver *) - if Ty.is_bool (Term.ty t) then ( - Log.debugf 5 (fun k -> - k "(@[solver.map-bool-subterm-to-lit@ :subterm %a@])" Term.pp t); - - (* make a literal *) - let lit = Lit.atom self.tst t in - (* ensure that SAT solver has a boolean atom for [u] *) - delayed_add_lit self lit; - - (* also map [sub] to this atom in the congruence closure, for propagation *) - let cc = cc self in - CC.set_as_lit cc (CC.add_term cc t) lit - ); - - List.iter (fun f -> f self acts t) self.preprocess - ) - in - preproc_rec_ t0 - - (* simplify literal, then preprocess the result *) - let simplify_and_preproc_lit_ (self : t) (lit : Lit.t) : - Lit.t * step_id option = - let t = Lit.term lit in - let sign = Lit.sign lit in - let u, pr = - match simplify_t self t with - | None -> t, None - | Some (u, pr_t_u) -> - Log.debugf 30 (fun k -> - k "(@[smt-solver.simplify@ :t %a@ :into %a@])" Term.pp t Term.pp u); - u, Some pr_t_u - in - preprocess_term_ self u; - Lit.atom self.tst ~sign u, pr - - let push_decision (self : t) (acts : theory_actions) (lit : lit) : unit = - let (module A) = acts in - (* make sure the literal is preprocessed *) - let lit, _ = simplify_and_preproc_lit_ self lit in - let sign = Lit.sign lit in - A.add_decision_lit (Lit.abs lit) sign - - module type ARR = sig - type 'a t - - val map : ('a -> 'b) -> 'a t -> 'b t - val to_iter : 'a t -> 'a Iter.t - end - - module Preprocess_clause (A : ARR) = struct - (* preprocess a clause's literals, possibly emitting a proof - for the preprocessing. *) - let top (self : t) (c : lit A.t) (pr_c : step_id) : lit A.t * step_id = - let steps = ref [] in - - (* simplify a literal, then preprocess it *) - let[@inline] simp_lit lit = - let lit, pr = simplify_and_preproc_lit_ self lit in - Option.iter (fun pr -> steps := pr :: !steps) pr; - lit - in - let c' = A.map simp_lit c in - - let pr_c' = - if !steps = [] then - pr_c - else ( - Stat.incr self.count_preprocess_clause; - P.add_step self.proof - @@ Rule_.lemma_rw_clause pr_c ~res:(A.to_iter c') - ~using:(Iter.of_list !steps) - ) - in - c', pr_c' - end - [@@inline] - - module PC_list = Preprocess_clause (CCList) - module PC_arr = Preprocess_clause (CCArray) - - let preprocess_clause_ = PC_list.top - let preprocess_clause_iarray_ = PC_arr.top - - module type PERFORM_ACTS = sig - type t - - val add_clause : solver -> t -> keep:bool -> lit list -> step_id -> unit - val add_lit : solver -> t -> ?default_pol:bool -> lit -> unit - end - - module Perform_delayed (A : PERFORM_ACTS) = struct - (* perform actions that were delayed *) - let top (self : t) (acts : A.t) : unit = - while not (Queue.is_empty self.delayed_actions) do - let act = Queue.pop self.delayed_actions in - match act with - | DA_add_clause { c; pr = pr_c; keep } -> - let c', pr_c' = preprocess_clause_ self c pr_c in - A.add_clause self acts ~keep c' pr_c' - | DA_add_lit { default_pol; lit } -> - preprocess_term_ self (Lit.term lit); - A.add_lit self acts ?default_pol lit - done - end - [@@inline] - - module Perform_delayed_th = Perform_delayed (struct - type t = theory_actions - - let add_clause self acts ~keep c pr : unit = - add_sat_clause_ self acts ~keep c pr - - let add_lit self acts ?default_pol lit : unit = - add_sat_lit_ self acts ?default_pol lit - end) - - let[@inline] add_clause_temp self _acts c (proof : step_id) : unit = - let c, proof = preprocess_clause_ self c proof in - delayed_add_clause self ~keep:false c proof - - let[@inline] add_clause_permanent self _acts c (proof : step_id) : unit = - let c, proof = preprocess_clause_ self c proof in - delayed_add_clause self ~keep:true c proof - - let[@inline] mk_lit (self : t) (_acts : theory_actions) ?sign t : lit = - Lit.atom self.tst ?sign t - - let[@inline] add_lit self _acts ?default_pol lit = - delayed_add_lit self ?default_pol lit - - let add_lit_t self _acts ?sign t = - let lit = Lit.atom self.tst ?sign t in - let lit, _ = simplify_and_preproc_lit_ self lit in - delayed_add_lit self lit - - let on_final_check self f = self.on_final_check <- f :: self.on_final_check - - let on_partial_check self f = - self.on_partial_check <- f :: self.on_partial_check - - let on_cc_new_term self f = Event.on (CC.on_new_term (cc self)) ~f - let on_cc_pre_merge self f = Event.on (CC.on_pre_merge (cc self)) ~f - let on_cc_post_merge self f = Event.on (CC.on_post_merge (cc self)) ~f - let on_cc_conflict self f = Event.on (CC.on_conflict (cc self)) ~f - let on_cc_propagate self f = Event.on (CC.on_propagate (cc self)) ~f - let on_cc_is_subterm self f = Event.on (CC.on_is_subterm (cc self)) ~f - let cc_add_term self t = CC.add_term (cc self) t - let cc_mem_term self t = CC.mem_term (cc self) t - let cc_find self n = CC.find (cc self) n - - let cc_are_equal self t1 t2 = - let n1 = cc_add_term self t1 in - let n2 = cc_add_term self t2 in - N.equal (cc_find self n1) (cc_find self n2) - - let cc_resolve_expl self e : lit list * _ = - let r = CC.explain_expl (cc self) e in - r.lits, r.pr self.proof - - (* - let cc_merge self _acts n1 n2 e = CC.merge (cc self) n1 n2 e - - let cc_merge_t self acts t1 t2 e = - let cc_acts = mk_cc_acts_ self.proof acts in - cc_merge self cc_acts (cc_add_term self t1) (cc_add_term self t2) e - - let cc_raise_conflict_expl self acts e = - let cc_acts = mk_cc_acts_ self.proof acts in - CC.raise_conflict_from_expl (cc self) cc_acts e - *) - - (** {2 Interface with the SAT solver} *) - - let rec push_lvl_ = function - | Ths_nil -> () - | Ths_cons r -> - r.push_level r.st; - push_lvl_ r.next - - let rec pop_lvls_ n = function - | Ths_nil -> () - | Ths_cons r -> - r.pop_levels r.st n; - pop_lvls_ n r.next - - let push_level (self : t) : unit = - self.level <- 1 + self.level; - CC.push_level (cc self); - push_lvl_ self.th_states - - let pop_levels (self : t) n : unit = - self.last_model <- None; - self.level <- self.level - n; - CC.pop_levels (cc self) n; - pop_lvls_ n self.th_states - - (** {2 Model construction and theory combination} *) - - (* make model from the congruence closure *) - let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = - Log.debug 1 "(smt.solver.mk-model)"; - Profile.with_ "smt-solver.mk-model" @@ fun () -> - let module M = Term.Tbl in - let { - cc = (lazy cc); - tst; - model_ask = model_ask_hooks; - model_complete; - _; - } = - self - in - - let model = M.create 128 in - - (* first, add all literals to the model using the given propositional model - [lits]. *) - lits (fun lit -> - let t, sign = Lit.signed_term lit in - M.replace model t (Term.bool tst sign)); - - (* populate with information from the CC *) - (* FIXME - CC.get_model_for_each_class cc (fun (_, ts, v) -> - Iter.iter - (fun n -> - let t = N.term n in - M.replace model t v) - ts); - *) - - (* complete model with theory specific values *) - let complete_with f = - f self ~add:(fun t u -> - if not (M.mem model t) then ( - Log.debugf 20 (fun k -> - k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp t - Term.pp u); - M.replace model t u - )) - in - List.iter complete_with model_complete; - - (* compute a value for [n]. *) - let rec val_for_class (n : N.t) : term = - Log.debugf 5 (fun k -> k "val-for-term %a" N.pp n); - let repr = CC.find cc n in - Log.debugf 5 (fun k -> k "val-for-term.repr %a" N.pp repr); - - (* see if a value is found already (always the case if it's a boolean) *) - match M.get model (N.term repr) with - | Some t_val -> - Log.debugf 5 (fun k -> k "cached val is %a" Term.pp t_val); - t_val - | None -> - (* try each model hook *) - let rec try_hooks_ = function - | [] -> N.term repr - | h :: hooks -> - (match h ~recurse:(fun _ n -> val_for_class n) self repr with - | None -> try_hooks_ hooks - | Some t -> t) - in - - let t_val = - try_hooks_ model_ask_hooks - (* FIXME: the more complete version? - match - (* look for a value in the model for any term in the class *) - N.iter_class repr - |> Iter.find_map (fun n -> M.get model (N.term n)) - with - | Some v -> v - | None -> try_hooks_ model_ask_hooks - *) - in - - M.replace model (N.term repr) t_val; - (* be sure to cache the value *) - Log.debugf 5 (fun k -> k "val is %a" Term.pp t_val); - t_val - in - - (* map terms of each CC class to the value computed for their class. *) - CC.all_classes cc (fun repr -> - let t_val = val_for_class repr in - (* value for this class *) - N.iter_class repr (fun u -> - let t_u = N.term u in - if (not (N.equal u repr)) && not (Term.equal t_u t_val) then - M.replace model t_u t_val)); - Model.Map model - - (* do theory combination using the congruence closure. Each theory - can merge classes, *) - let check_th_combination_ (self : t) (_acts : theory_actions) lits : - (Model.t, th_combination_conflict) result = - (* FIXME - - (* enter model mode, disabling most of congruence closure *) - CC.with_model_mode cc @@ fun () -> - let set_val (t, v) : unit = - Log.debugf 50 (fun k -> - k "(@[solver.th-comb.cc-set-term-value@ %a@ :val %a@])" Term.pp t - Term.pp v); - CC.set_model_value cc t v - in - - (* obtain assignments from the hook, and communicate them to the CC *) - let add_th_values f : unit = - let vals = f self acts in - Iter.iter set_val vals - in - try - List.iter add_th_values self.on_th_combination; - CC.check cc; - let m = mk_model_ self in - Ok m - with Semantic_conflict c -> Error c - *) - let m = mk_model_ self lits in - Ok m - - (* call congruence closure, perform the actions it scheduled *) - let check_cc_with_acts_ (self : t) (acts : theory_actions) = - let (module A) = acts in - let cc = cc self in - match CC.check cc with - | Ok acts -> - List.iter - (function - | CC.Result_action.Act_propagate { lit; reason } -> - let reason = Sidekick_sat.Consequence reason in - A.propagate lit reason) - acts - | Error (CC.Result_action.Conflict (lits, pr)) -> A.raise_conflict lits pr - - (* handle a literal assumed by the SAT solver *) - let assert_lits_ ~final (self : t) (acts : theory_actions) - (lits : Lit.t Iter.t) : unit = - Log.debugf 2 (fun k -> - k "(@[@{smt-solver.assume_lits@}%s[lvl=%d]@ %a@])" - (if final then - "[final]" - else - "") - self.level - (Util.pp_iter ~sep:"; " Lit.pp) - lits); - (* transmit to CC *) - let cc = cc self in - - if not final then CC.assert_lits cc lits; - (* transmit to theories. *) - check_cc_with_acts_ self acts; - if final then ( - List.iter (fun f -> f self acts lits) self.on_final_check; - check_cc_with_acts_ self acts; - - (match check_th_combination_ self acts lits with - | Ok m -> self.last_model <- Some m - | Error { lits; semantic } -> - (* bad model, we add a clause to remove it *) - Log.debugf 5 (fun k -> - k - "(@[solver.th-comb.conflict@ :lits (@[%a@])@ :same-val \ - (@[%a@])@])" - (Util.pp_list Lit.pp) lits - (Util.pp_list @@ Fmt.Dump.(triple bool Term.pp Term.pp)) - semantic); - - let c1 = List.rev_map Lit.neg lits in - let c2 = - semantic - |> List.rev_map (fun (sign, t, u) -> - let eqn = A.mk_eq self.tst t u in - let lit = Lit.atom ~sign:(not sign) self.tst eqn in - (* make sure to consider the new lit *) - add_lit self acts lit; - lit) - in - - let c = List.rev_append c1 c2 in - let pr = P.add_step self.proof @@ Rule_.lemma_cc (Iter.of_list c) in - - Log.debugf 20 (fun k -> - k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" - (Util.pp_list Lit.pp) c); - (* will add a delayed action *) - add_clause_temp self acts c pr); - - Perform_delayed_th.top self acts - ) else ( - List.iter (fun f -> f self acts lits) self.on_partial_check; - Perform_delayed_th.top self acts - ); - () - - let[@inline] iter_atoms_ (acts : theory_actions) : _ Iter.t = - fun f -> - let (module A) = acts in - A.iter_assumptions f - - (* propagation from the bool solver *) - let check_ ~final (self : t) (acts : sat_acts) = - let pb = - if final then - Profile.begin_ "solver.final-check" - else - Profile.null_probe - in - let iter = iter_atoms_ acts in - Log.debugf 5 (fun k -> k "(smt-solver.assume :len %d)" (Iter.length iter)); - self.on_progress (); - assert_lits_ ~final self acts iter; - Profile.exit pb - - (* propagation from the bool solver *) - let[@inline] partial_check (self : t) (acts : _ Sidekick_sat.acts) : unit = - check_ ~final:false self acts - - (* perform final check of the model *) - let[@inline] final_check (self : t) (acts : _ Sidekick_sat.acts) : unit = - check_ ~final:true self acts - - let declare_pb_is_incomplete self = - if self.complete then Log.debug 1 "(solver.declare-pb-is-incomplete)"; - self.complete <- false - - let create ~stat ~proof (tst : Term.store) (ty_st : Ty.store) () : t = - let rec self = - { - tst; - ty_st; - cc = - lazy - ((* lazily tie the knot *) - CC.create ~size:`Big self.tst self.proof); - proof; - th_states = Ths_nil; - stat; - simp = Simplify.create tst ty_st ~proof; - last_model = None; - on_progress = (fun () -> ()); - preprocess = []; - model_ask = []; - model_complete = []; - registry = Registry.create (); - preprocessed = Term.Tbl.create 32; - delayed_actions = Queue.create (); - count_axiom = Stat.mk_int stat "solver.th-axioms"; - count_preprocess_clause = Stat.mk_int stat "solver.preprocess-clause"; - count_propagate = Stat.mk_int stat "solver.th-propagations"; - count_conflict = Stat.mk_int stat "solver.th-conflicts"; - on_partial_check = []; - on_final_check = []; - on_th_combination = []; - level = 0; - complete = true; - } - in - ignore (Lazy.force @@ self.cc : CC.t); - self - end - - module Sat_solver = Sidekick_sat.Make_cdcl_t (Solver_internal) - (** the parametrized SAT Solver *) - - module Registry = Solver_internal.Registry - - module type THEORY = sig - type t - - val name : string - val create_and_setup : Solver_internal.t -> t - val push_level : t -> unit - val pop_levels : t -> int -> unit - end - - type theory = (module THEORY) - type 'a theory_p = (module THEORY with type t = 'a) - - (** {2 Result} *) - - module Unknown = struct - type t = U_timeout | U_max_depth | U_incomplete | U_asked_to_stop - - let pp out = function - | U_timeout -> Fmt.string out {|"timeout"|} - | U_max_depth -> Fmt.string out {|"max depth reached"|} - | U_incomplete -> Fmt.string out {|"incomplete fragment"|} - | U_asked_to_stop -> Fmt.string out {|"asked to stop by callback"|} - end - [@@ocaml.warning "-37"] - - type res = - | Sat of Model.t - | Unsat of { - unsat_core: unit -> lit Iter.t; - (** Unsat core (subset of assumptions), or empty *) - unsat_step_id: unit -> step_id option; - (** Proof step for the empty clause *) - } - | Unknown of Unknown.t - (** Result of solving for the current set of clauses *) - - (* main solver state *) - type t = { - si: Solver_internal.t; - solver: Sat_solver.t; - mutable last_res: res option; - stat: Stat.t; - proof: P.t; - count_clause: int Stat.counter; - count_solve: int Stat.counter; (* config: Config.t *) - } - - type solver = t - - (** {2 Main} *) - - let add_theory_p (type a) (self : t) (th : a theory_p) : a = - let (module Th) = th in - Log.debugf 2 (fun k -> k "(@[smt-solver.add-theory@ :name %S@])" Th.name); - let st = Th.create_and_setup self.si in - (* add push/pop to the internal solver *) - (let open Solver_internal in - self.si.th_states <- - Ths_cons - { - st; - push_level = Th.push_level; - pop_levels = Th.pop_levels; - next = self.si.th_states; - }); - st - - let add_theory (self : t) (th : theory) : unit = - let (module Th) = th in - ignore (add_theory_p self (module Th)) - - let add_theory_l self = List.iter (add_theory self) - - (* create a new solver *) - let create ?(stat = Stat.global) ?size ~proof ~theories tst ty_st () : t = - Log.debug 5 "smt-solver.create"; - let si = Solver_internal.create ~stat ~proof tst ty_st () in - let self = - { - si; - proof; - last_res = None; - solver = Sat_solver.create ~proof ?size ~stat si; - stat; - count_clause = Stat.mk_int stat "solver.add-clause"; - count_solve = Stat.mk_int stat "solver.solve"; - } - in - add_theory_l self theories; - (* assert [true] and [not false] *) - (let tst = Solver_internal.tst self.si in - let t_true = Term.bool tst true in - Sat_solver.add_clause self.solver - [ Lit.atom tst t_true ] - (P.add_step self.proof @@ Rule_.lemma_true t_true)); - self - - let[@inline] solver self = self.solver - let[@inline] cc self = Solver_internal.cc self.si - let[@inline] stats self = self.stat - let[@inline] tst self = Solver_internal.tst self.si - let[@inline] ty_st self = Solver_internal.ty_st self.si - let[@inline] proof self = self.si.proof - let[@inline] last_res self = self.last_res - let[@inline] registry self = Solver_internal.registry self.si - let reset_last_res_ self = self.last_res <- None - - (* preprocess clause, return new proof *) - let preprocess_clause_ (self : t) (c : lit array) (pr : step_id) : - lit array * step_id = - Solver_internal.preprocess_clause_iarray_ self.si c pr - - let mk_lit_t (self : t) ?sign (t : term) : lit = - let lit = Lit.atom self.si.tst ?sign t in - let lit, _ = Solver_internal.simplify_and_preproc_lit_ self.si lit in - lit - - (** {2 Main} *) - - let pp_stats out (self : t) : unit = Stat.pp_all out (Stat.all @@ stats self) - - (* add [c], without preprocessing its literals *) - let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit - = - Stat.incr self.count_clause; - reset_last_res_ self; - Log.debugf 50 (fun k -> - k "(@[solver.add-clause@ %a@])" (Util.pp_array Lit.pp) c); - let pb = Profile.begin_ "add-clause" in - Sat_solver.add_clause_a self.solver (c :> lit array) proof; - Profile.exit pb - - let add_clause_nopreproc_l_ self c p = - add_clause_nopreproc_ self (CCArray.of_list c) p - - module Perform_delayed_ = Solver_internal.Perform_delayed (struct - type nonrec t = t - - let add_clause _si solver ~keep:_ c pr : unit = - add_clause_nopreproc_l_ solver c pr - - let add_lit _si solver ?default_pol lit : unit = - Sat_solver.add_lit solver.solver ?default_pol lit - end) - - let add_clause (self : t) (c : lit array) (proof : step_id) : unit = - let c, proof = preprocess_clause_ self c proof in - add_clause_nopreproc_ self c proof; - Perform_delayed_.top self.si self; - (* finish preproc *) - () - - let add_clause_l self c p = add_clause self (CCArray.of_list c) p - - let assert_terms self c = - let c = CCList.map (fun t -> Lit.atom (tst self) t) c in - let pr_c = - P.add_step self.proof @@ A.Rule_sat.sat_input_clause (Iter.of_list c) - in - add_clause_l self c pr_c - - let assert_term self t = assert_terms self [ t ] - - exception Resource_exhausted = Sidekick_sat.Resource_exhausted - - let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) - ?(should_stop = fun _ _ -> false) ~assumptions (self : t) : res = - Profile.with_ "smt-solver.solve" @@ fun () -> - let do_on_exit () = List.iter (fun f -> f ()) on_exit in - - let on_progress = - let resource_counter = ref 0 in - fun () -> - incr resource_counter; - on_progress self; - if should_stop self !resource_counter then - raise_notrace Resource_exhausted - in - self.si.on_progress <- on_progress; - - let res = - match - Stat.incr self.count_solve; - Sat_solver.solve ~on_progress ~assumptions (solver self) - with - | Sat_solver.Sat _ when not self.si.complete -> - Log.debugf 1 (fun k -> - k - "(@[sidekick.smt-solver: SAT@ actual: UNKNOWN@ :reason \ - incomplete-fragment@])"); - Unknown Unknown.U_incomplete - | Sat_solver.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 N.pp) - (N.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 self.si.last_model with - | Some m -> m - | None -> assert false - in - (* TODO: check model *) - let _ = check in - - do_on_exit (); - Sat m - | Sat_solver.Unsat (module UNSAT) -> - let unsat_core () = UNSAT.unsat_assumptions () in - let unsat_step_id () = Some (UNSAT.unsat_proof ()) in - do_on_exit (); - Unsat { unsat_core; unsat_step_id } - | exception Resource_exhausted -> Unknown Unknown.U_asked_to_stop - in - self.last_res <- Some res; - res - - let push_assumption self a = - reset_last_res_ self; - Sat_solver.push_assumption self.solver a - - let pop_assumptions self n = - reset_last_res_ self; - Sat_solver.pop_assumptions self.solver n - - type propagation_result = - | PR_sat - | PR_conflict of { backtracked: int } - | PR_unsat of { unsat_core: unit -> lit Iter.t } - - let check_sat_propagations_only ~assumptions self : propagation_result = - reset_last_res_ self; - match Sat_solver.check_sat_propagations_only ~assumptions self.solver with - | Sat_solver.PR_sat -> PR_sat - | Sat_solver.PR_conflict { backtracked } -> PR_conflict { backtracked } - | Sat_solver.PR_unsat (module UNSAT) -> - let unsat_core () = UNSAT.unsat_assumptions () in - PR_unsat { unsat_core } - - let mk_theory (type st) ~name ~create_and_setup ?(push_level = fun _ -> ()) - ?(pop_levels = fun _ _ -> ()) () : theory = - let module Th = struct - type t = st - - let name = name - let create_and_setup = create_and_setup - let push_level = push_level - let pop_levels = pop_levels - end in - (module Th : THEORY) -end diff --git a/src/smt-solver/dune b/src/smt-solver/dune deleted file mode 100644 index 42a88c50..00000000 --- a/src/smt-solver/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name Sidekick_smt_solver) - (public_name sidekick.smt-solver) - (libraries containers iter sidekick.sigs.smt sidekick.util sidekick.cc - sidekick.sat) - (flags :standard -warn-error -a+8 -open Sidekick_util)) diff --git a/src/smt-solver/th_key.ml.bak b/src/smt-solver/th_key.ml.bak deleted file mode 100644 index cd8c7194..00000000 --- a/src/smt-solver/th_key.ml.bak +++ /dev/null @@ -1,145 +0,0 @@ - - -module type S = sig - type ('term,'lit,'a) t - (** An access key for theories which have per-class data ['a] *) - - val create : - ?pp:'a Fmt.printer -> - name:string -> - eq:('a -> 'a -> bool) -> - merge:('a -> 'a -> 'a) -> - unit -> - ('term,'lit,'a) t - (** Generative creation of keys for the given theory data. - - @param eq : Equality. This is used to optimize backtracking info. - - @param merge : - [merge d1 d2] is called when merging classes with data [d1] and [d2] - respectively. The theory should already have checked that the merge - is compatible, and this produces the combined data for terms in the - merged class. - @param name name of the theory which owns this data - @param pp a printer for the data - *) - - val equal : ('t,'lit,_) t -> ('t,'lit,_) t -> bool - (** Checks if two keys are equal (generatively) *) - - val pp : _ t Fmt.printer - (** Prints the name of the key. *) -end - - -(** Custom keys for theory data. - This imitates the classic tricks for heterogeneous maps - https://blog.janestreet.com/a-universal-type/ - - It needs to form a commutative monoid where values are persistent so - they can be restored during backtracking. -*) -module Key = struct - module type KEY_IMPL = sig - type term - type lit - type t - val id : int - val name : string - val pp : t Fmt.printer - val equal : t -> t -> bool - val merge : t -> t -> t - exception Store of t - end - - type ('term,'lit,'a) t = - (module KEY_IMPL with type term = 'term and type lit = 'lit and type t = 'a) - - let n_ = ref 0 - - let create (type term)(type lit)(type d) - ?(pp=fun out _ -> Fmt.string out "") - ~name ~eq ~merge () : (term,lit,d) t = - let module K = struct - type nonrec term = term - type nonrec lit = lit - type t = d - let id = !n_ - let name = name - let pp = pp - let merge = merge - let equal = eq - exception Store of d - end in - incr n_; - (module K) - - let[@inline] id - : type term lit a. (term,lit,a) t -> int - = fun (module K) -> K.id - - let[@inline] equal - : type term lit a b. (term,lit,a) t -> (term,lit,b) t -> bool - = fun (module K1) (module K2) -> K1.id = K2.id - - let pp - : type term lit a. (term,lit,a) t Fmt.printer - = fun out (module K) -> Fmt.string out K.name -end - - - -(* - (** Map for theory data associated with representatives *) - module K_map = struct - type 'a key = (term,lit,'a) Key.t - type pair = Pair : 'a key * exn -> pair - - type t = pair IM.t - - let empty = IM.empty - - let[@inline] mem k t = IM.mem (Key.id k) t - - let find (type a) (k : a key) (self:t) : a option = - let (module K) = k in - match IM.find K.id self with - | Pair (_, K.Store v) -> Some v - | _ -> None - | exception Not_found -> None - - let add (type a) (k : a key) (v:a) (self:t) : t = - let (module K) = k in - IM.add K.id (Pair (k, K.Store v)) self - - let remove (type a) (k: a key) self : t = - let (module K) = k in - IM.remove K.id self - - let equal (m1:t) (m2:t) : bool = - IM.equal - (fun p1 p2 -> - let Pair ((module K1), v1) = p1 in - let Pair ((module K2), v2) = p2 in - assert (K1.id = K2.id); - match v1, v2 with K1.Store v1, K1.Store v2 -> K1.equal v1 v2 | _ -> false) - m1 m2 - - let merge ~f_both (m1:t) (m2:t) : t = - IM.merge - (fun _ p1 p2 -> - match p1, p2 with - | None, None -> None - | Some v, None - | None, Some v -> Some v - | Some (Pair ((module K1) as key1, pair1)), Some (Pair (_, pair2)) -> - match pair1, pair2 with - | K1.Store v1, K1.Store v2 -> - f_both K1.id pair1 pair2; (* callback for checking compat *) - let v12 = K1.merge v1 v2 in (* merge content *) - Some (Pair (key1, K1.Store v12)) - | _ -> assert false - ) - m1 m2 - end - *) diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index 9ab1530d..a0e5b0c7 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -9,6 +9,9 @@ module Sigs = Sigs module Model = Model module Registry = Registry -module Simplify = Simplify module Solver_internal = Solver_internal module Solver = Solver +module Theory = Theory + +type theory = Theory.t +type solver = Solver.t diff --git a/src/th-cstor/Sidekick_th_cstor.mli b/src/th-cstor/Sidekick_th_cstor.mli new file mode 100644 index 00000000..0cf658a9 --- /dev/null +++ b/src/th-cstor/Sidekick_th_cstor.mli @@ -0,0 +1,13 @@ +(** Theory for constructors *) + +open Sidekick_core +module SMT = Sidekick_smt_solver + +type ('c, 't) cstor_view = T_cstor of 'c * 't array | T_other of 't + +module type ARG = sig + val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view + val lemma_cstor : Lit.t Iter.t -> Proof_term.t +end + +val make : (module ARG) -> SMT.theory From ee2ea784ad7488d540226d0ad4c4da21af7b5382 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:22:25 -0400 Subject: [PATCH 057/174] remove Vec_unit --- src/util/Sidekick_util.ml | 1 - src/util/Vec_unit.ml | 34 ---------------------------------- src/util/Vec_unit.mli | 5 ----- 3 files changed, 40 deletions(-) delete mode 100644 src/util/Vec_unit.ml delete mode 100644 src/util/Vec_unit.mli diff --git a/src/util/Sidekick_util.ml b/src/util/Sidekick_util.ml index aa84faad..a492a241 100644 --- a/src/util/Sidekick_util.ml +++ b/src/util/Sidekick_util.ml @@ -4,7 +4,6 @@ module Util = Util module Vec = Vec module Veci = Veci module Vec_float = Vec_float -module Vec_unit = Vec_unit module Vec_sig = Vec_sig module Bitvec = Bitvec module Int_id = Int_id diff --git a/src/util/Vec_unit.ml b/src/util/Vec_unit.ml deleted file mode 100644 index 0f61168c..00000000 --- a/src/util/Vec_unit.ml +++ /dev/null @@ -1,34 +0,0 @@ -type elt = unit - -(* no need to store anything so we don't even provide an actual vector - since unit is a "zero sized type" as rustaceans would say. *) -type t = { mutable size: int } - -let create ?cap:_ () : t = { size = 0 } -let clear self = self.size <- 0 -let copy { size } = { size } -let get (_self : t) _ = () -let size self = self.size -let iter ~f:_ (_self : t) = () -let iteri ~f:_ (_self : t) = () -let is_empty self = self.size = 0 -let push (self : t) _ = self.size <- 1 + self.size -let fast_remove (self : t) _ = self.size <- self.size - 1 -let ensure_size (self : t) i = self.size <- max self.size i -let set _ _ _ = () - -let pop self = - self.size <- self.size - 1; - () - -let filter_in_place _ _ = () -let shrink (self : t) i = self.size <- i - -let to_iter self k = - for _i = 0 to self.size - 1 do - k () - done - -let to_array self = Iter.to_array (to_iter self) -let fold_left f acc self = Iter.fold f acc (to_iter self) -let pp ppx out self = Iter.pp_seq ppx out (to_iter self) diff --git a/src/util/Vec_unit.mli b/src/util/Vec_unit.mli deleted file mode 100644 index abda0bf9..00000000 --- a/src/util/Vec_unit.mli +++ /dev/null @@ -1,5 +0,0 @@ -(** Fake vector of unit. - - This just retains the size, as 0 bits of actual storage are required. *) - -include Vec_sig.S with type elt = unit From 65e876bebc6ed47eec002fd383e0515a614ae8f3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:58:18 -0400 Subject: [PATCH 058/174] chore: makefile --- Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 78dbae1b..9840b1d9 100644 --- a/Makefile +++ b/Makefile @@ -77,7 +77,7 @@ reindent: @find src '(' -name '*.ml' -or -name '*.mli' ')' -print0 | xargs -0 echo "reindenting: " @find src '(' -name '*.ml' -or -name '*.mli' ')' -print0 | xargs -0 ocp-indent -i -WATCH=@all +WATCH?=@all watch: dune build $(WATCH) -w $(OPTS) #@dune build @all -w # TODO: once tests pass From 06107c212fe029c1d0a69e5ebb51d62f37aa0290 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:58:34 -0400 Subject: [PATCH 059/174] remove most sigs --- src/sigs/cc/dune | 9 - src/sigs/cc/sidekick_sigs_cc.ml | 515 ------------------ src/sigs/cc/view.ml | 38 -- src/sigs/cc/view.mli | 33 -- src/sigs/lit/dune | 5 - src/sigs/lit/sidekick_sigs_lit.ml | 45 -- src/sigs/proof-core/dune | 6 - .../proof-core/sidekick_sigs_proof_core.ml | 94 ---- src/sigs/proof-sat/dune | 6 - src/sigs/proof-sat/sidekick_sigs_proof_sat.ml | 22 - src/sigs/proof-trace/dune | 5 - .../proof-trace/sidekick_sigs_proof_trace.ml | 42 -- src/sigs/term/dune | 5 - src/sigs/term/sidekick_sigs_term.ml | 80 --- 14 files changed, 905 deletions(-) delete mode 100644 src/sigs/cc/dune delete mode 100644 src/sigs/cc/sidekick_sigs_cc.ml delete mode 100644 src/sigs/cc/view.ml delete mode 100644 src/sigs/cc/view.mli delete mode 100644 src/sigs/lit/dune delete mode 100644 src/sigs/lit/sidekick_sigs_lit.ml delete mode 100644 src/sigs/proof-core/dune delete mode 100644 src/sigs/proof-core/sidekick_sigs_proof_core.ml delete mode 100644 src/sigs/proof-sat/dune delete mode 100644 src/sigs/proof-sat/sidekick_sigs_proof_sat.ml delete mode 100644 src/sigs/proof-trace/dune delete mode 100644 src/sigs/proof-trace/sidekick_sigs_proof_trace.ml delete mode 100644 src/sigs/term/dune delete mode 100644 src/sigs/term/sidekick_sigs_term.ml diff --git a/src/sigs/cc/dune b/src/sigs/cc/dune deleted file mode 100644 index a980964b..00000000 --- a/src/sigs/cc/dune +++ /dev/null @@ -1,9 +0,0 @@ - -(library - (name sidekick_sigs_cc) - (public_name sidekick.sigs.cc) - (synopsis "Signatures for the congruence closure") - (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.sigs sidekick.sigs.term - sidekick.sigs.lit sidekick.sigs.proof-trace sidekick.sigs.proof.core - sidekick.util)) diff --git a/src/sigs/cc/sidekick_sigs_cc.ml b/src/sigs/cc/sidekick_sigs_cc.ml deleted file mode 100644 index 3bb47ec7..00000000 --- a/src/sigs/cc/sidekick_sigs_cc.ml +++ /dev/null @@ -1,515 +0,0 @@ -(** Main types for congruence closure *) - -module View = View - -module type TERM = Sidekick_sigs_term.S -module type LIT = Sidekick_sigs_lit.S -module type PROOF_TRACE = Sidekick_sigs_proof_trace.S - -(** Arguments to a congruence closure's implementation *) -module type ARG = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - (** Arguments for the congruence closure *) - val view_as_cc : T.Term.t -> (T.Fun.t, T.Term.t, T.Term.t Iter.t) View.t - (** View the term through the lens of the congruence closure *) - - val mk_lit_eq : ?sign:bool -> T.Term.store -> T.Term.t -> T.Term.t -> Lit.t - (** [mk_lit_eq store t u] makes the literal [t=u] *) - - module Rule_core : - Sidekick_sigs_proof_core.S - with type term = T.Term.t - and type lit = Lit.t - and type step_id = Proof_trace.A.step_id - and type rule = Proof_trace.A.rule -end - -(** Collection of input types, and types defined by the congruence closure *) -module type ARGS_CLASSES_EXPL_EVENT = sig - module T : TERM - module Lit : LIT with module T = T - module Proof_trace : PROOF_TRACE - - type term_store = T.Term.store - type term = T.Term.t - type value = term - type fun_ = T.Fun.t - type lit = Lit.t - type proof_trace = Proof_trace.t - type step_id = Proof_trace.A.step_id - - (** E-node. - - An e-node is a node in the congruence closure that is contained - in some equivalence classe). - An equivalence class is a set of terms that are currently equal - in the partial model built by the solver. - The class is represented by a collection of nodes, one of which is - distinguished and is called the "representative". - - All information pertaining to the whole equivalence class is stored - in its representative's {!E_node.t}. - - When two classes become equal (are "merged"), one of the two - representatives is picked as the representative of the new class. - The new class contains the union of the two old classes' nodes. - - We also allow theories to store additional information in the - representative. This information can be used when two classes are - merged, to detect conflicts and solve equations à la Shostak. - *) - module E_node : sig - type t - (** An E-node. - - A value of type [t] points to a particular term, but see - {!find} to get the representative of the class. *) - - include Sidekick_sigs.PRINT with type t := t - - val term : t -> term - (** Term contained in this equivalence class. - If [is_root n], then [term n] is the class' representative term. *) - - val equal : t -> t -> bool - (** Are two classes {b physically} equal? To check for - logical equality, use [CC.E_node.equal (CC.find cc n1) (CC.find cc n2)] - which checks for equality of representatives. *) - - val hash : t -> int - (** An opaque hash of this E_node.t. *) - - val is_root : t -> bool - (** Is the E_node.t a root (ie the representative of its class)? - See {!find} to get the root. *) - - val iter_class : t -> t Iter.t - (** Traverse the congruence class. - Precondition: [is_root n] (see {!find} below) *) - - val iter_parents : t -> t Iter.t - (** Traverse the parents of the class. - Precondition: [is_root n] (see {!find} below) *) - - (* FIXME: - [@@alert refactor "this should be replaced with a Per_class concept"] - *) - - type bitfield - (** A field in the bitfield of this node. This should only be - allocated when a theory is initialized. - - Bitfields are accessed using preallocated keys. - See {!CC_S.allocate_bitfield}. - - All fields are initially 0, are backtracked automatically, - and are merged automatically when classes are merged. *) - end - - (** Explanations - - Explanations are specialized proofs, created by the congruence closure - when asked to justify why two terms are equal. *) - module Expl : sig - type t - - include Sidekick_sigs.PRINT with type t := t - - val mk_merge : E_node.t -> E_node.t -> t - (** Explanation: the nodes were explicitly merged *) - - val mk_merge_t : term -> term -> t - (** Explanation: the terms were explicitly merged *) - - val mk_lit : lit -> t - (** Explanation: we merged [t] and [u] because of literal [t=u], - or we merged [t] and [true] because of literal [t], - or [t] and [false] because of literal [¬t] *) - - val mk_list : t list -> t - (** Conjunction of explanations *) - - val mk_theory : term -> term -> (term * term * t list) list -> step_id -> t - (** [mk_theory t u expl_sets pr] builds a theory explanation for - why [|- t=u]. It depends on sub-explanations [expl_sets] which - are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are - explanations that justify [t_i = u_i] in the current congruence closure. - - The proof [pr] is the theory lemma, of the form - [ (t_i = u_i)_i |- t=u ]. - It is resolved against each [expls_i |- t_i=u_i] obtained from - [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] - where [Gamma] is a subset of the literals asserted into the congruence - closure. - - For example for the lemma [a=b] deduced by injectivity - from [Some a=Some b] in the theory of datatypes, - the arguments would be - [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] - where [pr] is the injectivity lemma [Some a=Some b |- a=b]. - *) - end - - (** Resolved explanations. - - The congruence closure keeps explanations for why terms are in the same - class. However these are represented in a compact, cheap form. - To use these explanations we need to {b resolve} them into a - resolved explanation, typically a list of - literals that are true in the current trail and are responsible for - merges. - - However, we can also have merged classes because they have the same value - in the current model. *) - module Resolved_expl : sig - type t = { lits: lit list; pr: proof_trace -> step_id } - - include Sidekick_sigs.PRINT with type t := t - end - - (** Per-node data *) - - type e_node = E_node.t - (** A node of the congruence closure *) - - type repr = E_node.t - (** Node that is currently a representative. *) - - type explanation = Expl.t -end - -(** Main congruence closure signature. - - The congruence closure handles the theory QF_UF (uninterpreted - function symbols). - It is also responsible for {i theory combination}, and provides - a general framework for equality reasoning that other - theories piggyback on. - - For example, the theory of datatypes relies on the congruence closure - to do most of the work, and "only" adds injectivity/disjointness/acyclicity - lemmas when needed. - - Similarly, a theory of arrays would hook into the congruence closure and - assert (dis)equalities as needed. -*) -module type S = sig - include ARGS_CLASSES_EXPL_EVENT - - type t - (** The congruence closure object. - It contains a fair amount of state and is mutable - and backtrackable. *) - - (** {3 Accessors} *) - - val term_store : t -> term_store - val proof : t -> proof_trace - - val find : t -> e_node -> repr - (** Current representative *) - - val add_term : t -> term -> e_node - (** Add the term to the congruence closure, if not present already. - Will be backtracked. *) - - val mem_term : t -> term -> bool - (** Returns [true] if the term is explicitly present in the congruence closure *) - - val allocate_bitfield : t -> descr:string -> E_node.bitfield - (** Allocate a new e_node field (see {!E_node.bitfield}). - - This field descriptor is henceforth reserved for all nodes - in this congruence closure, and can be set using {!set_bitfield} - for each class_ individually. - This can be used to efficiently store some metadata on nodes - (e.g. "is there a numeric value in the class" - or "is there a constructor term in the class"). - - There may be restrictions on how many distinct fields are allocated - for a given congruence closure (e.g. at most {!Sys.int_size} fields). - *) - - val get_bitfield : t -> E_node.bitfield -> E_node.t -> bool - (** Access the bit field of the given e_node *) - - val set_bitfield : t -> E_node.bitfield -> bool -> E_node.t -> unit - (** Set the bitfield for the e_node. This will be backtracked. - See {!E_node.bitfield}. *) - - type propagation_reason = unit -> lit list * step_id - - (** Handler Actions - - Actions that can be scheduled by event handlers. *) - module Handler_action : sig - type t = - | Act_merge of E_node.t * E_node.t * Expl.t - | Act_propagate of lit * propagation_reason - - (* TODO: - - an action to modify data associated with a class - *) - - type conflict = Conflict of Expl.t [@@unboxed] - - type or_conflict = (t list, conflict) result - (** Actions or conflict scheduled by an event handler. - - - [Ok acts] is a list of merges and propagations - - [Error confl] is a conflict to resolve. - *) - end - - (** Result Actions. - - - Actions returned by the congruence closure after calling {!check}. *) - module Result_action : sig - type t = - | Act_propagate of { lit: lit; reason: propagation_reason } - (** [propagate (lit, reason)] declares that [reason() => lit] - is a tautology. - - - [reason()] should return a list of literals that are currently true, - as well as a proof. - - [lit] should be a literal of interest (see {!S.set_as_lit}). - - This function might never be called, a congruence closure has the right - to not propagate and only trigger conflicts. *) - - type conflict = - | Conflict of lit list * step_id - (** [raise_conflict (c,pr)] declares that [c] is a tautology of - the theory of congruence. - @param pr the proof of [c] being a tautology *) - - type or_conflict = (t list, conflict) result - end - - (** {3 Events} - - Events triggered by the congruence closure, to which - other plugins can subscribe. *) - - (** Events emitted by the congruence closure when something changes. *) - val on_pre_merge : - t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t - (** [Ev_on_pre_merge acts n1 n2 expl] is emitted right before [n1] - and [n2] are merged with explanation [expl]. *) - - val on_pre_merge2 : - t -> (t * E_node.t * E_node.t * Expl.t, Handler_action.or_conflict) Event.t - (** Second phase of "on pre merge". This runs after {!on_pre_merge} - and is used by Plugins. {b NOTE}: Plugin state might be observed as already - changed in these handlers. *) - - val on_post_merge : - t -> (t * E_node.t * E_node.t, Handler_action.t list) Event.t - (** [ev_on_post_merge acts n1 n2] is emitted right after [n1] - and [n2] were merged. [find cc n1] and [find cc n2] will return - the same E_node.t. *) - - val on_new_term : t -> (t * E_node.t * term, Handler_action.t list) Event.t - (** [ev_on_new_term n t] is emitted whenever a new term [t] - is added to the congruence closure. Its E_node.t is [n]. *) - - type ev_on_conflict = { cc: t; th: bool; c: lit list } - (** Event emitted when a conflict occurs in the CC. - - [th] is true if the explanation for this conflict involves - at least one "theory" explanation; i.e. some of the equations - participating in the conflict are purely syntactic theories - like injectivity of constructors. *) - - val on_conflict : t -> (ev_on_conflict, unit) Event.t - (** [ev_on_conflict {th; c}] is emitted when the congruence - closure triggers a conflict by asserting the tautology [c]. *) - - val on_propagate : - t -> (t * lit * (unit -> lit list * step_id), Handler_action.t list) Event.t - (** [ev_on_propagate lit reason] is emitted whenever [reason() => lit] - is a propagated lemma. See {!CC_ACTIONS.propagate}. *) - - val on_is_subterm : t -> (t * E_node.t * term, Handler_action.t list) Event.t - (** [ev_on_is_subterm n t] is emitted when [n] is a subterm of - another E_node.t for the first time. [t] is the term corresponding to - the E_node.t [n]. This can be useful for theory combination. *) - - (** {3 Misc} *) - - val n_true : t -> E_node.t - (** Node for [true] *) - - val n_false : t -> E_node.t - (** Node for [false] *) - - val n_bool : t -> bool -> E_node.t - (** Node for either true or false *) - - val set_as_lit : t -> E_node.t -> lit -> unit - (** map the given e_node to a literal. *) - - val find_t : t -> term -> repr - (** Current representative of the term. - @raise E_node.t_found if the term is not already {!add}-ed. *) - - val add_iter : t -> term Iter.t -> unit - (** Add a sequence of terms to the congruence closure *) - - val all_classes : t -> repr Iter.t - (** All current classes. This is costly, only use if there is no other solution *) - - val explain_eq : t -> E_node.t -> E_node.t -> Resolved_expl.t - (** Explain why the two nodes are equal. - Fails if they are not, in an unspecified way. *) - - val explain_expl : t -> Expl.t -> Resolved_expl.t - (** Transform explanation into an actionable conflict clause *) - - (* FIXME: remove - val raise_conflict_from_expl : t -> actions -> Expl.t -> 'a - (** Raise a conflict with the given explanation. - It must be a theory tautology that [expl ==> absurd]. - To be used in theories. - - This fails in an unspecified way if the explanation, once resolved, - satisfies {!Resolved_expl.is_semantic}. *) - *) - - val merge : t -> E_node.t -> E_node.t -> Expl.t -> unit - (** Merge these two nodes given this explanation. - It must be a theory tautology that [expl ==> n1 = n2]. - To be used in theories. *) - - val merge_t : t -> term -> term -> Expl.t -> unit - (** Shortcut for adding + merging *) - - (** {3 Main API *) - - val assert_eq : t -> term -> term -> Expl.t -> unit - (** Assert that two terms are equal, using the given explanation. *) - - val assert_lit : t -> lit -> unit - (** Given a literal, assume it in the congruence closure and propagate - its consequences. Will be backtracked. - - Useful for the theory combination or the SAT solver's functor *) - - val assert_lits : t -> lit Iter.t -> unit - (** Addition of many literals *) - - val check : t -> Result_action.or_conflict - (** Perform all pending operations done via {!assert_eq}, {!assert_lit}, etc. - Will use the {!actions} to propagate literals, declare conflicts, etc. *) - - val push_level : t -> unit - (** Push backtracking level *) - - val pop_levels : t -> int -> unit - (** Restore to state [n] calls to [push_level] earlier. Used during backtracking. *) - - val get_model : t -> E_node.t Iter.t Iter.t - (** get all the equivalence classes so they can be merged in the model *) -end - -(* TODO - module type DYN_BUILDER = sig - include ARGS_CLASSES_EXPL_EVENT - end -*) - -(* TODO: full EGG, also have a function to update the value when - the subterms (produced in [of_term]) are updated *) - -(** Data attached to the congruence closure classes. - - This helps theories keeping track of some state for each class. - The state of a class is the monoidal combination of the state for each - term in the class (for example, the set of terms in the - class whose head symbol is a datatype constructor). *) -module type MONOID_PLUGIN_ARG = sig - module CC : S - - type t - (** Some type with a monoid structure *) - - include Sidekick_sigs.PRINT with type t := t - - val name : string - (** name of the monoid structure (short) *) - - (* FIXME: for subs, return list of e_nodes, and assume of_term already - returned data for them. *) - val of_term : - CC.t -> CC.E_node.t -> CC.term -> t option * (CC.E_node.t * t) list - (** [of_term n t], where [t] is the term annotating node [n], - must return [maybe_m, l], where: - - - [maybe_m = Some m] if [t] has monoid value [m]; - otherwise [maybe_m=None] - - [l] is a list of [(u, m_u)] where each [u]'s term - is a direct subterm of [t] - and [m_u] is the monoid value attached to [u]. - - *) - - val merge : - CC.t -> - CC.E_node.t -> - t -> - CC.E_node.t -> - t -> - CC.Expl.t -> - (t * CC.Handler_action.t list, CC.Handler_action.conflict) result - (** Monoidal combination of two values. - - [merge cc n1 mon1 n2 mon2 expl] returns the result of merging - monoid values [mon1] (for class [n1]) and [mon2] (for class [n2]) - when [n1] and [n2] are merged with explanation [expl]. - - @return [Ok mon] if the merge is acceptable, annotating the class of [n1 ∪ n2]; - or [Error expl'] if the merge is unsatisfiable. [expl'] can then be - used to trigger a conflict and undo the merge. - *) -end - -(** Stateful plugin holding a per-equivalence-class monoid. - - Helps keep track of monoid state per equivalence class. - A theory might use one or more instance(s) of this to - aggregate some theory-specific state over all terms, with - the information of what terms are already known to be equal - potentially saving work for the theory. *) -module type DYN_MONOID_PLUGIN = sig - module M : MONOID_PLUGIN_ARG - include Sidekick_sigs.DYN_BACKTRACKABLE - - val pp : unit Fmt.printer - - val mem : M.CC.E_node.t -> bool - (** Does the CC E_node.t have a monoid value? *) - - val get : M.CC.E_node.t -> M.t option - (** Get monoid value for this CC E_node.t, if any *) - - val iter_all : (M.CC.repr * M.t) Iter.t -end - -(** Builder for a plugin. - - The builder takes a congruence closure, and instantiate the - plugin on it. *) -module type MONOID_PLUGIN_BUILDER = sig - module M : MONOID_PLUGIN_ARG - - module type DYN_PL_FOR_M = DYN_MONOID_PLUGIN with module M = M - - type t = (module DYN_PL_FOR_M) - - val create_and_setup : ?size:int -> M.CC.t -> t - (** Create a new monoid state *) -end diff --git a/src/sigs/cc/view.ml b/src/sigs/cc/view.ml deleted file mode 100644 index e319f5ef..00000000 --- a/src/sigs/cc/view.ml +++ /dev/null @@ -1,38 +0,0 @@ -type ('f, 't, 'ts) t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't -(* do not enter *) - -let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = - match v with - | Bool b -> Bool b - | App_fun (f, args) -> App_fun (f_f f, f_ts args) - | App_ho (f, a) -> App_ho (f_t f, f_t a) - | Not t -> Not (f_t t) - | If (a, b, c) -> If (f_t a, f_t b, f_t c) - | Eq (a, b) -> Eq (f_t a, f_t b) - | Opaque t -> Opaque (f_t t) - -let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = - match v with - | Bool _ -> () - | App_fun (f, args) -> - f_f f; - f_ts args - | App_ho (f, a) -> - f_t f; - f_t a - | Not t -> f_t t - | If (a, b, c) -> - f_t a; - f_t b; - f_t c - | Eq (a, b) -> - f_t a; - f_t b - | Opaque t -> f_t t diff --git a/src/sigs/cc/view.mli b/src/sigs/cc/view.mli deleted file mode 100644 index 038ea1a6..00000000 --- a/src/sigs/cc/view.mli +++ /dev/null @@ -1,33 +0,0 @@ -(** View terms through the lens of the Congruence Closure *) - -(** A view of a term fron the point of view of the congruence closure. - - - ['f] is the type of function symbols - - ['t] is the type of terms - - ['ts] is the type of sequences of terms (arguments of function application) - *) -type ('f, 't, 'ts) t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't (** do not enter *) - -val map_view : - f_f:('a -> 'b) -> - f_t:('c -> 'd) -> - f_ts:('e -> 'f) -> - ('a, 'c, 'e) t -> - ('b, 'd, 'f) t -(** Map function over a view, one level deep. - Each function maps over a different type, e.g. [f_t] maps over terms *) - -val iter_view : - f_f:('a -> unit) -> - f_t:('b -> unit) -> - f_ts:('c -> unit) -> - ('a, 'b, 'c) t -> - unit -(** Iterate over a view, one level deep. *) diff --git a/src/sigs/lit/dune b/src/sigs/lit/dune deleted file mode 100644 index 3774c2ba..00000000 --- a/src/sigs/lit/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name sidekick_sigs_lit) - (public_name sidekick.sigs.lit) - (synopsis "Common definition for literals") - (libraries containers iter sidekick.sigs sidekick.sigs.term)) diff --git a/src/sigs/lit/sidekick_sigs_lit.ml b/src/sigs/lit/sidekick_sigs_lit.ml deleted file mode 100644 index 4acc4277..00000000 --- a/src/sigs/lit/sidekick_sigs_lit.ml +++ /dev/null @@ -1,45 +0,0 @@ -(** Literals - - Literals are a pair of a boolean-sorted term, and a sign. - Positive literals are the same as their term, and negative literals - are the negation of their term. - - The SAT solver deals only in literals and clauses (sets of literals). - Everything else belongs in the SMT solver. *) - -module type TERM = Sidekick_sigs_term.S - -module type S = sig - module T : TERM - (** Literals depend on terms *) - - type t - (** A literal *) - - include Sidekick_sigs.EQ_HASH_PRINT with type t := t - - val term : t -> T.Term.t - (** Get the (positive) term *) - - val sign : t -> bool - (** Get the sign. A negated literal has sign [false]. *) - - val neg : t -> t - (** Take negation of literal. [sign (neg lit) = not (sign lit)]. *) - - val abs : t -> t - (** [abs lit] is like [lit] but always positive, i.e. [sign (abs lit) = true] *) - - val signed_term : t -> T.Term.t * bool - (** Return the atom and the sign *) - - val atom : ?sign:bool -> T.Term.store -> T.Term.t -> t - (** [atom store t] makes a literal out of a term, possibly normalizing - its sign in the process. - @param sign if provided, and [sign=false], negate the resulting lit. *) - - val norm_sign : t -> t * bool - (** [norm_sign (+t)] is [+t, true], - and [norm_sign (-t)] is [+t, false]. - In both cases the term is positive, and the boolean reflects the initial sign. *) -end diff --git a/src/sigs/proof-core/dune b/src/sigs/proof-core/dune deleted file mode 100644 index 8eb404e9..00000000 --- a/src/sigs/proof-core/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_sigs_proof_core) - (public_name sidekick.sigs.proof.core) - (synopsis "Common rules for proof traces") - (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.util sidekick.sigs)) diff --git a/src/sigs/proof-core/sidekick_sigs_proof_core.ml b/src/sigs/proof-core/sidekick_sigs_proof_core.ml deleted file mode 100644 index 7bc87bb2..00000000 --- a/src/sigs/proof-core/sidekick_sigs_proof_core.ml +++ /dev/null @@ -1,94 +0,0 @@ -(** Proof rules for common operations and congruence closure *) - -module type S = sig - type rule - type term - type lit - - type step_id - (** Identifier for a proof proof_rule (like a unique ID for a clause previously - added/proved) *) - - val lemma_cc : lit Iter.t -> rule - (** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory - of uninterpreted functions. *) - - val define_term : term -> term -> rule - (** [define_term cst u proof] defines the new constant [cst] as being equal - to [u]. - The result is a proof of the clause [cst = u] *) - - val proof_p1 : step_id -> step_id -> rule - (** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) - and [p2] proves [C \/ t], is the rule that produces [C \/ u], - i.e unit paramodulation. *) - - val proof_r1 : step_id -> step_id -> rule - (** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) - and [p2] proves [C \/ ¬t], is the rule that produces [C \/ u], - i.e unit resolution. *) - - val proof_res : pivot:term -> step_id -> step_id -> rule - (** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] - and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], - is the rule that produces [C \/ D], i.e boolean resolution. *) - - val with_defs : step_id -> step_id Iter.t -> rule - (** [with_defs pr defs] specifies that [pr] is valid only in - a context where the definitions [defs] are present. *) - - val lemma_true : term -> rule - (** [lemma_true (true) p] asserts the clause [(true)] *) - - val lemma_preprocess : term -> term -> using:step_id Iter.t -> rule - (** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology - and that [t] has been preprocessed into [u]. - - The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence - closure, and then resolved against the clauses [using] to obtain - a unit equality. - - From now on, [t] and [u] will be used interchangeably. - @return a rule ID for the clause [(t=u)]. *) - - val lemma_rw_clause : - step_id -> res:lit Iter.t -> using:step_id Iter.t -> rule - (** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], - uses the equations [|- p_i = q_i] from [using] - to rewrite some literals of [c] into [res]. This is used to preprocess - literals of a clause (using {!lemma_preprocess} individually). *) -end - -type ('rule, 'step_id, 'term, 'lit) t = - (module S - with type rule = 'rule - and type step_id = 'step_id - and type term = 'term - and type lit = 'lit) - -(** Make a dummy proof with given types *) -module Dummy (A : sig - type rule - type step_id - type term - type lit - - val dummy_rule : rule -end) : - S - with type rule = A.rule - and type step_id = A.step_id - and type term = A.term - and type lit = A.lit = struct - include A - - let lemma_cc _ = dummy_rule - let define_term _ _ = dummy_rule - let proof_p1 _ _ = dummy_rule - let proof_r1 _ _ = dummy_rule - let proof_res ~pivot:_ _ _ = dummy_rule - let with_defs _ _ = dummy_rule - let lemma_true _ = dummy_rule - let lemma_preprocess _ _ ~using:_ = dummy_rule - let lemma_rw_clause _ ~res:_ ~using:_ = dummy_rule -end diff --git a/src/sigs/proof-sat/dune b/src/sigs/proof-sat/dune deleted file mode 100644 index baa7cc5f..00000000 --- a/src/sigs/proof-sat/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_sigs_proof_sat) - (public_name sidekick.sigs.proof.sat) - (synopsis "SAT-solving rules for proof traces") - (flags :standard -open Sidekick_util) - (libraries containers iter sidekick.util sidekick.sigs)) diff --git a/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml b/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml deleted file mode 100644 index c9b20417..00000000 --- a/src/sigs/proof-sat/sidekick_sigs_proof_sat.ml +++ /dev/null @@ -1,22 +0,0 @@ -(** Proof rules for SAT Solver reasoning *) - -module type S = sig - type rule - (** The stored proof (possibly nil, possibly on disk, possibly in memory) *) - - type step_id - (** identifier for a proof *) - - type lit - (** A boolean literal for the proof trace *) - - val sat_input_clause : lit Iter.t -> rule - (** Emit an input clause. *) - - val sat_redundant_clause : lit Iter.t -> hyps:step_id Iter.t -> rule - (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. - The clause must be RUP wrt [hyps]. *) - - val sat_unsat_core : lit Iter.t -> rule - (** TODO: is this relevant here? *) -end diff --git a/src/sigs/proof-trace/dune b/src/sigs/proof-trace/dune deleted file mode 100644 index 19c97cd6..00000000 --- a/src/sigs/proof-trace/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name sidekick_sigs_proof_trace) - (public_name sidekick.sigs.proof-trace) - (synopsis "Common definition for proof traces") - (libraries containers iter sidekick.sigs sidekick.util)) diff --git a/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml b/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml deleted file mode 100644 index 83ee8d3f..00000000 --- a/src/sigs/proof-trace/sidekick_sigs_proof_trace.ml +++ /dev/null @@ -1,42 +0,0 @@ -(** Proof traces. -*) - -open Sidekick_util - -module type ARG = sig - type rule - - type step_id - (** Identifier for a tracing step (like a unique ID for a clause previously - added/proved) *) - - module Step_vec : Vec_sig.BASE with type elt = step_id - (** A vector indexed by steps. *) -end - -module type S = sig - module A : ARG - - type t - (** The proof trace itself. - - A proof trace is a log of all deductive steps taken by the solver, - so we can later reconstruct a certificate for proof-checking. - - Each step in the proof trace should be a {b valid - lemma} (of its theory) or a {b valid consequence} of previous steps. - *) - - val enabled : t -> bool - (** Is proof tracing enabled? *) - - val add_step : t -> A.rule -> A.step_id - (** Create a new step in the trace. *) - - val add_unsat : t -> A.step_id -> unit - (** Signal "unsat" result at the given proof *) - - val delete : t -> A.step_id -> unit - (** Forget a step that won't be used in the rest of the trace. - Only useful for performance/memory considerations. *) -end diff --git a/src/sigs/term/dune b/src/sigs/term/dune deleted file mode 100644 index 3c461792..00000000 --- a/src/sigs/term/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name sidekick_sigs_term) - (public_name sidekick.sigs.term) - (synopsis "Common definition for terms and types") - (libraries containers iter sidekick.sigs)) diff --git a/src/sigs/term/sidekick_sigs_term.ml b/src/sigs/term/sidekick_sigs_term.ml deleted file mode 100644 index bf82f0c7..00000000 --- a/src/sigs/term/sidekick_sigs_term.ml +++ /dev/null @@ -1,80 +0,0 @@ -(** Main representation of Terms and Types *) -module type S = sig - module Fun : Sidekick_sigs.EQ_HASH_PRINT - (** A function symbol, like "f" or "plus" or "is_human" or "socrates" *) - - (** Types - - Types should be comparable (ideally, in O(1)), and have - at least a boolean type available. *) - module Ty : sig - include Sidekick_sigs.EQ_HASH_PRINT - - type store - - val bool : store -> t - val is_bool : t -> bool - end - - (** Term structure. - - Terms should be {b hashconsed}, with perfect sharing. - This allows, for example, {!Term.Tbl} and {!Term.iter_dag} to be efficient. - *) - module Term : sig - include Sidekick_sigs.EQ_ORD_HASH_PRINT - - type store - (** A store used to create new terms. It is where the hashconsing - table should live, along with other all-terms related store. *) - - val ty : t -> Ty.t - - val bool : store -> bool -> t - (** build true/false *) - - val as_bool : t -> bool option - (** [as_bool t] is [Some true] if [t] is the term [true], and similarly - for [false]. For other terms it is [None]. *) - - val abs : store -> t -> t * bool - (** [abs t] returns an "absolute value" for the term, along with the - sign of [t]. - - The idea is that we want to turn [not a] into [(a, false)], - or [(a != b)] into [(a=b, false)]. For terms without a negation this - should return [(t, true)]. - - The store is passed in case a new term needs to be created. *) - - val map_shallow : store -> (t -> t) -> t -> t - (** Map function on immediate subterms. This should not be recursive. *) - - val iter_shallow : store -> (t -> unit) -> t -> unit - (** Iterate function on immediate subterms. This should not be recursive. *) - - val iter_dag : t -> (t -> unit) -> unit - (** [iter_dag t f] calls [f] once on each subterm of [t], [t] included. - It must {b not} traverse [t] as a tree, but rather as a - perfectly shared DAG. - - For example, in: - {[ - let x = 2 in - let y = f x x in - let z = g y x in - z = z - ]} - - the DAG has the following nodes: - - {[ n1: 2 - n2: f n1 n1 - n3: g n2 n1 - n4: = n3 n3 - ]} - *) - - module Tbl : CCHashtbl.S with type key = t - end -end From dd50ab079e2d967b7c93f9451c97e3f5e8f33d50 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 30 Jul 2022 23:59:15 -0400 Subject: [PATCH 060/174] remove most proof-trace code --- .../dummy/Sidekick_proof_trace_dummy.ml | 35 ------------------- src/proof-trace/dummy/dune | 6 ---- .../dyn/Sidekick_proof_trace_dyn.ml | 23 ------------ src/proof-trace/dyn/dune | 6 ---- .../bare/dump => proof-tracy-bare-dump}/dune | 0 .../proof_trace_dump.ml | 0 6 files changed, 70 deletions(-) delete mode 100644 src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml delete mode 100644 src/proof-trace/dummy/dune delete mode 100644 src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml delete mode 100644 src/proof-trace/dyn/dune rename src/{proof-trace/bare/dump => proof-tracy-bare-dump}/dune (100%) rename src/{proof-trace/bare/dump => proof-tracy-bare-dump}/proof_trace_dump.ml (100%) diff --git a/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml b/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml deleted file mode 100644 index 15b463ed..00000000 --- a/src/proof-trace/dummy/Sidekick_proof_trace_dummy.ml +++ /dev/null @@ -1,35 +0,0 @@ -(** Dummy proof traces. - - These proof traces will not record information. *) - -module type S = Sidekick_sigs_proof_trace.S - -module type ARG = sig - include Sidekick_sigs_proof_trace.ARG - - val dummy_step_id : step_id -end - -module Make (A : ARG) : S with type t = unit and module A = A = struct - module A = A - - type t = unit - - let enabled _ = false - let add_step _ _ = A.dummy_step_id - let add_unsat _ _ = () - let delete _ _ = () -end - -(** Dummy proof trace where everything is [unit]. Use this if you don't care - for proofs at all. *) -module Unit : - S with type t = unit and type A.rule = unit and type A.step_id = unit = -Make (struct - type rule = unit - type step_id = unit - - module Step_vec = Vec_unit - - let dummy_step_id = () -end) diff --git a/src/proof-trace/dummy/dune b/src/proof-trace/dummy/dune deleted file mode 100644 index 57140a75..00000000 --- a/src/proof-trace/dummy/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_proof_trace_dummy) - (public_name sidekick.proof-trace.dummy) - (synopsis "Dummy proof trace that stores nothing") - (libraries sidekick.util sidekick.sigs.proof-trace) - (flags :standard -open Sidekick_util)) diff --git a/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml b/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml deleted file mode 100644 index 9deee8f7..00000000 --- a/src/proof-trace/dyn/Sidekick_proof_trace_dyn.ml +++ /dev/null @@ -1,23 +0,0 @@ -module type ARG = Sidekick_sigs_proof_trace.ARG -module type S = Sidekick_sigs_proof_trace.S - -(** Dynamic version. - - The proof trace is a first-class module that can be provided at runtime. *) -module Make_dyn (A : ARG) : S with module A = A = struct - module A = A - - module type DYN = sig - val enabled : unit -> bool - val add_step : A.rule -> A.step_id - val add_unsat : A.step_id -> unit - val delete : A.step_id -> unit - end - - type t = (module DYN) - - let[@inline] enabled ((module Tr) : t) : bool = Tr.enabled () - let[@inline] add_step ((module Tr) : t) rule : A.step_id = Tr.add_step rule - let[@inline] add_unsat ((module Tr) : t) s : unit = Tr.add_unsat s - let[@inline] delete ((module Tr) : t) s : unit = Tr.delete s -end diff --git a/src/proof-trace/dyn/dune b/src/proof-trace/dyn/dune deleted file mode 100644 index 24ca6785..00000000 --- a/src/proof-trace/dyn/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name sidekick_proof_trace_dyn) - (public_name sidekick.proof-trace.dyn) - (synopsis "Dynamic version of the proof trace") - (libraries sidekick.util sidekick.sigs.proof-trace) - (flags :standard -open Sidekick_util)) diff --git a/src/proof-trace/bare/dump/dune b/src/proof-tracy-bare-dump/dune similarity index 100% rename from src/proof-trace/bare/dump/dune rename to src/proof-tracy-bare-dump/dune diff --git a/src/proof-trace/bare/dump/proof_trace_dump.ml b/src/proof-tracy-bare-dump/proof_trace_dump.ml similarity index 100% rename from src/proof-trace/bare/dump/proof_trace_dump.ml rename to src/proof-tracy-bare-dump/proof_trace_dump.ml From 1edf0541043e451ebb0a39615278956c0bb38ad1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 31 Jul 2022 15:00:27 -0400 Subject: [PATCH 061/174] refactor(proof): use a suspension but keep uniform `Proof_term.data` type this makes proof terms uniformly printable or (de)serializable. --- src/cc/CC.ml | 28 ++++----- src/core/proof_core.ml | 27 +++------ src/core/proof_core.mli | 54 ++++++++--------- src/core/proof_sat.ml | 10 ++-- src/core/proof_sat.mli | 6 +- src/core/proof_term.ml | 16 ++--- src/core/proof_term.mli | 24 ++++---- src/sat/solver.ml | 55 +++++++++-------- src/simplify/sidekick_simplify.ml | 9 +-- src/smt/solver.ml | 6 +- src/smt/solver_internal.ml | 26 ++++---- src/th-bool-static/Sidekick_th_bool_static.ml | 9 +-- src/th-cstor/Sidekick_th_cstor.ml | 2 +- src/th-cstor/Sidekick_th_cstor.mli | 2 +- src/th-data/Sidekick_th_data.ml | 59 ++++++++++--------- src/th-data/th_intf.ml | 16 ++--- src/th-lra/intf.ml | 2 +- src/th-lra/sidekick_th_lra.ml | 20 +++---- src/util/Bag.ml | 2 + src/util/Bag.mli | 1 + 20 files changed, 182 insertions(+), 192 deletions(-) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index a9192ccf..c8722d3f 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -2,12 +2,6 @@ open Types_ type view_as_cc = Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t -open struct - (* proof rules *) - module Rules_ = Proof_core - module P = Proof_trace -end - type e_node = E_node.t (** A node of the congruence closure *) @@ -305,13 +299,13 @@ module Expl_state = struct (* proof of [\/_i ¬lits[i]] *) let proof_of_th_lemmas (self : t) (proof : Proof_trace.t) : Proof_term.step_id = - let p_lits1 = Iter.of_list self.lits |> Iter.map Lit.neg in + let p_lits1 = List.rev_map Lit.neg self.lits in let p_lits2 = - Iter.of_list self.th_lemmas - |> Iter.map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) + self.th_lemmas |> List.rev_map (fun (lit_t_u, _, _) -> Lit.neg lit_t_u) in let p_cc = - P.add_step proof @@ Rules_.lemma_cc (Iter.append p_lits1 p_lits2) + Proof_trace.add_step proof @@ fun () -> + Proof_core.lemma_cc (List.rev_append p_lits1 p_lits2) in let resolve_with_th_proof pr (lit_t_u, sub_proofs, pr_th) = (* pr_th: [sub_proofs |- t=u]. @@ -322,16 +316,16 @@ module Expl_state = struct (fun pr_th (lit_i, hyps_i) -> (* [hyps_i |- lit_i] *) let lemma_i = - P.add_step proof - @@ Rules_.lemma_cc - Iter.(cons lit_i (of_list hyps_i |> map Lit.neg)) + Proof_trace.add_step proof @@ fun () -> + Proof_core.lemma_cc (lit_i :: List.rev_map Lit.neg hyps_i) in (* resolve [lit_i] away. *) - P.add_step proof - @@ Rules_.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) + Proof_trace.add_step proof @@ fun () -> + Proof_core.proof_res ~pivot:(Lit.term lit_i) lemma_i pr_th) pr_th sub_proofs in - P.add_step proof @@ Rules_.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr + Proof_trace.add_step proof @@ fun () -> + Proof_core.proof_res ~pivot:(Lit.term lit_t_u) pr_th pr in (* resolve with theory proofs responsible for some merges, if any. *) List.fold_left resolve_with_th_proof p_cc self.th_lemmas @@ -590,7 +584,7 @@ and task_merge_ self a b e_ab : unit = E_node.pp ra E_node.pp a E_node.pp rb E_node.pp b Expl.pp e_ab); let th = ref false in (* TODO: - C1: P.true_neq_false + C1: Proof_trace.true_neq_false C2: lemma [lits |- true=false] (and resolve on theory proofs) C3: r1 C1 C2 *) diff --git a/src/core/proof_core.ml b/src/core/proof_core.ml index c6b65106..b24d17e7 100644 --- a/src/core/proof_core.ml +++ b/src/core/proof_core.ml @@ -6,33 +6,24 @@ type lit = Lit.t -let lemma_cc lits : Proof_term.t = Proof_term.make ~lits "core.lemma-cc" +let lemma_cc lits : Proof_term.data = Proof_term.make_data ~lits "core.lemma-cc" let define_term t1 t2 = - Proof_term.make ~terms:(Iter.of_list [ t1; t2 ]) "core.define-term" + Proof_term.make_data ~terms:[ t1; t2 ] "core.define-term" -let proof_r1 p1 p2 = - Proof_term.make ~premises:(Iter.of_list [ p1; p2 ]) "core.r1" - -let proof_p1 p1 p2 = - Proof_term.make ~premises:(Iter.of_list [ p1; p2 ]) "core.p1" +let proof_r1 p1 p2 = Proof_term.make_data ~premises:[ p1; p2 ] "core.r1" +let proof_p1 p1 p2 = Proof_term.make_data ~premises:[ p1; p2 ] "core.p1" let proof_res ~pivot p1 p2 = - Proof_term.make ~terms:(Iter.return pivot) - ~premises:(Iter.of_list [ p1; p2 ]) - "core.res" + Proof_term.make_data ~terms:[ pivot ] ~premises:[ p1; p2 ] "core.res" let with_defs pr defs = - Proof_term.make ~premises:(Iter.append (Iter.return pr) defs) "core.with-defs" + Proof_term.make_data ~premises:(pr :: defs) "core.with-defs" -let lemma_true t = Proof_term.make ~terms:(Iter.return t) "core.true" +let lemma_true t = Proof_term.make_data ~terms:[ t ] "core.true" let lemma_preprocess t1 t2 ~using = - Proof_term.make - ~terms:(Iter.of_list [ t1; t2 ]) - ~premises:using "core.preprocess" + Proof_term.make_data ~terms:[ t1; t2 ] ~premises:using "core.preprocess" let lemma_rw_clause pr ~res ~using = - Proof_term.make - ~premises:(Iter.append (Iter.return pr) using) - ~lits:res "core.rw-clause" + Proof_term.make_data ~premises:(pr :: using) ~lits:res "core.rw-clause" diff --git a/src/core/proof_core.mli b/src/core/proof_core.mli index 3641c14d..6e71e413 100644 --- a/src/core/proof_core.mli +++ b/src/core/proof_core.mli @@ -4,56 +4,56 @@ open Sidekick_core_logic type lit = Lit.t -val lemma_cc : lit Iter.t -> Proof_term.t +val lemma_cc : lit list -> Proof_term.data (** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory - of uninterpreted functions. *) + of uninterpreted functions. *) -val define_term : Term.t -> Term.t -> Proof_term.t +val define_term : Term.t -> Term.t -> Proof_term.data (** [define_term cst u proof] defines the new constant [cst] as being equal - to [u]. - The result is a proof of the clause [cst = u] *) + to [u]. + The result is a proof of the clause [cst = u] *) -val proof_p1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t +val proof_p1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.data (** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) - and [p2] proves [C \/ t], is the Proof_term.t that produces [C \/ u], - i.e unit paramodulation. *) + and [p2] proves [C \/ t], is the Proof_term.t that produces [C \/ u], + i.e unit paramodulation. *) -val proof_r1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t +val proof_r1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.data (** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) and [p2] proves [C \/ ¬t], is the Proof_term.t that produces [C \/ u], i.e unit resolution. *) val proof_res : - pivot:Term.t -> Proof_term.step_id -> Proof_term.step_id -> Proof_term.t + pivot:Term.t -> Proof_term.step_id -> Proof_term.step_id -> Proof_term.data (** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] - and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], - is the Proof_term.t that produces [C \/ D], i.e boolean resolution. *) + and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], + is the Proof_term.t that produces [C \/ D], i.e boolean resolution. *) -val with_defs : Proof_term.step_id -> Proof_term.step_id Iter.t -> Proof_term.t +val with_defs : Proof_term.step_id -> Proof_term.step_id list -> Proof_term.data (** [with_defs pr defs] specifies that [pr] is valid only in a context where the definitions [defs] are present. *) -val lemma_true : Term.t -> Proof_term.t +val lemma_true : Term.t -> Proof_term.data (** [lemma_true (true) p] asserts the clause [(true)] *) val lemma_preprocess : - Term.t -> Term.t -> using:Proof_term.step_id Iter.t -> Proof_term.t + Term.t -> Term.t -> using:Proof_term.step_id list -> Proof_term.data (** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology - and that [t] has been preprocessed into [u]. + and that [t] has been preprocessed into [u]. - The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence - closure, and then resolved against the clauses [using] to obtain - a unit equality. + The theorem [/\_{eqn in using} eqn |- t=u] is proved using congruence + closure, and then resolved against the clauses [using] to obtain + a unit equality. - From now on, [t] and [u] will be used interchangeably. - @return a Proof_term.t ID for the clause [(t=u)]. *) + From now on, [t] and [u] will be used interchangeably. + @return a Proof_term.t ID for the clause [(t=u)]. *) val lemma_rw_clause : Proof_term.step_id -> - res:lit Iter.t -> - using:Proof_term.step_id Iter.t -> - Proof_term.t + res:lit list -> + using:Proof_term.step_id list -> + Proof_term.data (** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], - uses the equations [|- p_i = q_i] from [using] - to rewrite some literals of [c] into [res]. This is used to preprocess - literals of a clause (using {!lemma_preprocess} individually). *) + uses the equations [|- p_i = q_i] from [using] + to rewrite some literals of [c] into [res]. This is used to preprocess + literals of a clause (using {!lemma_preprocess} individually). *) diff --git a/src/core/proof_sat.ml b/src/core/proof_sat.ml index 15cb809b..63707072 100644 --- a/src/core/proof_sat.ml +++ b/src/core/proof_sat.ml @@ -1,8 +1,10 @@ type lit = Lit.t -let sat_input_clause lits : Proof_term.t = Proof_term.make "sat.input" ~lits +let sat_input_clause lits : Proof_term.data = + Proof_term.make_data "sat.input" ~lits -let sat_redundant_clause lits ~hyps : Proof_term.t = - Proof_term.make "sat.rup" ~lits ~premises:hyps +let sat_redundant_clause lits ~hyps : Proof_term.data = + Proof_term.make_data "sat.rup" ~lits ~premises:(Iter.to_rev_list hyps) -let sat_unsat_core lits : Proof_term.t = Proof_term.make ~lits "sat.unsat-core" +let sat_unsat_core lits : Proof_term.data = + Proof_term.make_data ~lits "sat.unsat-core" diff --git a/src/core/proof_sat.mli b/src/core/proof_sat.mli index c9d89a54..f26abdcf 100644 --- a/src/core/proof_sat.mli +++ b/src/core/proof_sat.mli @@ -4,12 +4,12 @@ open Proof_term type lit = Lit.t -val sat_input_clause : lit Iter.t -> Proof_term.t +val sat_input_clause : lit list -> Proof_term.data (** Emit an input clause. *) -val sat_redundant_clause : lit Iter.t -> hyps:step_id Iter.t -> Proof_term.t +val sat_redundant_clause : lit list -> hyps:step_id Iter.t -> Proof_term.data (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. The clause must be RUP wrt [hyps]. *) -val sat_unsat_core : lit Iter.t -> Proof_term.t +val sat_unsat_core : lit list -> Proof_term.data (** TODO: is this relevant here? *) diff --git a/src/core/proof_term.ml b/src/core/proof_term.ml index 0600a51a..ae0db5b3 100644 --- a/src/core/proof_term.ml +++ b/src/core/proof_term.ml @@ -3,18 +3,20 @@ open Sidekick_core_logic type step_id = Proof_step.id type lit = Lit.t -type t = { +type data = { rule_name: string; - lit_args: lit Iter.t; - term_args: Term.t Iter.t; - subst_args: Subst.t Iter.t; - premises: step_id Iter.t; + lit_args: lit list; + term_args: Term.t list; + subst_args: Subst.t list; + premises: step_id list; } +type t = unit -> data + let pp out _ = Fmt.string out "" (* TODO *) -let make ?(lits = Iter.empty) ?(terms = Iter.empty) ?(substs = Iter.empty) - ?(premises = Iter.empty) rule_name : t = +let make_data ?(lits = []) ?(terms = []) ?(substs = []) ?(premises = []) + rule_name : data = { rule_name; lit_args = lits; diff --git a/src/core/proof_term.mli b/src/core/proof_term.mli index 81ef09c3..c74a2ea4 100644 --- a/src/core/proof_term.mli +++ b/src/core/proof_term.mli @@ -7,20 +7,22 @@ open Sidekick_core_logic type step_id = Proof_step.id type lit = Lit.t -type t = { +type data = { rule_name: string; - lit_args: lit Iter.t; - term_args: Term.t Iter.t; - subst_args: Subst.t Iter.t; - premises: step_id Iter.t; + lit_args: lit list; + term_args: Term.t list; + subst_args: Subst.t list; + premises: step_id list; } +type t = unit -> data + include Sidekick_sigs.PRINT with type t := t -val make : - ?lits:lit Iter.t -> - ?terms:Term.t Iter.t -> - ?substs:Subst.t Iter.t -> - ?premises:step_id Iter.t -> +val make_data : + ?lits:lit list -> + ?terms:Term.t list -> + ?substs:Subst.t list -> + ?premises:step_id list -> string -> - t + data diff --git a/src/sat/solver.ml b/src/sat/solver.ml index 61e6f43e..c4399c2e 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -467,10 +467,10 @@ let rec proof_of_atom_lvl0_ (self : t) (a : atom) : Proof_step.id = if !steps = [] then proof_c2 else - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.return (Atom.lit self.store a)) - ~hyps:Iter.(cons proof_c2 (of_list !steps)) + Proof_trace.add_step self.proof @@ fun () -> + Proof_sat.sat_redundant_clause + [ Atom.lit self.store a ] + ~hyps:Iter.(cons proof_c2 (of_list !steps)) in Atom.set_proof_lvl0 self.store a p; @@ -559,11 +559,12 @@ let preprocess_clause_ (self : t) (c : Clause.t) : Clause.t = k "(@[sat.add-clause.resolved-lvl-0@ :into [@[%a@]]@])" (Atom.debug_a store) atoms); let proof = - let lits = Iter.of_array atoms |> Iter.map (Atom.lit store) in - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause lits - ~hyps: - Iter.(cons (Clause.proof_step self.store c) (of_list !res0_proofs)) + Proof_trace.add_step self.proof @@ fun () -> + let lits = Util.array_to_list_map (Atom.lit store) atoms in + let hyps = + Iter.(cons (Clause.proof_step self.store c) (of_list !res0_proofs)) + in + Proof_sat.sat_redundant_clause lits ~hyps in Clause.make_a store atoms proof ~removable:(Clause.removable store c) ) @@ -1005,10 +1006,9 @@ let record_learnt_clause (self : t) ~pool (cr : conflict_res) : unit = assert (cr.cr_backtrack_lvl = 0 && decision_level self = 0); let p = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) + Proof_trace.add_step self.proof @@ fun () -> + let lits = Util.array_to_list_map (Atom.lit self.store) cr.cr_learnt in + Proof_sat.sat_redundant_clause lits ~hyps:(Step_vec.to_iter cr.cr_steps) in let uclause = Clause.make_a store ~removable:true cr.cr_learnt p in Event.emit self.on_learnt uclause; @@ -1022,10 +1022,9 @@ let record_learnt_clause (self : t) ~pool (cr : conflict_res) : unit = | _ -> let fuip = cr.cr_learnt.(0) in let p = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause - (Iter.of_array cr.cr_learnt |> Iter.map (Atom.lit self.store)) - ~hyps:(Step_vec.to_iter cr.cr_steps) + Proof_trace.add_step self.proof @@ fun () -> + let lits = Util.array_to_list_map (Atom.lit self.store) cr.cr_learnt in + Proof_sat.sat_redundant_clause lits ~hyps:(Step_vec.to_iter cr.cr_steps) in let lclause = Clause.make_a store ~removable:true cr.cr_learnt p in @@ -1741,8 +1740,8 @@ let assume self cnf : unit = (fun l -> let atoms = Util.array_of_list_map (make_atom_ self) l in let proof = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_list l) + Proof_trace.add_step self.proof @@ fun () -> + Proof_sat.sat_input_clause l in let c = Clause.make_a self.store ~removable:false atoms proof in Log.debugf 10 (fun k -> @@ -1825,10 +1824,10 @@ let resolve_with_lvl0 (self : t) (c : clause) : clause = (* no resolution happened *) else ( let proof = - let lits = Iter.of_list !res |> Iter.map (Atom.lit self.store) in + Proof_trace.add_step self.proof @@ fun () -> + let lits = List.rev_map (Atom.lit self.store) !res in let hyps = Iter.of_list (Clause.proof_step self.store c :: !lvl0) in - Proof_trace.add_step self.proof - @@ Proof_sat.sat_redundant_clause lits ~hyps + Proof_sat.sat_redundant_clause lits ~hyps in Clause.make_l self.store ~removable:false !res proof ) @@ -1861,8 +1860,9 @@ let mk_unsat (self : t) (us : unsat_cause) : _ unsat_state = (* increasing trail order *) assert (Atom.equal first @@ List.hd core); let proof = - let lits = Iter.of_list core |> Iter.map (Atom.lit self.store) in - Proof_trace.add_step self.proof @@ Proof_sat.sat_unsat_core lits + Proof_trace.add_step self.proof @@ fun () -> + let lits = List.rev_map (Atom.lit self.store) core in + Proof_sat.sat_unsat_core lits in Clause.make_l self.store ~removable:false [] proof) in @@ -1937,15 +1937,14 @@ let add_clause self (c : Lit.t list) (pr : Proof_step.id) : unit = let add_input_clause self (c : Lit.t list) = let pr = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_list c) + Proof_trace.add_step self.proof @@ fun () -> Proof_sat.sat_input_clause c in add_clause self c pr let add_input_clause_a self c = let pr = - Proof_trace.add_step self.proof - @@ Proof_sat.sat_input_clause (Iter.of_array c) + Proof_trace.add_step self.proof @@ fun () -> + Proof_sat.sat_input_clause (Array.to_list c) in add_clause_a self c pr diff --git a/src/simplify/sidekick_simplify.ml b/src/simplify/sidekick_simplify.ml index 2daa4114..3a49c947 100644 --- a/src/simplify/sidekick_simplify.ml +++ b/src/simplify/sidekick_simplify.ml @@ -1,10 +1,5 @@ open Sidekick_core -open struct - module P = Proof_trace - module Rule_ = Proof_core -end - type t = { tst: Term.store; proof: Proof_trace.t; @@ -68,8 +63,8 @@ let normalize (self : t) (t : Term.t) : (Term.t * Proof_step.id) option = else ( (* proof: [sub_proofs |- t=u] by CC + subproof *) let step = - P.add_step self.proof - @@ Rule_.lemma_preprocess t u ~using:(Bag.to_iter pr_u) + Proof_trace.add_step self.proof @@ fun () -> + Proof_core.lemma_preprocess t u ~using:(Bag.to_list pr_u) in Some (u, step) ) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 670a5630..fb71706c 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -113,7 +113,7 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = let t_true = Term.true_ tst in Sat_solver.add_clause self.solver [ Lit.atom t_true ] - (P.add_step self.proof @@ Rule_.lemma_true t_true)); + (P.add_step self.proof @@ fun () -> Rule_.lemma_true t_true)); self let[@inline] solver self = self.solver @@ -173,9 +173,7 @@ let add_clause_l self c p = add_clause self (CCArray.of_list c) p let assert_terms self c = let c = CCList.map Lit.atom c in - let pr_c = - P.add_step self.proof @@ Proof_sat.sat_input_clause (Iter.of_list c) - in + let pr_c = P.add_step self.proof @@ fun () -> Proof_sat.sat_input_clause c in add_clause_l self c pr_c let assert_term self t = assert_terms self [ t ] diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 35d28732..e6e73bb9 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -1,13 +1,6 @@ open Sigs -module Proof_rules = Sidekick_core.Proof_sat -module P_core_rules = Sidekick_core.Proof_core module Ty = Term -open struct - module P = Proof_trace - module Rule_ = Proof_core -end - type th_states = | Ths_nil | Ths_cons : { @@ -200,7 +193,7 @@ module type ARR = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t - val to_iter : 'a t -> 'a Iter.t + val to_list : 'a t -> 'a list end module Preprocess_clause (A : ARR) = struct @@ -222,16 +215,21 @@ module Preprocess_clause (A : ARR) = struct pr_c else ( Stat.incr self.count_preprocess_clause; - P.add_step self.proof - @@ Rule_.lemma_rw_clause pr_c ~res:(A.to_iter c') - ~using:(Iter.of_list !steps) + Proof_trace.add_step self.proof @@ fun () -> + Proof_core.lemma_rw_clause pr_c ~res:(A.to_list c') ~using:!steps ) in c', pr_c' end [@@inline] -module PC_list = Preprocess_clause (CCList) +module PC_list = Preprocess_clause (struct + type 'a t = 'a list + + let map = CCList.map + let to_list l = l +end) + module PC_arr = Preprocess_clause (CCArray) let preprocess_clause = PC_list.top @@ -518,7 +516,9 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) in let c = List.rev_append c1 c2 in - let pr = P.add_step self.proof @@ Rule_.lemma_cc (Iter.of_list c) in + let pr = + Proof_trace.add_step self.proof @@ fun () -> Proof_core.lemma_cc c + in Log.debugf 20 (fun k -> k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index f18edbfd..c0e61cad 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -36,8 +36,9 @@ end = struct let add_step_eq a b ~using ~c0 : unit = add_step_ @@ mk_step_ - @@ Proof_core.lemma_rw_clause c0 ~using - ~res:(Iter.return (Lit.atom (A.mk_bool tst (B_eq (a, b))))) + @@ fun () -> + Proof_core.lemma_rw_clause c0 ~using + ~res:[ Lit.atom (A.mk_bool tst (B_eq (a, b))) ] in let[@inline] ret u = Some (u, Iter.of_list !steps) in @@ -81,11 +82,11 @@ end = struct Option.iter add_step_ prf_a; (match A.view_as_bool a with | B_bool true -> - add_step_eq t b ~using:(Iter.of_opt prf_a) + add_step_eq t b ~using:(Option.to_list prf_a) ~c0:(mk_step_ @@ A.P.lemma_ite_true ~ite:t); ret b | B_bool false -> - add_step_eq t c ~using:(Iter.of_opt prf_a) + add_step_eq t c ~using:(Option.to_list prf_a) ~c0:(mk_step_ @@ A.P.lemma_ite_false ~ite:t); ret c | _ -> None) diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index 67a4845a..31c8ae3c 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -9,7 +9,7 @@ let name = "th-cstor" module type ARG = sig val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view - val lemma_cstor : Lit.t Iter.t -> Proof_term.t + val lemma_cstor : Lit.t list -> Proof_term.data end module Make (A : ARG) : sig diff --git a/src/th-cstor/Sidekick_th_cstor.mli b/src/th-cstor/Sidekick_th_cstor.mli index 0cf658a9..024e06da 100644 --- a/src/th-cstor/Sidekick_th_cstor.mli +++ b/src/th-cstor/Sidekick_th_cstor.mli @@ -7,7 +7,7 @@ type ('c, 't) cstor_view = T_cstor of 'c * 't array | T_other of 't module type ARG = sig val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view - val lemma_cstor : Lit.t Iter.t -> Proof_term.t + val lemma_cstor : Lit.t list -> Proof_term.data end val make : (module ARG) -> SMT.theory diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index bcaae31a..956bec1b 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -186,7 +186,7 @@ end = struct let t1 = E_node.term c1.c_n in let t2 = E_node.term c2.c_n in mk_expl t1 t2 @@ Proof_trace.add_step proof - @@ A.P.lemma_cstor_inj t1 t2 i + @@ fun () -> A.P.lemma_cstor_inj t1 t2 i in assert (CCArray.length c1.c_args = CCArray.length c2.c_args); @@ -199,7 +199,7 @@ end = struct let expl = let t1 = E_node.term c1.c_n and t2 = E_node.term c2.c_n in mk_expl t1 t2 @@ Proof_trace.add_step proof - @@ A.P.lemma_cstor_distinct t1 t2 + @@ fun () -> A.P.lemma_cstor_distinct t1 t2 in Error (CC.Handler_action.Conflict expl) @@ -332,15 +332,14 @@ end = struct with exhaustiveness: [|- is-c(t)] *) let proof = let pr_isa = - Proof_trace.add_step self.proof - @@ A.P.lemma_isa_split t - (Iter.return @@ Act.mk_lit (A.mk_is_a self.tst cstor t)) + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_isa_split t [ Lit.atom (A.mk_is_a self.tst cstor t) ] and pr_eq_sel = - Proof_trace.add_step self.proof - @@ A.P.lemma_select_cstor ~cstor_t:u t + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_select_cstor ~cstor_t:u t in - Proof_trace.add_step self.proof - @@ Proof_core.proof_r1 pr_isa pr_eq_sel + Proof_trace.add_step self.proof @@ fun () -> + Proof_core.proof_r1 pr_isa pr_eq_sel in Term.Tbl.add self.single_cstor_preproc_done t (); @@ -394,8 +393,8 @@ end = struct %a@])" name Term.pp_debug t is_true E_node.pp n Monoid_cstor.pp cstor); let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_isa_cstor ~cstor_t:(E_node.term cstor.c_n) t + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_isa_cstor ~cstor_t:(E_node.term cstor.c_n) t in let n_bool = CC.n_bool cc is_true in let expl = @@ -421,8 +420,8 @@ end = struct assert (i < CCArray.length cstor.c_args); let u_i = CCArray.get cstor.c_args i in let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_select_cstor ~cstor_t:(E_node.term cstor.c_n) t + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_select_cstor ~cstor_t:(E_node.term cstor.c_n) t in let expl = Expl.( @@ -458,9 +457,9 @@ end = struct name Monoid_parents.pp_is_a is_a2 is_true E_node.pp n1 E_node.pp n2 Monoid_cstor.pp c1); let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_isa_cstor ~cstor_t:(E_node.term c1.c_n) - (E_node.term is_a2.is_a_n) + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_isa_cstor ~cstor_t:(E_node.term c1.c_n) + (E_node.term is_a2.is_a_n) in let n_bool = CC.n_bool cc is_true in let expl = @@ -487,9 +486,9 @@ end = struct E_node.pp n2 sel2.sel_idx Monoid_cstor.pp c1); assert (sel2.sel_idx < CCArray.length c1.c_args); let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_select_cstor ~cstor_t:(E_node.term c1.c_n) - (E_node.term sel2.sel_n) + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_select_cstor ~cstor_t:(E_node.term c1.c_n) + (E_node.term sel2.sel_n) in let u_i = CCArray.get c1.c_args sel2.sel_idx in let expl = @@ -598,10 +597,13 @@ end = struct (* conflict: the [path] forms a cycle *) let path = (n, node) :: path in let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_acyclicity - (Iter.of_list path - |> Iter.map (fun (a, b) -> E_node.term a, E_node.term b.repr)) + Proof_trace.add_step self.proof @@ fun () -> + let path = + List.rev_map + (fun (a, b) -> E_node.term a, E_node.term b.repr) + path + in + A.P.lemma_acyclicity path in let expl = let subs = @@ -654,7 +656,9 @@ end = struct Log.debugf 50 (fun k -> k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name Term.pp_debug u Term.pp_debug rhs Lit.pp lit); - let pr = Proof_trace.add_step self.proof @@ A.P.lemma_isa_sel t in + let pr = + Proof_trace.add_step self.proof @@ fun () -> A.P.lemma_isa_sel t + in (* merge [u] and [rhs] *) CC.merge_t (SI.cc solver) u rhs (Expl.mk_theory u rhs @@ -680,12 +684,11 @@ end = struct |> Iter.to_rev_list in SI.add_clause_permanent solver acts c - (Proof_trace.add_step self.proof - @@ A.P.lemma_isa_split t (Iter.of_list c)); + (Proof_trace.add_step self.proof @@ fun () -> A.P.lemma_isa_split t c); Iter.diagonal_l c (fun (l1, l2) -> let pr = - Proof_trace.add_step self.proof - @@ A.P.lemma_isa_disj (Lit.neg l1) (Lit.neg l2) + Proof_trace.add_step self.proof @@ fun () -> + A.P.lemma_isa_disj (Lit.neg l1) (Lit.neg l2) in SI.add_clause_permanent solver acts [ Lit.neg l1; Lit.neg l2 ] pr) ) diff --git a/src/th-data/th_intf.ml b/src/th-data/th_intf.ml index 1004e5b0..500f7b85 100644 --- a/src/th-data/th_intf.ml +++ b/src/th-data/th_intf.ml @@ -22,35 +22,35 @@ type ('c, 'ty) data_ty_view = | Ty_other module type PROOF_RULES = sig - val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t + val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.data (** [lemma_isa_cstor (d …) (is-c t)] returns the clause [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) - val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t + val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.data (** [lemma_select_cstor (c t1…tn) (sel-c-i t)] returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) - val lemma_isa_split : Term.t -> Lit.t Iter.t -> Proof_term.t + val lemma_isa_split : Term.t -> Lit.t list -> Proof_term.data (** [lemma_isa_split t lits] is the proof of [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) - val lemma_isa_sel : Term.t -> Proof_term.t + val lemma_isa_sel : Term.t -> Proof_term.data (** [lemma_isa_sel (is-c t)] is the proof of [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) - val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.t + val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.data (** [lemma_isa_disj (is-c t) (is-d t)] is the proof of [¬ (is-c t) \/ ¬ (is-c t)] *) - val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.t + val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.data (** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of [c t1…tn = c u1…un |- ti = ui] *) - val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.t + val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.data (** [lemma_isa_distinct (c …) (d …)] is the proof of the unit clause [|- (c …) ≠ (d …)] *) - val lemma_acyclicity : (Term.t * Term.t) Iter.t -> Proof_term.t + val lemma_acyclicity : (Term.t * Term.t) list -> Proof_term.data (** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] by acyclicity. *) end diff --git a/src/th-lra/intf.ml b/src/th-lra/intf.ml index c9b60c30..8e2cd63f 100644 --- a/src/th-lra/intf.ml +++ b/src/th-lra/intf.ml @@ -44,7 +44,7 @@ module type ARG = sig val has_ty_real : Term.t -> bool (** Does this term have the type [Real] *) - val lemma_lra : Lit.t Iter.t -> Proof_term.t + val lemma_lra : Lit.t list -> Proof_term.data module Gensym : sig type t diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index 80bd87cd..d1666f2d 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -248,13 +248,13 @@ module Make (A : ARG) = (* : S with module A = A *) struct proxy) let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = - let pr = Proof_trace.add_step PA.proof @@ A.lemma_lra (Iter.of_list lits) in + let pr = Proof_trace.add_step PA.proof @@ fun () -> A.lemma_lra lits in let pr = match using with | None -> pr | Some using -> - Proof_trace.add_step PA.proof - @@ Proof_core.lemma_rw_clause pr ~res:(Iter.of_list lits) ~using + Proof_trace.add_step PA.proof @@ fun () -> + Proof_core.lemma_rw_clause pr ~res:lits ~using in PA.add_clause lits pr @@ -396,12 +396,12 @@ module Make (A : ARG) = (* : S with module A = A *) struct let simplify (self : state) (_recurse : _) (t : Term.t) : (Term.t * Proof_step.id Iter.t) option = let proof_eq t u = - Proof_trace.add_step self.proof - @@ A.lemma_lra (Iter.return (Lit.atom (Term.eq self.tst t u))) + Proof_trace.add_step self.proof @@ fun () -> + A.lemma_lra [ Lit.atom (Term.eq self.tst t u) ] in let proof_bool t ~sign:b = let lit = Lit.atom ~sign:b t in - Proof_trace.add_step self.proof @@ A.lemma_lra (Iter.return lit) + Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] in match A.view_as_lra t with @@ -467,7 +467,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct |> List.rev_map Lit.neg in let pr = - Proof_trace.add_step (SI.proof si) @@ A.lemma_lra (Iter.of_list confl) + Proof_trace.add_step (SI.proof si) @@ fun () -> A.lemma_lra confl in SI.raise_conflict si acts confl pr @@ -478,8 +478,8 @@ module Make (A : ARG) = (* : S with module A = A *) struct SI.propagate si acts lit ~reason:(fun () -> let lits = CCList.flat_map (Tag.to_lits si) reason in let pr = - Proof_trace.add_step (SI.proof si) - @@ A.lemma_lra Iter.(cons lit (of_list lits)) + Proof_trace.add_step (SI.proof si) @@ fun () -> + A.lemma_lra (lit :: lits) in CCList.flat_map (Tag.to_lits si) reason, pr) | _ -> () @@ -525,7 +525,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* [c=0] when [c] is not 0 *) let lit = Lit.atom ~sign:false @@ Term.eq self.tst t1 t2 in let pr = - Proof_trace.add_step self.proof @@ A.lemma_lra (Iter.return lit) + Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] in SI.add_clause_permanent si acts [ lit ] pr ) diff --git a/src/util/Bag.ml b/src/util/Bag.ml index 53e0800b..ed020939 100644 --- a/src/util/Bag.ml +++ b/src/util/Bag.ml @@ -44,6 +44,8 @@ let rec fold f acc = function | L x -> f acc x | N (a, b) -> fold f (fold f acc a) b +let to_list self = fold (fun acc x -> x :: acc) [] self + let[@unroll 2] rec to_iter t yield = match t with | E -> () diff --git a/src/util/Bag.mli b/src/util/Bag.mli index 641e4dc4..2eb559eb 100644 --- a/src/util/Bag.mli +++ b/src/util/Bag.mli @@ -15,6 +15,7 @@ val snoc : 'a t -> 'a -> 'a t val append : 'a t -> 'a t -> 'a t val of_iter : 'a Iter.t -> 'a t val to_iter : 'a t -> 'a Iter.t +val to_list : 'a t -> 'a list val fold : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a val iter : ('a -> unit) -> 'a t -> unit From 4aec4fe4917221c011a5a023ca077e88ff1f5b40 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 1 Aug 2022 20:42:45 -0400 Subject: [PATCH 062/174] refactor(proofs): make proof terms a recursive term --- src/core/proof_core.ml | 18 ++++----- src/core/proof_core.mli | 18 ++++----- src/core/proof_sat.ml | 12 +++--- src/core/proof_sat.mli | 6 +-- src/core/proof_term.ml | 38 +++++++++++++------ src/core/proof_term.mli | 19 ++++++++-- src/core/proof_trace.ml | 3 +- src/core/proof_trace.mli | 6 +-- src/th-bool-static/Sidekick_th_bool_static.ml | 38 +++++++++---------- src/th-cstor/Sidekick_th_cstor.ml | 2 +- src/th-cstor/Sidekick_th_cstor.mli | 2 +- src/th-data/th_intf.ml | 16 ++++---- src/th-lra/intf.ml | 2 +- 13 files changed, 102 insertions(+), 78 deletions(-) diff --git a/src/core/proof_core.ml b/src/core/proof_core.ml index b24d17e7..7ff4b619 100644 --- a/src/core/proof_core.ml +++ b/src/core/proof_core.ml @@ -6,24 +6,24 @@ type lit = Lit.t -let lemma_cc lits : Proof_term.data = Proof_term.make_data ~lits "core.lemma-cc" +let lemma_cc lits : Proof_term.t = Proof_term.apply_rule ~lits "core.lemma-cc" let define_term t1 t2 = - Proof_term.make_data ~terms:[ t1; t2 ] "core.define-term" + Proof_term.apply_rule ~terms:[ t1; t2 ] "core.define-term" -let proof_r1 p1 p2 = Proof_term.make_data ~premises:[ p1; p2 ] "core.r1" -let proof_p1 p1 p2 = Proof_term.make_data ~premises:[ p1; p2 ] "core.p1" +let proof_r1 p1 p2 = Proof_term.apply_rule ~premises:[ p1; p2 ] "core.r1" +let proof_p1 p1 p2 = Proof_term.apply_rule ~premises:[ p1; p2 ] "core.p1" let proof_res ~pivot p1 p2 = - Proof_term.make_data ~terms:[ pivot ] ~premises:[ p1; p2 ] "core.res" + Proof_term.apply_rule ~terms:[ pivot ] ~premises:[ p1; p2 ] "core.res" let with_defs pr defs = - Proof_term.make_data ~premises:(pr :: defs) "core.with-defs" + Proof_term.apply_rule ~premises:(pr :: defs) "core.with-defs" -let lemma_true t = Proof_term.make_data ~terms:[ t ] "core.true" +let lemma_true t = Proof_term.apply_rule ~terms:[ t ] "core.true" let lemma_preprocess t1 t2 ~using = - Proof_term.make_data ~terms:[ t1; t2 ] ~premises:using "core.preprocess" + Proof_term.apply_rule ~terms:[ t1; t2 ] ~premises:using "core.preprocess" let lemma_rw_clause pr ~res ~using = - Proof_term.make_data ~premises:(pr :: using) ~lits:res "core.rw-clause" + Proof_term.apply_rule ~premises:(pr :: using) ~lits:res "core.rw-clause" diff --git a/src/core/proof_core.mli b/src/core/proof_core.mli index 6e71e413..0a440a06 100644 --- a/src/core/proof_core.mli +++ b/src/core/proof_core.mli @@ -4,40 +4,40 @@ open Sidekick_core_logic type lit = Lit.t -val lemma_cc : lit list -> Proof_term.data +val lemma_cc : lit list -> Proof_term.t (** [lemma_cc proof lits] asserts that [lits] form a tautology for the theory of uninterpreted functions. *) -val define_term : Term.t -> Term.t -> Proof_term.data +val define_term : Term.t -> Term.t -> Proof_term.t (** [define_term cst u proof] defines the new constant [cst] as being equal to [u]. The result is a proof of the clause [cst = u] *) -val proof_p1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.data +val proof_p1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t (** [proof_p1 p1 p2], where [p1] proves the unit clause [t=u] (t:bool) and [p2] proves [C \/ t], is the Proof_term.t that produces [C \/ u], i.e unit paramodulation. *) -val proof_r1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.data +val proof_r1 : Proof_term.step_id -> Proof_term.step_id -> Proof_term.t (** [proof_r1 p1 p2], where [p1] proves the unit clause [|- t] (t:bool) and [p2] proves [C \/ ¬t], is the Proof_term.t that produces [C \/ u], i.e unit resolution. *) val proof_res : - pivot:Term.t -> Proof_term.step_id -> Proof_term.step_id -> Proof_term.data + pivot:Term.t -> Proof_term.step_id -> Proof_term.step_id -> Proof_term.t (** [proof_res ~pivot p1 p2], where [p1] proves the clause [|- C \/ l] and [p2] proves [D \/ ¬l], where [l] is either [pivot] or [¬pivot], is the Proof_term.t that produces [C \/ D], i.e boolean resolution. *) -val with_defs : Proof_term.step_id -> Proof_term.step_id list -> Proof_term.data +val with_defs : Proof_term.step_id -> Proof_term.step_id list -> Proof_term.t (** [with_defs pr defs] specifies that [pr] is valid only in a context where the definitions [defs] are present. *) -val lemma_true : Term.t -> Proof_term.data +val lemma_true : Term.t -> Proof_term.t (** [lemma_true (true) p] asserts the clause [(true)] *) val lemma_preprocess : - Term.t -> Term.t -> using:Proof_term.step_id list -> Proof_term.data + Term.t -> Term.t -> using:Proof_term.step_id list -> Proof_term.t (** [lemma_preprocess t u ~using p] asserts that [t = u] is a tautology and that [t] has been preprocessed into [u]. @@ -52,7 +52,7 @@ val lemma_rw_clause : Proof_term.step_id -> res:lit list -> using:Proof_term.step_id list -> - Proof_term.data + Proof_term.t (** [lemma_rw_clause prc ~res ~using], where [prc] is the proof of [|- c], uses the equations [|- p_i = q_i] from [using] to rewrite some literals of [c] into [res]. This is used to preprocess diff --git a/src/core/proof_sat.ml b/src/core/proof_sat.ml index 63707072..30733098 100644 --- a/src/core/proof_sat.ml +++ b/src/core/proof_sat.ml @@ -1,10 +1,10 @@ type lit = Lit.t -let sat_input_clause lits : Proof_term.data = - Proof_term.make_data "sat.input" ~lits +let sat_input_clause lits : Proof_term.t = + Proof_term.apply_rule "sat.input" ~lits -let sat_redundant_clause lits ~hyps : Proof_term.data = - Proof_term.make_data "sat.rup" ~lits ~premises:(Iter.to_rev_list hyps) +let sat_redundant_clause lits ~hyps : Proof_term.t = + Proof_term.apply_rule "sat.rup" ~lits ~premises:(Iter.to_rev_list hyps) -let sat_unsat_core lits : Proof_term.data = - Proof_term.make_data ~lits "sat.unsat-core" +let sat_unsat_core lits : Proof_term.t = + Proof_term.apply_rule ~lits "sat.unsat-core" diff --git a/src/core/proof_sat.mli b/src/core/proof_sat.mli index f26abdcf..7c94a270 100644 --- a/src/core/proof_sat.mli +++ b/src/core/proof_sat.mli @@ -4,12 +4,12 @@ open Proof_term type lit = Lit.t -val sat_input_clause : lit list -> Proof_term.data +val sat_input_clause : lit list -> Proof_term.t (** Emit an input clause. *) -val sat_redundant_clause : lit list -> hyps:step_id Iter.t -> Proof_term.data +val sat_redundant_clause : lit list -> hyps:step_id Iter.t -> Proof_term.t (** Emit a clause deduced by the SAT solver, redundant wrt previous clauses. The clause must be RUP wrt [hyps]. *) -val sat_unsat_core : lit list -> Proof_term.data +val sat_unsat_core : lit list -> Proof_term.t (** TODO: is this relevant here? *) diff --git a/src/core/proof_term.ml b/src/core/proof_term.ml index ae0db5b3..d4b81516 100644 --- a/src/core/proof_term.ml +++ b/src/core/proof_term.ml @@ -1,9 +1,10 @@ open Sidekick_core_logic type step_id = Proof_step.id +type local_ref = int type lit = Lit.t -type data = { +type rule_apply = { rule_name: string; lit_args: lit list; term_args: Term.t list; @@ -11,16 +12,31 @@ type data = { premises: step_id list; } -type t = unit -> data +type t = + | P_ref of step_id + | P_local of local_ref + | P_let of (local_ref * t) list * t + | P_apply of rule_apply + +type delayed = unit -> t let pp out _ = Fmt.string out "" (* TODO *) -let make_data ?(lits = []) ?(terms = []) ?(substs = []) ?(premises = []) - rule_name : data = - { - rule_name; - lit_args = lits; - subst_args = substs; - term_args = terms; - premises; - } +let local_ref id = P_local id +let ref_ id = P_ref id + +let let_ bs r = + match bs with + | [] -> r + | _ -> P_let (bs, r) + +let apply_rule ?(lits = []) ?(terms = []) ?(substs = []) ?(premises = []) + rule_name : t = + P_apply + { + rule_name; + lit_args = lits; + subst_args = substs; + term_args = terms; + premises; + } diff --git a/src/core/proof_term.mli b/src/core/proof_term.mli index c74a2ea4..351f9cfb 100644 --- a/src/core/proof_term.mli +++ b/src/core/proof_term.mli @@ -5,9 +5,10 @@ open Sidekick_core_logic type step_id = Proof_step.id +type local_ref = int type lit = Lit.t -type data = { +type rule_apply = { rule_name: string; lit_args: lit list; term_args: Term.t list; @@ -15,14 +16,24 @@ type data = { premises: step_id list; } -type t = unit -> data +type t = + | P_ref of step_id + | P_local of local_ref (** Local reference, in a let *) + | P_let of (local_ref * t) list * t + | P_apply of rule_apply + +type delayed = unit -> t include Sidekick_sigs.PRINT with type t := t -val make_data : +val ref_ : step_id -> t +val local_ref : local_ref -> t +val let_ : (local_ref * t) list -> t -> t + +val apply_rule : ?lits:lit list -> ?terms:Term.t list -> ?substs:Subst.t list -> ?premises:step_id list -> string -> - data + t diff --git a/src/core/proof_trace.ml b/src/core/proof_trace.ml index ea51bf3d..6b12bfce 100644 --- a/src/core/proof_trace.ml +++ b/src/core/proof_trace.ml @@ -1,6 +1,5 @@ type lit = Lit.t type step_id = Proof_step.id -type proof_term = Proof_term.t module Step_vec = struct type elt = step_id @@ -26,7 +25,7 @@ end module type DYN = sig val enabled : unit -> bool - val add_step : proof_term -> step_id + val add_step : Proof_term.delayed -> step_id val add_unsat : step_id -> unit val delete : step_id -> unit end diff --git a/src/core/proof_trace.mli b/src/core/proof_trace.mli index 0a3c563b..703308ec 100644 --- a/src/core/proof_trace.mli +++ b/src/core/proof_trace.mli @@ -17,8 +17,6 @@ type step_id = Proof_step.id module Step_vec : Vec_sig.BASE with type elt = step_id (** A vector indexed by steps. *) -type proof_term = Proof_term.t - (** {2 Traces} *) type t @@ -34,7 +32,7 @@ type t val enabled : t -> bool (** Is proof tracing enabled? *) -val add_step : t -> proof_term -> step_id +val add_step : t -> Proof_term.delayed -> step_id (** Create a new step in the trace. *) val add_unsat : t -> step_id -> unit @@ -57,7 +55,7 @@ val dummy : t module type DYN = sig val enabled : unit -> bool - val add_step : proof_term -> step_id + val add_step : Proof_term.delayed -> step_id val add_unsat : step_id -> unit val delete : step_id -> unit end diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index c0e61cad..130735c1 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -44,7 +44,7 @@ end = struct let[@inline] ret u = Some (u, Iter.of_list !steps) in (* proof is [t <=> u] *) let ret_bequiv t1 u = - add_step_ @@ mk_step_ @@ A.P.lemma_bool_equiv t1 u; + (add_step_ @@ mk_step_ @@ fun () -> A.P.lemma_bool_equiv t1 u); ret u in @@ -83,11 +83,11 @@ end = struct (match A.view_as_bool a with | B_bool true -> add_step_eq t b ~using:(Option.to_list prf_a) - ~c0:(mk_step_ @@ A.P.lemma_ite_true ~ite:t); + ~c0:(mk_step_ @@ fun () -> A.P.lemma_ite_true ~ite:t); ret b | B_bool false -> add_step_eq t c ~using:(Option.to_list prf_a) - ~c0:(mk_step_ @@ A.P.lemma_ite_false ~ite:t); + ~c0:(mk_step_ @@ fun () -> A.P.lemma_ite_false ~ite:t); ret c | _ -> None) | B_equiv (a, b) when is_true a -> ret_bequiv t b @@ -140,26 +140,26 @@ end = struct PA.add_clause [ Lit.neg lit; Lit.neg a; b ] (if is_xor then - mk_step_ @@ A.P.lemma_bool_c "xor-e+" [ t ] + mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-e+" [ t ] else - mk_step_ @@ A.P.lemma_bool_c "eq-e" [ t; t_a ]); + mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-e" [ t; t_a ]); PA.add_clause [ Lit.neg lit; Lit.neg b; a ] (if is_xor then - mk_step_ @@ A.P.lemma_bool_c "xor-e-" [ t ] + mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-e-" [ t ] else - mk_step_ @@ A.P.lemma_bool_c "eq-e" [ t; t_b ]); + mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-e" [ t; t_b ]); PA.add_clause [ lit; a; b ] (if is_xor then - mk_step_ @@ A.P.lemma_bool_c "xor-i" [ t; t_a ] + mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-i" [ t; t_a ] else - mk_step_ @@ A.P.lemma_bool_c "eq-i+" [ t ]); + mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-i+" [ t ]); PA.add_clause [ lit; Lit.neg a; Lit.neg b ] (if is_xor then - mk_step_ @@ A.P.lemma_bool_c "xor-i" [ t; t_b ] + mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-i" [ t; t_b ] else - mk_step_ @@ A.P.lemma_bool_c "eq-i-" [ t ]) + mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-i-" [ t ]) in (* make a literal for [t], with a proof of [|- abs(t) = abs(lit)] *) @@ -177,11 +177,11 @@ end = struct (fun t_u u -> PA.add_clause [ Lit.neg lit; u ] - (mk_step_ @@ A.P.lemma_bool_c "and-e" [ t; t_u ])) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "and-e" [ t; t_u ])) t_subs subs; PA.add_clause (lit :: List.map Lit.neg subs) - (mk_step_ @@ A.P.lemma_bool_c "and-i" [ t ]) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "and-i" [ t ]) | B_or l -> let t_subs = Iter.to_list l in let subs = List.map PA.mk_lit t_subs in @@ -192,10 +192,10 @@ end = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (mk_step_ @@ A.P.lemma_bool_c "or-i" [ t; t_u ])) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "or-i" [ t; t_u ])) t_subs subs; PA.add_clause (Lit.neg lit :: subs) - (mk_step_ @@ A.P.lemma_bool_c "or-e" [ t ]) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "or-e" [ t ]) | B_imply (t_args, t_u) -> (* transform into [¬args \/ u] on the fly *) let t_args = Iter.to_list t_args in @@ -211,18 +211,18 @@ end = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (mk_step_ @@ A.P.lemma_bool_c "imp-i" [ t; t_u ])) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "imp-i" [ t; t_u ])) (t_u :: t_args) subs; PA.add_clause (Lit.neg lit :: subs) - (mk_step_ @@ A.P.lemma_bool_c "imp-e" [ t ]) + (mk_step_ @@ fun () -> A.P.lemma_bool_c "imp-e" [ t ]) | B_ite (a, b, c) -> let lit_a = PA.mk_lit a in PA.add_clause [ Lit.neg lit_a; PA.mk_lit (eq self.tst t b) ] - (mk_step_ @@ A.P.lemma_ite_true ~ite:t); + (mk_step_ @@ fun () -> A.P.lemma_ite_true ~ite:t); PA.add_clause [ lit_a; PA.mk_lit (eq self.tst t c) ] - (mk_step_ @@ A.P.lemma_ite_false ~ite:t) + (mk_step_ @@ fun () -> A.P.lemma_ite_false ~ite:t) | B_eq _ | B_neq _ -> () | B_equiv (a, b) -> equiv_ si ~t ~is_xor:false a b | B_xor (a, b) -> equiv_ si ~t ~is_xor:true a b diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index 31c8ae3c..c309ceee 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -9,7 +9,7 @@ let name = "th-cstor" module type ARG = sig val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view - val lemma_cstor : Lit.t list -> Proof_term.data + val lemma_cstor : Lit.t list -> Proof_term.t end module Make (A : ARG) : sig diff --git a/src/th-cstor/Sidekick_th_cstor.mli b/src/th-cstor/Sidekick_th_cstor.mli index 024e06da..b292ba6b 100644 --- a/src/th-cstor/Sidekick_th_cstor.mli +++ b/src/th-cstor/Sidekick_th_cstor.mli @@ -7,7 +7,7 @@ type ('c, 't) cstor_view = T_cstor of 'c * 't array | T_other of 't module type ARG = sig val view_as_cstor : Term.t -> (Const.t, Term.t) cstor_view - val lemma_cstor : Lit.t list -> Proof_term.data + val lemma_cstor : Lit.t list -> Proof_term.t end val make : (module ARG) -> SMT.theory diff --git a/src/th-data/th_intf.ml b/src/th-data/th_intf.ml index 500f7b85..e26304da 100644 --- a/src/th-data/th_intf.ml +++ b/src/th-data/th_intf.ml @@ -22,35 +22,35 @@ type ('c, 'ty) data_ty_view = | Ty_other module type PROOF_RULES = sig - val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.data + val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t (** [lemma_isa_cstor (d …) (is-c t)] returns the clause [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) - val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.data + val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t (** [lemma_select_cstor (c t1…tn) (sel-c-i t)] returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) - val lemma_isa_split : Term.t -> Lit.t list -> Proof_term.data + val lemma_isa_split : Term.t -> Lit.t list -> Proof_term.t (** [lemma_isa_split t lits] is the proof of [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) - val lemma_isa_sel : Term.t -> Proof_term.data + val lemma_isa_sel : Term.t -> Proof_term.t (** [lemma_isa_sel (is-c t)] is the proof of [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) - val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.data + val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.t (** [lemma_isa_disj (is-c t) (is-d t)] is the proof of [¬ (is-c t) \/ ¬ (is-c t)] *) - val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.data + val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.t (** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of [c t1…tn = c u1…un |- ti = ui] *) - val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.data + val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.t (** [lemma_isa_distinct (c …) (d …)] is the proof of the unit clause [|- (c …) ≠ (d …)] *) - val lemma_acyclicity : (Term.t * Term.t) list -> Proof_term.data + val lemma_acyclicity : (Term.t * Term.t) list -> Proof_term.t (** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] by acyclicity. *) end diff --git a/src/th-lra/intf.ml b/src/th-lra/intf.ml index 8e2cd63f..d1cdc516 100644 --- a/src/th-lra/intf.ml +++ b/src/th-lra/intf.ml @@ -44,7 +44,7 @@ module type ARG = sig val has_ty_real : Term.t -> bool (** Does this term have the type [Real] *) - val lemma_lra : Lit.t list -> Proof_term.data + val lemma_lra : Lit.t list -> Proof_term.t module Gensym : sig type t From 24e79df776257ebaf34eb4d63d9bf3afee9ca34a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 5 Aug 2022 21:55:53 -0400 Subject: [PATCH 063/174] wip: refactor base --- src/base/Base_types.ml | 161 ++++++------ src/base/Config.ml | 6 +- src/base/Config.mli | 2 +- src/base/Form.ml | 4 + src/base/Hashcons.ml | 34 --- src/base/{CCHet.ml => Het.ml} | 52 ---- src/base/{CCHet.mli => Het.mli} | 25 -- src/base/ID.ml | 3 +- src/base/Lit.ml | 1 - src/base/Lit.mli | 1 - src/base/Model.ml | 246 ------------------ src/base/Model.mli | 56 ---- src/base/Proof_dummy.ml | 76 ------ src/base/Proof_dummy.mli | 36 --- src/base/{Proof_quip.ml => Proof_quip.ml.tmp} | 0 .../{Proof_quip.mli => Proof_quip.mli.tmp} | 0 src/base/{Proof.ml => Proof_storage.ml.tmp} | 0 src/base/{Proof.mli => Proof_storage.mli.tmp} | 0 src/base/Sidekick_base.ml | 7 +- src/base/Ty.ml | 59 +++++ src/base/Ty.mli | 24 ++ src/base/arith_types_.ml | 146 +++++++++++ src/base/dune | 9 +- src/base/solver/dune | 4 +- src/base/types_.ml | 94 +++++++ 25 files changed, 417 insertions(+), 629 deletions(-) delete mode 100644 src/base/Hashcons.ml rename src/base/{CCHet.ml => Het.ml} (71%) rename src/base/{CCHet.mli => Het.mli} (58%) delete mode 100644 src/base/Lit.ml delete mode 100644 src/base/Lit.mli delete mode 100644 src/base/Model.ml delete mode 100644 src/base/Model.mli delete mode 100644 src/base/Proof_dummy.ml delete mode 100644 src/base/Proof_dummy.mli rename src/base/{Proof_quip.ml => Proof_quip.ml.tmp} (100%) rename src/base/{Proof_quip.mli => Proof_quip.mli.tmp} (100%) rename src/base/{Proof.ml => Proof_storage.ml.tmp} (100%) rename src/base/{Proof.mli => Proof_storage.mli.tmp} (100%) create mode 100644 src/base/Ty.ml create mode 100644 src/base/Ty.mli create mode 100644 src/base/arith_types_.ml create mode 100644 src/base/types_.ml diff --git a/src/base/Base_types.ml b/src/base/Base_types.ml index efd3852b..476a2450 100644 --- a/src/base/Base_types.ml +++ b/src/base/Base_types.ml @@ -1,17 +1,19 @@ (** Basic type definitions for Sidekick_base *) -module Vec = Sidekick_util.Vec -module Log = Sidekick_util.Log -module Fmt = CCFormat -module CC_view = Sidekick_sigs_cc.View -module Proof_ser = Sidekick_base_proof_trace.Proof_ser -module Storage = Sidekick_base_proof_trace.Storage +(* + +open Sidekick_core +module CC_view = Sidekick_cc.View +(* FIXME + module Proof_ser = Sidekick_base_proof_trace.Proof_ser + module Storage = Sidekick_base_proof_trace.Storage +*) let hash_z = Z.hash let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) module LRA_pred = struct - type t = Sidekick_arith_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq + type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq let to_string = function | Lt -> "<" @@ -25,7 +27,7 @@ module LRA_pred = struct end module LRA_op = struct - type t = Sidekick_arith_lra.op = Plus | Minus + type t = Sidekick_th_lra.op = Plus | Minus let to_string = function | Plus -> "+" @@ -154,34 +156,12 @@ module LIA_view = struct | Var v -> LRA_view.Var (f v) end -type term = { - mutable term_id: int; (* unique ID *) - mutable term_ty: ty; - term_view: term term_view; -} -(** Term. +type term = Term.t +type ty = Term.t +type value = Term.t - A term, with its own view, type, and a unique identifier. - Do not create directly, see {!Term}. *) - -(** Shallow structure of a term. - - A term is a DAG (direct acyclic graph) of nodes, each of which has a - term view. *) -and 'a term_view = - | Bool of bool - | App_fun of fun_ * 'a array (* full, first-order application *) - | Eq of 'a * 'a - | Not of 'a - | Ite of 'a * 'a * 'a - | LRA of 'a LRA_view.t - | LIA of 'a LIA_view.t - -and fun_ = { fun_id: ID.t; fun_view: fun_view } -(** type of function symbols *) - -and fun_view = - | Fun_undef of fun_ty (* simple undefined constant *) +type fun_view = + | Fun_undef of ty (* simple undefined constant *) | Fun_select of select | Fun_cstor of cstor | Fun_is_a of cstor @@ -202,19 +182,9 @@ and fun_view = congruence but not for evaluation. *) -and fun_ty = { fun_ty_args: ty list; fun_ty_ret: ty } -(** Function type *) - -and ty = { mutable ty_id: int; ty_view: ty_view } -(** Hashconsed type *) - and ty_view = - | Ty_bool - | Ty_real | Ty_int - | Ty_atomic of { def: ty_def; args: ty list; mutable finite: bool } - -and ty_def = + | Ty_real | Ty_uninterpreted of ID.t | Ty_data of { data: data } | Ty_def of { @@ -245,21 +215,22 @@ and select = { select_i: int; } -(** Semantic values, used for models (and possibly model-constructing calculi) *) -and value = - | V_bool of bool - | V_element of { id: ID.t; ty: ty } - (** a named constant, distinct from any other constant *) - | V_cstor of { c: cstor; args: value list } - | V_custom of { - view: value_custom_view; - pp: value_custom_view Fmt.printer; - eq: value_custom_view -> value_custom_view -> bool; - hash: value_custom_view -> int; - } (** Custom value *) - | V_real of Q.t +(* FIXME: just use terms; introduce a Const.view for V_element + (** Semantic values, used for models (and possibly model-constructing calculi) *) + type value_view = + | V_element of { id: ID.t; ty: ty } + (** a named constant, distinct from any other constant *) + | V_cstor of { c: cstor; args: value list } + | V_custom of { + view: value_custom_view; + pp: value_custom_view Fmt.printer; + eq: value_custom_view -> value_custom_view -> bool; + hash: value_custom_view -> int; + } (** Custom value *) + | V_real of Q.t -and value_custom_view = .. + and value_custom_view = .. +*) type definition = ID.t * ty * term @@ -278,15 +249,50 @@ type statement = | Stmt_get_value of term list | Stmt_exit -let[@inline] term_equal_ (a : term) b = a == b -let[@inline] term_hash_ a = a.term_id -let[@inline] term_cmp_ a b = CCInt.compare a.term_id b.term_id -let fun_compare a b = ID.compare a.fun_id b.fun_id -let pp_fun out a = ID.pp out a.fun_id -let id_of_fun a = a.fun_id -let[@inline] eq_ty a b = a.ty_id = b.ty_id -let eq_cstor c1 c2 = ID.equal c1.cstor_id c2.cstor_id +type Const.view += Ty of ty_view +let ops_ty : Const.ops = + (module struct + let pp out = function + | Ty ty -> + (match ty with + | Ty_real -> Fmt.string out "Real" + | Ty_int -> Fmt.string out "Int" + | Ty_atomic { def = Ty_uninterpreted id; args = []; _ } -> ID.pp out id + | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> + Fmt.fprintf out "(@[%a@ %a@])" ID.pp id (Util.pp_list pp_ty) args + | Ty_atomic { def = Ty_def def; args; _ } -> def.pp pp_ty out args + | Ty_atomic { def = Ty_data d; args = []; _ } -> + ID.pp out d.data.data_id + | Ty_atomic { def = Ty_data d; args; _ } -> + Fmt.fprintf out "(@[%a@ %a@])" ID.pp d.data.data_id + (Util.pp_list pp_ty) args) + | _ -> () + + let equal a b = + match a, b with + | Ty a, Ty b -> + (match a, b with + | Ty_bool, Ty_bool | Ty_int, Ty_int | Ty_real, Ty_real -> true + | Ty_atomic a1, Ty_atomic a2 -> + equal_def a1.def a2.def && CCList.equal equal a1.args a2.args + | (Ty_bool | Ty_atomic _ | Ty_real | Ty_int), _ -> false) + | _ -> false + + let hash t = + match t.ty_view with + | Ty_bool -> Hash.int 1 + | Ty_real -> Hash.int 2 + | Ty_int -> Hash.int 3 + | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> + Hash.combine3 10 (ID.hash id) (Hash.list hash args) + | Ty_atomic { def = Ty_def d; args; _ } -> + Hash.combine3 20 (ID.hash d.id) (Hash.list hash args) + | Ty_atomic { def = Ty_data d; args; _ } -> + Hash.combine3 30 (ID.hash d.data.data_id) (Hash.list hash args) + end) + +(* let rec eq_value a b = match a, b with | V_bool a, V_bool b -> a = b @@ -314,22 +320,7 @@ let rec pp_value out = function | V_cstor { c; args } -> Fmt.fprintf out "(@[%a@ %a@])" ID.pp c.cstor_id (Util.pp_list pp_value) args | V_real x -> Q.pp_print out x - -let pp_db out (i, _) = Format.fprintf out "%%%d" i - -let rec pp_ty out t = - match t.ty_view with - | Ty_bool -> Fmt.string out "Bool" - | Ty_real -> Fmt.string out "Real" - | Ty_int -> Fmt.string out "Int" - | Ty_atomic { def = Ty_uninterpreted id; args = []; _ } -> ID.pp out id - | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> - Fmt.fprintf out "(@[%a@ %a@])" ID.pp id (Util.pp_list pp_ty) args - | Ty_atomic { def = Ty_def def; args; _ } -> def.pp pp_ty out args - | Ty_atomic { def = Ty_data d; args = []; _ } -> ID.pp out d.data.data_id - | Ty_atomic { def = Ty_data d; args; _ } -> - Fmt.fprintf out "(@[%a@ %a@])" ID.pp d.data.data_id (Util.pp_list pp_ty) - args + *) let pp_term_view_gen ~pp_id ~pp_t out = function | Bool true -> Fmt.string out "true" @@ -1396,3 +1387,5 @@ module Statement = struct | Stmt_define _ -> assert false (* TODO *) end + +*) diff --git a/src/base/Config.ml b/src/base/Config.ml index 63afe4eb..f82120c5 100644 --- a/src/base/Config.ml +++ b/src/base/Config.ml @@ -2,8 +2,8 @@ type 'a sequence = ('a -> unit) -> unit -module Key = CCHet.Key +module Key = Het.Key -type pair = CCHet.pair = Pair : 'a Key.t * 'a -> pair +type pair = Het.pair = Pair : 'a Key.t * 'a -> pair -include CCHet.Map +include Het.Map diff --git a/src/base/Config.mli b/src/base/Config.mli index 5adda152..2c7f51c3 100644 --- a/src/base/Config.mli +++ b/src/base/Config.mli @@ -1,4 +1,4 @@ -(** {1 Configuration} *) +(** Configuration *) type 'a sequence = ('a -> unit) -> unit diff --git a/src/base/Form.ml b/src/base/Form.ml index 45cb908a..bb6794ab 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -1,3 +1,5 @@ +(* + (** Formulas (boolean terms). This module defines function symbols, constants, and views @@ -202,3 +204,5 @@ module Gensym = struct let id = ID.make name in T.const self.tst @@ Fun.mk_undef_const id ty end + +*) diff --git a/src/base/Hashcons.ml b/src/base/Hashcons.ml deleted file mode 100644 index 28ca6e21..00000000 --- a/src/base/Hashcons.ml +++ /dev/null @@ -1,34 +0,0 @@ -module type ARG = sig - type t - - val equal : t -> t -> bool - val hash : t -> int - val set_id : t -> int -> unit -end - -module Make (A : ARG) : sig - type t - - val create : ?size:int -> unit -> t - val hashcons : t -> A.t -> A.t - val size : t -> int - val to_iter : t -> A.t Iter.t -end = struct - module W = Weak.Make (A) - - type t = { tbl: W.t; mutable n: int } - - let create ?(size = 1024) () : t = { tbl = W.create size; n = 0 } - - (* hashcons terms *) - let hashcons st t = - let t' = W.merge st.tbl t in - if t == t' then ( - st.n <- 1 + st.n; - A.set_id t' st.n - ); - t' - - let size st = W.count st.tbl - let to_iter st yield = W.iter yield st.tbl -end diff --git a/src/base/CCHet.ml b/src/base/Het.ml similarity index 71% rename from src/base/CCHet.ml rename to src/base/Het.ml index 52c748e8..5404ca76 100644 --- a/src/base/CCHet.ml +++ b/src/base/Het.ml @@ -74,58 +74,6 @@ let pair_of_e_pair (E_pair (k, e)) = | K.Store v -> Pair (k, v) | _ -> assert false -module Tbl = struct - module M = Hashtbl.Make (struct - type t = int - - let equal (i : int) j = i = j - let hash (i : int) = Hashtbl.hash i - end) - - type t = exn_pair M.t - - let create ?(size = 16) () = M.create size - let mem t k = M.mem t (Key.id k) - - let find_exn (type a) t (k : a Key.t) : a = - let module K = (val k) in - let (E_pair (_, v)) = M.find t K.id in - match v with - | K.Store v -> v - | _ -> assert false - - let find t k = try Some (find_exn t k) with Not_found -> None - - let add_pair_ t p = - let (Pair (k, v)) = p in - let module K = (val k) in - let p = E_pair (k, K.Store v) in - M.replace t K.id p - - let add t k v = add_pair_ t (Pair (k, v)) - - let remove (type a) t (k : a Key.t) = - let module K = (val k) in - M.remove t K.id - - let length t = M.length t - let iter f t = M.iter (fun _ pair -> f (pair_of_e_pair pair)) t - let to_iter t yield = iter yield t - let to_list t = M.fold (fun _ p l -> pair_of_e_pair p :: l) t [] - let add_list t l = List.iter (add_pair_ t) l - let add_iter t seq = seq (add_pair_ t) - - let of_list l = - let t = create () in - add_list t l; - t - - let of_iter seq = - let t = create () in - add_iter t seq; - t -end - module Map = struct module M = Map.Make (struct type t = int diff --git a/src/base/CCHet.mli b/src/base/Het.mli similarity index 58% rename from src/base/CCHet.mli rename to src/base/Het.mli index e98271ad..196e251d 100644 --- a/src/base/CCHet.mli +++ b/src/base/Het.mli @@ -1,5 +1,3 @@ -(* This file is free software, part of containers. See file "license" for more details. *) - (** {1 Associative containers with Heterogeneous Values} This is similar to {!CCMixtbl}, but the injection is directly used as @@ -21,29 +19,6 @@ end type pair = Pair : 'a Key.t * 'a -> pair -(** {2 Imperative table indexed by [Key]} *) -module Tbl : sig - type t - - val create : ?size:int -> unit -> t - val mem : t -> _ Key.t -> bool - val add : t -> 'a Key.t -> 'a -> unit - val remove : t -> _ Key.t -> unit - val length : t -> int - val find : t -> 'a Key.t -> 'a option - - val find_exn : t -> 'a Key.t -> 'a - (** @raise Not_found if the key is not in the table. *) - - val iter : (pair -> unit) -> t -> unit - val to_iter : t -> pair iter - val of_iter : pair iter -> t - val add_iter : t -> pair iter -> unit - val add_list : t -> pair list -> unit - val of_list : pair list -> t - val to_list : t -> pair list -end - (** {2 Immutable map} *) module Map : sig type t diff --git a/src/base/ID.ml b/src/base/ID.ml index 90c761d5..a1e5f808 100644 --- a/src/base/ID.ml +++ b/src/base/ID.ml @@ -21,8 +21,7 @@ let pp_name out a = CCFormat.string out a.name let to_string_full a = Printf.sprintf "%s/%d" a.name a.id module AsKey = struct - type t_ = t - type t = t_ + type nonrec t = t let equal = equal let compare = compare diff --git a/src/base/Lit.ml b/src/base/Lit.ml deleted file mode 100644 index 42b275a1..00000000 --- a/src/base/Lit.ml +++ /dev/null @@ -1 +0,0 @@ -include Sidekick_lit.Make (Solver_arg) diff --git a/src/base/Lit.mli b/src/base/Lit.mli deleted file mode 100644 index aa24343c..00000000 --- a/src/base/Lit.mli +++ /dev/null @@ -1 +0,0 @@ -include Sidekick_core.LIT with module T = Solver_arg diff --git a/src/base/Model.ml b/src/base/Model.ml deleted file mode 100644 index 21c53d05..00000000 --- a/src/base/Model.ml +++ /dev/null @@ -1,246 +0,0 @@ -(* This file is free software. See file "license" for more details. *) - -open! Base_types - -module Val_map = struct - module M = CCMap.Make (CCInt) - - module Key = struct - type t = Value.t list - - let equal = CCList.equal Value.equal - let hash = Hash.list Value.hash - end - - type key = Key.t - type 'a t = (key * 'a) list M.t - - let empty = M.empty - let is_empty m = M.cardinal m = 0 - let cardinal = M.cardinal - - let find k m = - try Some (CCList.assoc ~eq:Key.equal k @@ M.find (Key.hash k) m) - with Not_found -> None - - let add k v m = - let h = Key.hash k in - let l = M.get_or ~default:[] h m in - let l = CCList.Assoc.set ~eq:Key.equal k v l in - M.add h l m - - let to_iter m yield = M.iter (fun _ l -> List.iter yield l) m -end - -module Fun_interpretation = struct - type t = { cases: Value.t Val_map.t; default: Value.t } - - let default fi = fi.default - let cases_list fi = Val_map.to_iter fi.cases |> Iter.to_rev_list - - let make ~default l : t = - let m = - List.fold_left (fun m (k, v) -> Val_map.add k v m) Val_map.empty l - in - { cases = m; default } -end - -type t = { values: Value.t Term.Map.t; funs: Fun_interpretation.t Fun.Map.t } - -let empty : t = { values = Term.Map.empty; funs = Fun.Map.empty } - -(* FIXME: ues this to allocate a default value for each sort - (* get or make a default value for this type *) - let rec get_ty_default (ty:Ty.t) : Value.t = - match Ty.view ty with - | Ty_prop -> Value.true_ - | Ty_atomic { def = Ty_uninterpreted _;_} -> - (* domain element *) - Ty_tbl.get_or_add ty_tbl ~k:ty - ~f:(fun ty -> Value.mk_elt (ID.makef "ty_%d" @@ Ty.id ty) ty) - | Ty_atomic { def = Ty_def d; args; _} -> - (* ask the theory for a default value *) - Ty_tbl.get_or_add ty_tbl ~k:ty - ~f:(fun _ty -> - let vals = List.map get_ty_default args in - d.default_val vals) - in -*) - -let[@inline] mem t m = Term.Map.mem t m.values -let[@inline] find t m = Term.Map.get t m.values - -let add t v m : t = - match Term.Map.find t m.values with - | v' -> - if not @@ Value.equal v v' then - Error.errorf - "@[Model: incompatible values for term %a@ :previous %a@ :new %a@]" - Term.pp t Value.pp v Value.pp v'; - m - | exception Not_found -> { m with values = Term.Map.add t v m.values } - -let add_fun c v m : t = - match Fun.Map.find c m.funs with - | _ -> - Error.errorf "@[Model: function %a already has an interpretation@]" Fun.pp c - | exception Not_found -> { m with funs = Fun.Map.add c v m.funs } - -(* merge two models *) -let merge m1 m2 : t = - let values = - Term.Map.merge_safe m1.values m2.values ~f:(fun t o -> - match o with - | `Left v | `Right v -> Some v - | `Both (v1, v2) -> - if Value.equal v1 v2 then - Some v1 - else - Error.errorf - "@[Model: incompatible values for term %a@ :previous %a@ :new \ - %a@]" - Term.pp t Value.pp v1 Value.pp v2) - and funs = - Fun.Map.merge_safe m1.funs m2.funs ~f:(fun c o -> - match o with - | `Left v | `Right v -> Some v - | `Both _ -> - Error.errorf "cannot merge the two interpretations of function %a" - Fun.pp c) - in - { values; funs } - -let add_funs fs m : t = merge { values = Term.Map.empty; funs = fs } m - -let pp out { values; funs } = - let module FI = Fun_interpretation in - let pp_tv out (t, v) = - Fmt.fprintf out "(@[%a@ := %a@])" Term.pp t Value.pp v - in - let pp_fun_entry out (vals, ret) = - Format.fprintf out "(@[%a@ := %a@])" (Fmt.Dump.list Value.pp) vals Value.pp - ret - in - let pp_fun out ((c, fi) : Fun.t * FI.t) = - Format.fprintf out "(@[%a :default %a@ %a@])" Fun.pp c Value.pp - fi.FI.default - (Fmt.list ~sep:(Fmt.return "@ ") pp_fun_entry) - (FI.cases_list fi) - in - Fmt.fprintf out "(@[model@ @[:terms (@[%a@])@]@ @[:funs (@[%a@])@]@])" - (Fmt.iter ~sep:Fmt.(return "@ ") pp_tv) - (Term.Map.to_iter values) - (Fmt.iter ~sep:Fmt.(return "@ ") pp_fun) - (Fun.Map.to_iter funs) - -exception No_value - -let eval (m : t) (t : Term.t) : Value.t option = - let module FI = Fun_interpretation in - let rec aux t = - match Term.view t with - | Bool b -> Value.bool b - | Not a -> - (match aux a with - | V_bool b -> V_bool (not b) - | v -> - Error.errorf "@[Model: wrong value@ for boolean %a@ :val %a@]" Term.pp a - Value.pp v) - | Ite (a, b, c) -> - (match aux a with - | V_bool true -> aux b - | V_bool false -> aux c - | v -> - Error.errorf "@[Model: wrong value@ for boolean %a@ :val %a@]" Term.pp a - Value.pp v) - | Eq (a, b) -> - let a = aux a in - let b = aux b in - if Value.equal a b then - Value.true_ - else - Value.false_ - | LRA _l -> - assert false - (* TODO: evaluation - begin match l with - | LRA_pred (p, a, b) -> - | LRA_op (_, _, _)|LRA_const _|LRA_other _ -> assert false - end - *) - | LIA _l -> assert false (* TODO *) - | App_fun (c, args) -> - (match Fun.view c, (args : _ array :> _ array) with - | Fun_def udef, _ -> - (* use builtin interpretation function *) - let args = CCArray.map aux args in - udef.eval args - | Fun_cstor c, _ -> Value.cstor_app c (Util.array_to_list_map aux args) - | Fun_select s, [| u |] -> - (match aux u with - | V_cstor { c; args } when Cstor.equal c s.select_cstor -> - List.nth args s.select_i - | v_u -> - Error.errorf "cannot eval selector %a@ on %a" Term.pp t Value.pp v_u) - | Fun_is_a c1, [| u |] -> - (match aux u with - | V_cstor { c = c2; args = _ } -> Value.bool (Cstor.equal c1 c2) - | v_u -> - Error.errorf "cannot eval is-a %a@ on %a" Term.pp t Value.pp v_u) - | Fun_select _, _ -> Error.errorf "bad selector term %a" Term.pp t - | Fun_is_a _, _ -> Error.errorf "bad is-a term %a" Term.pp t - | Fun_undef _, _ -> - (try Term.Map.find t m.values - with Not_found -> - (match Fun.Map.find c m.funs with - | fi -> - let args = CCArray.map aux args |> CCArray.to_list in - (match Val_map.find args fi.FI.cases with - | None -> fi.FI.default - | Some v -> v) - | exception Not_found -> - raise No_value (* no particular interpretation *)))) - in - try Some (aux t) with No_value -> None - -(* TODO: get model from each theory, then complete it as follows based on types - let mk_model (cc:t) (m:A.Model.t) : A.Model.t = - let module Model = A.Model in - let module Value = A.Value in - Log.debugf 15 (fun k->k "(@[cc.mk-model@ %a@])" pp_full cc); - let t_tbl = N_tbl.create 32 in - (* populate [repr -> value] table *) - T_tbl.values cc.tbl - (fun r -> - if N.is_root r then ( - (* find a value in the class, if any *) - let v = - N.iter_class r - |> Iter.find_map (fun n -> Model.eval m n.n_term) - in - let v = match v with - | Some v -> v - | None -> - if same_class r (true_ cc) then Value.true_ - else if same_class r (false_ cc) then Value.false_ - else Value.fresh r.n_term - in - N_tbl.add t_tbl r v - )); - (* now map every term to its representative's value *) - let pairs = - T_tbl.values cc.tbl - |> Iter.map - (fun n -> - let r = find_ n in - let v = - try N_tbl.find t_tbl r - with Not_found -> - Error.errorf "didn't allocate a value for repr %a" N.pp r - in - n.n_term, v) - in - let m = Iter.fold (fun m (t,v) -> Model.add t v m) m pairs in - Log.debugf 5 (fun k->k "(@[cc.model@ %a@])" Model.pp m); - m -*) diff --git a/src/base/Model.mli b/src/base/Model.mli deleted file mode 100644 index c87c8b64..00000000 --- a/src/base/Model.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* This file is free software. See file "license" for more details. *) - -(** Models - - A model is a solution to the satisfiability question, created by the - SMT solver when it proves the formula to be {b satisfiable}. - - A model gives a value to each term of the original formula(s), in - such a way that the formula(s) is true when the term is replaced by its - value. -*) - -open Base_types - -module Val_map : sig - type key = Value.t list - type 'a t - - val empty : 'a t - val is_empty : _ t -> bool - val cardinal : _ t -> int - val find : key -> 'a t -> 'a option - val add : key -> 'a -> 'a t -> 'a t -end - -(** Model for function symbols. - - Function models are a finite map from argument tuples to values, - accompanied with a default value that every other argument tuples - map to. In other words, it's of the form: - - [lambda x y. if (x=vx1,y=vy1) then v1 else if … then … else vdefault] -*) -module Fun_interpretation : sig - type t = { cases: Value.t Val_map.t; default: Value.t } - - val default : t -> Value.t - val cases_list : t -> (Value.t list * Value.t) list - val make : default:Value.t -> (Value.t list * Value.t) list -> t -end - -type t = { values: Value.t Term.Map.t; funs: Fun_interpretation.t Fun.Map.t } -(** Model *) - -val empty : t -(** Empty model *) - -val add : Term.t -> Value.t -> t -> t -val mem : Term.t -> t -> bool -val find : Term.t -> t -> Value.t option -val merge : t -> t -> t -val pp : t CCFormat.printer - -val eval : t -> Term.t -> Value.t option -(** [eval m t] tries to evaluate term [t] in the model. - If it succeeds, the value is returned, otherwise [None] is. *) diff --git a/src/base/Proof_dummy.ml b/src/base/Proof_dummy.ml deleted file mode 100644 index af268417..00000000 --- a/src/base/Proof_dummy.ml +++ /dev/null @@ -1,76 +0,0 @@ -open Base_types - -type lit = Lit.t -type term = Term.t - -module Arg = struct - type nonrec rule = unit - type nonrec step_id = unit - - module Step_vec = Vec_unit - - let dummy_step_id = () -end - -include Sidekick_proof_trace_dummy.Make (Arg) - -type rule = A.rule -type step_id = A.step_id - -let create () : t = () -let with_proof _ _ = () - -module Rule_sat = struct - type nonrec rule = rule - type nonrec step_id = step_id - type nonrec lit = lit - - let sat_redundant_clause _ ~hyps:_ = () - let sat_input_clause _ = () - let sat_unsat_core _ = () -end - -module Rule_core = struct - type nonrec rule = rule - type nonrec step_id = step_id - type nonrec lit = lit - type nonrec term = term - - let define_term _ _ = () - let proof_p1 _ _ = () - let proof_r1 _ _ = () - let proof_res ~pivot:_ _ _ = () - let lemma_preprocess _ _ ~using:_ = () - let lemma_true _ = () - let lemma_cc _ = () - let lemma_rw_clause _ ~res:_ ~using:_ = () - let with_defs _ _ = () -end - -let lemma_lra _ = () - -module Rule_bool = struct - type nonrec rule = rule - type nonrec lit = lit - - let lemma_bool_tauto _ = () - let lemma_bool_c _ _ = () - let lemma_bool_equiv _ _ = () - let lemma_ite_true ~ite:_ = () - let lemma_ite_false ~ite:_ = () -end - -module Rule_data = struct - type nonrec rule = rule - type nonrec lit = lit - type nonrec term = term - - let lemma_isa_cstor ~cstor_t:_ _ = () - let lemma_select_cstor ~cstor_t:_ _ = () - let lemma_isa_split _ _ = () - let lemma_isa_sel _ = () - let lemma_isa_disj _ _ = () - let lemma_cstor_inj _ _ _ = () - let lemma_cstor_distinct _ _ = () - let lemma_acyclicity _ = () -end diff --git a/src/base/Proof_dummy.mli b/src/base/Proof_dummy.mli deleted file mode 100644 index 3aca187e..00000000 --- a/src/base/Proof_dummy.mli +++ /dev/null @@ -1,36 +0,0 @@ -(** Dummy proof module that does nothing. *) - -open Base_types - -module Arg : - Sidekick_sigs_proof_trace.ARG with type rule = unit and type step_id = unit - -include Sidekick_sigs_proof_trace.S with module A = Arg - -type rule = A.rule -type step_id = A.step_id - -module Rule_sat : - Sidekick_sigs_proof_sat.S with type rule = rule and type lit = Lit.t - -module Rule_core : - Sidekick_core.PROOF_CORE - with type rule = rule - and type lit = Lit.t - and type term = Term.t - -val create : unit -> t -val lemma_lra : Lit.t Iter.t -> rule - -module Rule_data : - Sidekick_th_data.PROOF_RULES - with type rule = rule - and type lit = Lit.t - and type term = Term.t - -module Rule_bool : - Sidekick_th_bool_static.PROOF_RULES - with type rule = rule - and type lit = Lit.t - and type term = Term.t - and type term := Term.t diff --git a/src/base/Proof_quip.ml b/src/base/Proof_quip.ml.tmp similarity index 100% rename from src/base/Proof_quip.ml rename to src/base/Proof_quip.ml.tmp diff --git a/src/base/Proof_quip.mli b/src/base/Proof_quip.mli.tmp similarity index 100% rename from src/base/Proof_quip.mli rename to src/base/Proof_quip.mli.tmp diff --git a/src/base/Proof.ml b/src/base/Proof_storage.ml.tmp similarity index 100% rename from src/base/Proof.ml rename to src/base/Proof_storage.ml.tmp diff --git a/src/base/Proof.mli b/src/base/Proof_storage.mli.tmp similarity index 100% rename from src/base/Proof.mli rename to src/base/Proof_storage.mli.tmp diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index bbd89507..c89d4f06 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -16,15 +16,12 @@ *) +module Term = Sidekick_core.Term module Base_types = Base_types module ID = ID -module Fun = Base_types.Fun module Stat = Stat -module Model = Model -module Term = Base_types.Term module Value = Base_types.Value module Term_cell = Base_types.Term_cell -module Ty = Base_types.Ty module Statement = Base_types.Statement module Data = Base_types.Data module Select = Base_types.Select @@ -37,6 +34,6 @@ module LIA_pred = Base_types.LIA_pred module LIA_op = Base_types.LIA_op module Solver_arg = Solver_arg module Lit = Lit -module Proof_dummy = Proof_dummy module Proof = Proof module Proof_quip = Proof_quip +module Types_ = Types_ diff --git a/src/base/Ty.ml b/src/base/Ty.ml new file mode 100644 index 00000000..fcdbe96f --- /dev/null +++ b/src/base/Ty.ml @@ -0,0 +1,59 @@ +(** Core types *) + +open Sidekick_core +include Sidekick_core.Term +open Types_ + +type Const.view += Ty of ty_view +type data = Types_.data + +let ops_ty : Const.ops = + (module struct + let pp out = function + | Ty ty -> + (match ty with + | Ty_real -> Fmt.string out "Real" + | Ty_int -> Fmt.string out "Int" + | Ty_uninterpreted { id; _ } -> ID.pp out id + | Ty_data d -> ID.pp out d.data.data_id) + | _ -> () + + let equal a b = + match a, b with + | Ty a, Ty b -> + (match a, b with + | Ty_int, Ty_int | Ty_real, Ty_real -> true + | Ty_uninterpreted u1, Ty_uninterpreted u2 -> ID.equal u1.id u2.id + | Ty_data d1, Ty_data d2 -> ID.equal d1.data.data_id d2.data.data_id + | (Ty_real | Ty_int | Ty_uninterpreted _ | Ty_data _), _ -> false) + | _ -> false + + let hash = function + | Ty a -> + (match a with + | Ty_real -> Hash.int 2 + | Ty_int -> Hash.int 3 + | Ty_uninterpreted u -> Hash.combine2 10 (ID.hash u.id) + | Ty_data d -> Hash.combine2 30 (ID.hash d.data.data_id)) + | _ -> assert false + end) + +open struct + let mk_ty0 tst view = + let ty = Term.type_ tst in + Term.const tst @@ Const.make (Ty view) ops_ty ~ty +end +(* TODO: handle polymorphic constants *) + +let int tst : ty = mk_ty0 tst Ty_int +let real tst : ty = mk_ty0 tst Ty_real + +let uninterpreted tst id : t = + mk_ty0 tst (Ty_uninterpreted { id; finite = false }) + +let data tst data : t = mk_ty0 tst (Ty_data { data }) + +let is_uninterpreted (self : t) = + match view self with + | E_const { Const.c_view = Ty (Ty_uninterpreted _); _ } -> true + | _ -> false diff --git a/src/base/Ty.mli b/src/base/Ty.mli new file mode 100644 index 00000000..dac21a9a --- /dev/null +++ b/src/base/Ty.mli @@ -0,0 +1,24 @@ +open Types_ + +include module type of struct + include Term +end + +type t = ty +type data = Types_.data + +val bool : store -> t +val real : store -> t +val int : store -> t +val uninterpreted : store -> ID.t -> t +val data : store -> data -> t +val is_uninterpreted : t -> bool + +(* TODO: separate functor? + val finite : t -> bool + val set_finite : t -> bool -> unit + val args : t -> ty list + val ret : t -> ty + val arity : t -> int + val unfold : t -> ty list * ty +*) diff --git a/src/base/arith_types_.ml b/src/base/arith_types_.ml new file mode 100644 index 00000000..ec5cc14f --- /dev/null +++ b/src/base/arith_types_.ml @@ -0,0 +1,146 @@ +let hash_z = Z.hash +let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) + +module LRA_pred = struct + type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq + + let to_string = function + | Lt -> "<" + | Leq -> "<=" + | Neq -> "!=" + | Eq -> "=" + | Gt -> ">" + | Geq -> ">=" + + let pp out p = Fmt.string out (to_string p) +end + +module LRA_op = struct + type t = Sidekick_th_lra.op = Plus | Minus + + let to_string = function + | Plus -> "+" + | Minus -> "-" + + let pp out p = Fmt.string out (to_string p) +end + +module LRA_view = struct + type 'a t = + | Pred of LRA_pred.t * 'a * 'a + | Op of LRA_op.t * 'a * 'a + | Mult of Q.t * 'a + | Const of Q.t + | Var of 'a + | To_real of 'a + + let map ~f_c f (l : _ t) : _ t = + match l with + | Pred (p, a, b) -> Pred (p, f a, f b) + | Op (p, a, b) -> Op (p, f a, f b) + | Mult (n, a) -> Mult (f_c n, f a) + | Const c -> Const (f_c c) + | Var x -> Var (f x) + | To_real x -> To_real (f x) + + let iter f l : unit = + match l with + | Pred (_, a, b) | Op (_, a, b) -> + f a; + f b + | Mult (_, x) | Var x | To_real x -> f x + | Const _ -> () + + let pp ~pp_t out = function + | Pred (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b + | Op (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b + | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x + | Const q -> Q.pp_print out q + | Var x -> pp_t out x + | To_real x -> Fmt.fprintf out "(@[to_real@ %a@])" pp_t x + + let hash ~sub_hash = function + | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | Mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) + | Const q -> Hash.combine2 84 (hash_q q) + | Var x -> sub_hash x + | To_real x -> Hash.combine2 85 (sub_hash x) + + let equal ~sub_eq l1 l2 = + match l1, l2 with + | Pred (p1, a1, b1), Pred (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | Op (p1, a1, b1), Op (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | Const a1, Const a2 -> Q.equal a1 a2 + | Mult (n1, x1), Mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 + | Var x1, Var x2 | To_real x1, To_real x2 -> sub_eq x1 x2 + | (Pred _ | Op _ | Const _ | Mult _ | Var _ | To_real _), _ -> false +end + +module LIA_pred = LRA_pred +module LIA_op = LRA_op + +module LIA_view = struct + type 'a t = + | Pred of LIA_pred.t * 'a * 'a + | Op of LIA_op.t * 'a * 'a + | Mult of Z.t * 'a + | Const of Z.t + | Var of 'a + + let map ~f_c f (l : _ t) : _ t = + match l with + | Pred (p, a, b) -> Pred (p, f a, f b) + | Op (p, a, b) -> Op (p, f a, f b) + | Mult (n, a) -> Mult (f_c n, f a) + | Const c -> Const (f_c c) + | Var x -> Var (f x) + + let iter f l : unit = + match l with + | Pred (_, a, b) | Op (_, a, b) -> + f a; + f b + | Mult (_, x) | Var x -> f x + | Const _ -> () + + let pp ~pp_t out = function + | Pred (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b + | Op (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b + | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x + | Const n -> Z.pp_print out n + | Var x -> pp_t out x + + let hash ~sub_hash = function + | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | Mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) + | Const n -> Hash.combine2 84 (hash_z n) + | Var x -> sub_hash x + + let equal ~sub_eq l1 l2 = + match l1, l2 with + | Pred (p1, a1, b1), Pred (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | Op (p1, a1, b1), Op (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | Const a1, Const a2 -> Z.equal a1 a2 + | Mult (n1, x1), Mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 + | Var x1, Var x2 -> sub_eq x1 x2 + | (Pred _ | Op _ | Const _ | Mult _ | Var _), _ -> false + + (* convert the whole structure to reals *) + let to_lra f l : _ LRA_view.t = + match l with + | Pred (p, a, b) -> LRA_view.Pred (p, f a, f b) + | Op (op, a, b) -> LRA_view.Op (op, f a, f b) + | Mult (c, x) -> LRA_view.Mult (Q.of_bigint c, f x) + | Const x -> LRA_view.Const (Q.of_bigint x) + | Var v -> LRA_view.Var (f v) +end diff --git a/src/base/dune b/src/base/dune index 2846b4e8..af6aa5f3 100644 --- a/src/base/dune +++ b/src/base/dune @@ -2,8 +2,7 @@ (name sidekick_base) (public_name sidekick-base) (synopsis "Base term definitions for the standalone SMT solver and library") - (libraries containers iter sidekick.core sidekick.util sidekick.lit - sidekick-base.proof-trace sidekick.quip sidekick.arith-lra - sidekick.th-bool-static sidekick.th-data sidekick.zarith zarith - sidekick.proof-trace.dummy) - (flags :standard -w -32 -open Sidekick_util)) + (libraries containers iter sidekick.core sidekick.util sidekick.smt-solver + sidekick.cc sidekick.quip sidekick.th-lra sidekick.th-bool-static + sidekick.th-data sidekick.zarith zarith) + (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/base/solver/dune b/src/base/solver/dune index ab2c62ab..35b17f20 100644 --- a/src/base/solver/dune +++ b/src/base/solver/dune @@ -3,7 +3,7 @@ (public_name sidekick-base.solver) (synopsis "Instantiation of solver and theories for Sidekick_base") (libraries sidekick-base sidekick.core sidekick.smt-solver - sidekick.th-bool-static sidekick.mini-cc sidekick.th-data - sidekick.arith-lra sidekick.zarith) + sidekick.th-bool-static sidekick.mini-cc sidekick.th-data sidekick.th-lra + sidekick.zarith) (flags :standard -warn-error -a+8 -safe-string -color always -open Sidekick_util)) diff --git a/src/base/types_.ml b/src/base/types_.ml new file mode 100644 index 00000000..69e0070e --- /dev/null +++ b/src/base/types_.ml @@ -0,0 +1,94 @@ +include Sidekick_core + +(* FIXME + module Proof_ser = Sidekick_base_proof_trace.Proof_ser + module Storage = Sidekick_base_proof_trace.Storage +*) + +type term = Term.t +type ty = Term.t +type value = Term.t + +type fun_view = + | Fun_undef of ty (* simple undefined constant *) + | Fun_select of select + | Fun_cstor of cstor + | Fun_is_a of cstor + | Fun_def of { + pp: 'a. ('a Fmt.printer -> 'a array Fmt.printer) option; + abs: self:term -> term array -> term * bool; (* remove the sign? *) + do_cc: bool; (* participate in congruence closure? *) + relevant: 'a. ID.t -> 'a array -> int -> bool; (* relevant argument? *) + ty: ID.t -> term array -> ty; (* compute type *) + eval: value array -> value; (* evaluate term *) + } + (** Methods on the custom term view whose arguments are ['a]. + Terms must be printable, and provide some additional theory handles. + + - [relevant] must return a subset of [args] (possibly the same set). + The terms it returns will be activated and evaluated whenever possible. + Terms in [args \ relevant args] are considered for + congruence but not for evaluation. +*) + +and ty_view = + | Ty_int + | Ty_real + | Ty_uninterpreted of { id: ID.t; mutable finite: bool } + | Ty_data of { data: data } + +and data = { + data_id: ID.t; + data_cstors: cstor ID.Map.t lazy_t; + data_as_ty: ty lazy_t; +} + +and cstor = { + cstor_id: ID.t; + cstor_is_a: ID.t; + mutable cstor_arity: int; + cstor_args: select list lazy_t; + cstor_ty_as_data: data; + cstor_ty: ty lazy_t; +} + +and select = { + select_id: ID.t; + select_cstor: cstor; + select_ty: ty lazy_t; + select_i: int; +} + +(* FIXME: just use terms; introduce a Const.view for V_element + (** Semantic values, used for models (and possibly model-constructing calculi) *) + type value_view = + | V_element of { id: ID.t; ty: ty } + (** a named constant, distinct from any other constant *) + | V_cstor of { c: cstor; args: value list } + | V_custom of { + view: value_custom_view; + pp: value_custom_view Fmt.printer; + eq: value_custom_view -> value_custom_view -> bool; + hash: value_custom_view -> int; + } (** Custom value *) + | V_real of Q.t + + and value_custom_view = .. +*) + +type definition = ID.t * ty * term + +type statement = + | Stmt_set_logic of string + | 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_define of definition list + | Stmt_assert of term + | Stmt_assert_clause of term list + | Stmt_check_sat of (bool * term) list + | Stmt_get_model + | Stmt_get_value of term list + | Stmt_exit From a7e7b38d1b0fe6a09aaaa49f2b91448ddcbc9d5f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 5 Aug 2022 21:56:23 -0400 Subject: [PATCH 064/174] core: re-export Const.t properly --- src/core-logic/const.mli | 2 +- src/core-logic/sidekick_core_logic.ml | 3 --- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/core-logic/const.mli b/src/core-logic/const.mli index bf22cd28..8fe1838d 100644 --- a/src/core-logic/const.mli +++ b/src/core-logic/const.mli @@ -4,7 +4,6 @@ open Types_ -type t = const type view = const_view = .. module type DYN_OPS = sig @@ -14,6 +13,7 @@ module type DYN_OPS = sig end type ops = (module DYN_OPS) +type t = const = { c_view: view; c_ops: ops; c_ty: term } val view : t -> view val make : view -> ops -> ty:term -> t diff --git a/src/core-logic/sidekick_core_logic.ml b/src/core-logic/sidekick_core_logic.ml index faef37b1..c06f698a 100644 --- a/src/core-logic/sidekick_core_logic.ml +++ b/src/core-logic/sidekick_core_logic.ml @@ -4,9 +4,6 @@ module Bvar = Bvar module Const = Const module Subst = Subst module T_builtins = T_builtins - -(* *) - module Store = Term.Store (* TODO: move to separate library? *) From c873346047a1b484a59f92f510542f45447a11a2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 5 Aug 2022 21:56:45 -0400 Subject: [PATCH 065/174] detail in th-lra --- src/th-lra/sidekick_th_lra.ml | 4 +--- src/th-lra/sidekick_th_lra.mli | 5 +++-- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index d1666f2d..5d60f300 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -4,11 +4,9 @@ open Sidekick_core open Sidekick_cc module Intf = Intf -open Intf +include Intf module SI = SMT.Solver_internal -module type ARG = Intf.ARG - module Tag = struct type t = Lit of Lit.t | CC_eq of E_node.t * E_node.t diff --git a/src/th-lra/sidekick_th_lra.mli b/src/th-lra/sidekick_th_lra.mli index fdb34b33..11ee0b4c 100644 --- a/src/th-lra/sidekick_th_lra.mli +++ b/src/th-lra/sidekick_th_lra.mli @@ -1,9 +1,10 @@ (** Linear Rational Arithmetic *) module Intf = Intf -open Intf -module type ARG = Intf.ARG +include module type of struct + include Intf +end (* TODO type state From c2af58928202d60afce7fd27536a4df32c88baed Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 7 Aug 2022 22:40:39 -0400 Subject: [PATCH 066/174] add core.bool_view --- src/core/Sidekick_core.ml | 1 + src/core/bool_view.ml | 15 +++++++++++++++ src/th-bool-static/Sidekick_th_bool_static.ml | 4 +--- src/th-bool-static/intf.ml | 3 +-- 4 files changed, 18 insertions(+), 5 deletions(-) create mode 100644 src/core/bool_view.ml diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index 204c1174..ca4699d7 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -23,6 +23,7 @@ module Term = struct include Sidekick_core_logic.T_builtins end +module Bool_view = Bool_view module Bvar = Sidekick_core_logic.Bvar module Lit = Lit module Proof_step = Proof_step diff --git a/src/core/bool_view.ml b/src/core/bool_view.ml new file mode 100644 index 00000000..6842efc7 --- /dev/null +++ b/src/core/bool_view.ml @@ -0,0 +1,15 @@ +(** Boolean-oriented view of terms *) + +(** View *) +type ('a, 'args) t = + | B_bool of bool + | B_not of 'a + | B_and of 'args + | B_or of 'args + | B_imply of 'args * 'a + | B_equiv of 'a * 'a + | B_xor of 'a * 'a + | B_eq of 'a * 'a + | B_neq of 'a * 'a + | B_ite of 'a * 'a * 'a + | B_atom of 'a diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 130735c1..dde8ae39 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -53,7 +53,7 @@ end = struct | B_not u when is_true u -> ret_bequiv t (T.false_ tst) | B_not u when is_false u -> ret_bequiv t (T.true_ tst) | B_not _ -> None - | B_opaque_bool _ -> None + | B_atom _ -> None | B_and a -> if Iter.exists is_false a then ret (T.false_ tst) @@ -102,7 +102,6 @@ end = struct | B_eq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) | B_neq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) | B_eq _ | B_neq _ -> None - | B_atom _ -> None let fresh_term self ~for_t ~pre ty = let u = A.Gensym.fresh_term self.gensym ~pre ty in @@ -164,7 +163,6 @@ end = struct (* make a literal for [t], with a proof of [|- abs(t) = abs(lit)] *) (match A.view_as_bool t with - | B_opaque_bool _ -> () | B_bool _ -> () | B_not _ -> () | B_and l -> diff --git a/src/th-bool-static/intf.ml b/src/th-bool-static/intf.ml index e25335a2..a348d9df 100644 --- a/src/th-bool-static/intf.ml +++ b/src/th-bool-static/intf.ml @@ -6,7 +6,7 @@ type term = Term.t type ty = Term.t (** Boolean-oriented view of terms *) -type ('a, 'args) bool_view = +type ('a, 'args) bool_view = ('a, 'args) Bool_view.t = | B_bool of bool | B_not of 'a | B_and of 'args @@ -17,7 +17,6 @@ type ('a, 'args) bool_view = | B_eq of 'a * 'a | B_neq of 'a * 'a | B_ite of 'a * 'a * 'a - | B_opaque_bool of 'a (* do not enter *) | B_atom of 'a module type PROOF_RULES = sig From 86bc9453d503dfce1e2c5241a74cc0d7c885ac72 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 7 Aug 2022 22:41:05 -0400 Subject: [PATCH 067/174] rename dir --- src/{proof-tracy-bare-dump => proof-trace-bare-dump}/dune | 0 .../proof_trace_dump.ml | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename src/{proof-tracy-bare-dump => proof-trace-bare-dump}/dune (100%) rename src/{proof-tracy-bare-dump => proof-trace-bare-dump}/proof_trace_dump.ml (100%) diff --git a/src/proof-tracy-bare-dump/dune b/src/proof-trace-bare-dump/dune similarity index 100% rename from src/proof-tracy-bare-dump/dune rename to src/proof-trace-bare-dump/dune diff --git a/src/proof-tracy-bare-dump/proof_trace_dump.ml b/src/proof-trace-bare-dump/proof_trace_dump.ml similarity index 100% rename from src/proof-tracy-bare-dump/proof_trace_dump.ml rename to src/proof-trace-bare-dump/proof_trace_dump.ml From 4dcc3ea4ada766aec3988f5859bcaebe0d996111 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 7 Aug 2022 22:41:13 -0400 Subject: [PATCH 068/174] small changes in smt --- src/smt/solver.ml | 4 ++-- src/smt/solver_internal.ml | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index fb71706c..6f92f526 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -103,8 +103,8 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = last_res = None; solver = Sat_solver.create ~proof ?size ~stat (SI.to_sat_plugin si); stat; - count_clause = Stat.mk_int stat "solver.add-clause"; - count_solve = Stat.mk_int stat "solver.solve"; + count_clause = Stat.mk_int stat "smt.solver.add-clause"; + count_solve = Stat.mk_int stat "smt.solver.solve"; } in add_theory_l self theories; diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index e6e73bb9..eff96801 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -607,10 +607,10 @@ let create (module A : ARG) ~stat ~proof (tst : Term.store) () : t = registry = Registry.create (); preprocessed = Term.Tbl.create 32; delayed_actions = Queue.create (); - count_axiom = Stat.mk_int stat "solver.th-axioms"; - count_preprocess_clause = Stat.mk_int stat "solver.preprocess-clause"; - count_propagate = Stat.mk_int stat "solver.th-propagations"; - count_conflict = Stat.mk_int stat "solver.th-conflicts"; + count_axiom = Stat.mk_int stat "smt.solver.th-axioms"; + count_preprocess_clause = Stat.mk_int stat "smt.solver.preprocess-clause"; + count_propagate = Stat.mk_int stat "smt.solver.th-propagations"; + count_conflict = Stat.mk_int stat "smt.solver.th-conflicts"; on_partial_check = []; on_final_check = []; on_th_combination = []; From 5b6fd14dcf1a51509afbea68b0994b697f094806 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 7 Aug 2022 22:41:26 -0400 Subject: [PATCH 069/174] wip: refactor(base): split into several views, all based on Const --- src/base/{arith_types_.ml => Arith_types_.ml} | 6 +- src/base/Data_ty.ml | 113 ++++++++++++ src/base/Data_ty.mli | 51 ++++++ src/base/Form.ml | 164 +++++++++++++++++- src/base/Form.mli | 48 +++++ src/base/Sidekick_base.ml | 53 +++--- src/base/Solver_arg.ml | 4 - src/base/Solver_arg.mli | 15 -- src/base/Statement.ml | 48 +++++ src/base/Statement.mli | 24 +++ src/base/Ty.ml | 13 +- src/base/Ty.mli | 3 +- src/base/Uconst.ml | 51 ++++++ src/base/Uconst.mli | 23 +++ src/base/solver/dune | 9 - src/base/solver/sidekick_base_solver.ml | 142 --------------- src/base/types_.ml | 29 +--- 17 files changed, 563 insertions(+), 233 deletions(-) rename src/base/{arith_types_.ml => Arith_types_.ml} (97%) create mode 100644 src/base/Data_ty.ml create mode 100644 src/base/Data_ty.mli create mode 100644 src/base/Form.mli delete mode 100644 src/base/Solver_arg.ml delete mode 100644 src/base/Solver_arg.mli create mode 100644 src/base/Statement.ml create mode 100644 src/base/Statement.mli create mode 100644 src/base/Uconst.ml create mode 100644 src/base/Uconst.mli delete mode 100644 src/base/solver/dune delete mode 100644 src/base/solver/sidekick_base_solver.ml diff --git a/src/base/arith_types_.ml b/src/base/Arith_types_.ml similarity index 97% rename from src/base/arith_types_.ml rename to src/base/Arith_types_.ml index ec5cc14f..e244d13d 100644 --- a/src/base/arith_types_.ml +++ b/src/base/Arith_types_.ml @@ -1,5 +1,7 @@ -let hash_z = Z.hash -let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) +open struct + let hash_z = Z.hash + let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) +end module LRA_pred = struct type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq diff --git a/src/base/Data_ty.ml b/src/base/Data_ty.ml new file mode 100644 index 00000000..1503fe78 --- /dev/null +++ b/src/base/Data_ty.ml @@ -0,0 +1,113 @@ +open Types_ + +type select = Types_.select = { + select_id: ID.t; + select_cstor: cstor; + select_ty: ty lazy_t; + select_i: int; +} + +type cstor = Types_.cstor = { + cstor_id: ID.t; + cstor_is_a: ID.t; + mutable cstor_arity: int; + cstor_args: select list lazy_t; + cstor_ty_as_data: data; + cstor_ty: ty lazy_t; +} + +type t = data = { + data_id: ID.t; + data_cstors: cstor ID.Map.t lazy_t; + data_as_ty: ty lazy_t; +} + +let pp out d = ID.pp out d.data_id +let equal a b = ID.equal a.data_id b.data_id +let hash a = ID.hash a.data_id + +(** Datatype selectors. + + A selector is a kind of function that allows to obtain an argument + of a given constructor. *) +module Select = struct + type t = Types_.select = { + select_id: ID.t; + select_cstor: cstor; + select_ty: ty lazy_t; + select_i: int; + } + + let ty sel = Lazy.force sel.select_ty + + let equal a b = + ID.equal a.select_id b.select_id + && ID.equal a.select_cstor.cstor_id b.select_cstor.cstor_id + && a.select_i = b.select_i + + let hash a = + Hash.combine4 1952 (ID.hash a.select_id) + (ID.hash a.select_cstor.cstor_id) + (Hash.int a.select_i) + + let pp out self = + Fmt.fprintf out "select.%a[%d]" ID.pp self.select_cstor.cstor_id + self.select_i +end + +(** Datatype constructors. + + A datatype has one or more constructors, each of which is a special + kind of function symbol. Constructors are injective and pairwise distinct. *) +module Cstor = struct + type t = cstor + + let id c = c.cstor_id + let hash c = ID.hash c.cstor_id + let ty_args c = Lazy.force c.cstor_args |> Iter.of_list |> Iter.map Select.ty + let equal a b = ID.equal a.cstor_id b.cstor_id + let pp out c = ID.pp out c.cstor_id +end + +type Const.view += + | Data of data + | Cstor of cstor + | Select of select + | Is_a of cstor + +let ops = + (module struct + let pp out = function + | Data d -> pp out d + | Cstor c -> Cstor.pp out c + | Select s -> Select.pp out s + | Is_a c -> Fmt.fprintf out "(_ is %a)" Cstor.pp c + | _ -> assert false + + let equal a b = + match a, b with + | Data a, Data b -> equal a b + | Cstor a, Cstor b -> Cstor.equal a b + | Select a, Select b -> Select.equal a b + | Is_a a, Is_a b -> Cstor.equal a b + | _ -> false + + let hash = function + | Data d -> Hash.combine2 592 (hash d) + | Cstor c -> Hash.combine2 593 (Cstor.hash c) + | Select s -> Hash.combine2 594 (Select.hash s) + | Is_a c -> Hash.combine2 595 (Cstor.hash c) + | _ -> assert false + end : Const.DYN_OPS) + +let data tst d : Term.t = + Term.const tst @@ Const.make (Data d) ops ~ty:(Term.type_ tst) + +let cstor tst c : Term.t = + Term.const tst @@ Const.make (Cstor c) ops ~ty:(Lazy.force c.cstor_ty) + +let select tst s : Term.t = + Term.const tst @@ Const.make (Select s) ops ~ty:(Lazy.force s.select_ty) + +let is_a tst c : Term.t = + Term.const tst @@ Const.make (Is_a c) ops ~ty:(Term.bool tst) diff --git a/src/base/Data_ty.mli b/src/base/Data_ty.mli new file mode 100644 index 00000000..875d099a --- /dev/null +++ b/src/base/Data_ty.mli @@ -0,0 +1,51 @@ +open Types_ + +type select = Types_.select = { + select_id: ID.t; + select_cstor: cstor; + select_ty: ty lazy_t; + select_i: int; +} + +type cstor = Types_.cstor = { + cstor_id: ID.t; + cstor_is_a: ID.t; + mutable cstor_arity: int; + cstor_args: select list lazy_t; + cstor_ty_as_data: data; + cstor_ty: ty lazy_t; +} + +type t = data = { + data_id: ID.t; + data_cstors: cstor ID.Map.t lazy_t; + data_as_ty: ty lazy_t; +} + +type Const.view += + private + | Data of data + | Cstor of cstor + | Select of select + | Is_a of cstor + +include Sidekick_sigs.EQ_HASH_PRINT with type t := t + +module Select : sig + type t = select + + include Sidekick_sigs.EQ_HASH_PRINT with type t := t +end + +module Cstor : sig + type t = cstor + + include Sidekick_sigs.EQ_HASH_PRINT with type t := t +end + +val data : Term.store -> t -> Term.t +val cstor : Term.store -> cstor -> Term.t +val select : Term.store -> select -> Term.t +val is_a : Term.store -> cstor -> Term.t + +(* TODO: select_ : store -> cstor -> int -> term *) diff --git a/src/base/Form.ml b/src/base/Form.ml index bb6794ab..e931c08f 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -1,14 +1,164 @@ -(* +open Types_ +open Sidekick_core +module T = Term -(** Formulas (boolean terms). +type ty = Term.t +type term = Term.t - This module defines function symbols, constants, and views - to manipulate boolean formulas in {!Sidekick_base}. - This is useful to have the ability to use boolean connectives instead - of being limited to clauses; by using {!Sidekick_th_bool_static}, - the formulas are turned into clauses automatically for you. +type ('a, 'args) view = ('a, 'args) Sidekick_core.Bool_view.t = + | B_bool of bool + | B_not of 'a + | B_and of 'args + | B_or of 'args + | B_imply of 'args * 'a + | B_equiv of 'a * 'a + | B_xor of 'a * 'a + | B_eq of 'a * 'a + | B_neq of 'a * 'a + | B_ite of 'a * 'a * 'a + | B_atom of 'a + +(* ### allocate special IDs for connectors *) + +let id_and = ID.make "and" +let id_or = ID.make "or" +let id_imply = ID.make "=>" + +(* ### view *) + +exception Not_a_th_term + +let view_id_ fid args = + if ID.equal fid id_and then + B_and args + else if ID.equal fid id_or then + B_or args + else if ID.equal fid id_imply then ( + match args with + | [ arg; concl ] -> B_imply ([ arg ], concl) + | _ -> raise_notrace Not_a_th_term + ) else + raise_notrace Not_a_th_term + +let view (t : T.t) : (T.t, _) view = + let hd, args = T.unfold_app t in + match T.view hd, args with + | E_const { Const.c_view = T.C_true; _ }, [] -> B_bool true + | E_const { Const.c_view = T.C_false; _ }, [] -> B_bool false + | E_const { Const.c_view = T.C_not; _ }, [ a ] -> B_not a + | E_const { Const.c_view = T.C_eq; _ }, [ _ty; a; b ] -> B_eq (a, b) + | E_const { Const.c_view = T.C_ite; _ }, [ _ty; a; b; c ] -> B_ite (a, b, c) + | E_const { Const.c_view = Uconst.Uconst { uc_id; _ }; _ }, _ -> + (try view_id_ uc_id args with Not_a_th_term -> B_atom t) + | _ -> B_atom t + +(* TODO + let and_l st l = + match flatten_id id_and true l with + | [] -> T.true_ st + | l when List.exists T.is_false l -> T.false_ st + | [ x ] -> x + | args -> T.app_fun st Funs.and_ (CCArray.of_list args) + + let or_l st l = + match flatten_id id_or false l with + | [] -> T.false_ st + | l when List.exists T.is_true l -> T.true_ st + | [ x ] -> x + | args -> T.app_fun st Funs.or_ (CCArray.of_list args) *) +let c_and tst : Term.t = + let bool = Term.bool tst in + Uconst.uconst_of_id' tst id_and [ bool; bool ] bool + +let c_or tst : Term.t = + let bool = Term.bool tst in + Uconst.uconst_of_id' tst id_or [ bool; bool ] bool + +let c_imply tst : Term.t = + let bool = Term.bool tst in + Uconst.uconst_of_id' tst id_imply [ bool; bool ] bool + +let bool = Term.bool_val +let and_ tst a b = Term.app_l tst (c_and tst) [ a; b ] +let or_ tst a b = Term.app_l tst (c_or tst) [ a; b ] +let imply tst a b = Term.app_l tst (c_imply tst) [ a; b ] +let eq = T.eq +let not_ = T.not +let ite = T.ite +let neq st a b = not_ st @@ eq st a b +let imply_l tst xs y = List.fold_right (imply tst) xs y + +let equiv tst a b = + if (not (T.is_bool (T.ty a))) || not (T.is_bool (T.ty b)) then + failwith "Form.equiv: takes boolean arguments"; + T.eq tst a b + +let xor tst a b = not_ tst (equiv tst a b) + +let and_l tst = function + | [] -> T.true_ tst + | [ x ] -> x + | x :: tl -> List.fold_left (and_ tst) x tl + +let or_l tst = function + | [] -> T.false_ tst + | [ x ] -> x + | x :: tl -> List.fold_left (or_ tst) x tl + +let distinct_l tst l = + match l with + | [] | [ _ ] -> T.true_ tst + | l -> + (* turn into [and_{i List.map (fun (a, b) -> neq tst a b) in + and_l tst cs + +let mk_of_view tst = function + | B_bool b -> T.bool_val tst b + | B_atom t -> t + | B_and l -> and_l tst l + | B_or l -> or_l tst l + | B_imply (a, b) -> imply_l tst a b + | B_ite (a, b, c) -> ite tst a b c + | B_equiv (a, b) -> equiv tst a b + | B_xor (a, b) -> not_ tst (equiv tst a b) + | B_eq (a, b) -> T.eq tst a b + | B_neq (a, b) -> not_ tst (T.eq tst a b) + | B_not t -> not_ tst t + +(* + let eval id args = + let open Value in + match view_id id args with + | B_bool b -> Value.bool b + | B_not (V_bool b) -> Value.bool (not b) + | B_and a when Iter.for_all Value.is_true a -> Value.true_ + | B_and a when Iter.exists Value.is_false a -> Value.false_ + | B_or a when Iter.exists Value.is_true a -> Value.true_ + | B_or a when Iter.for_all Value.is_false a -> Value.false_ + | B_imply (_, V_bool true) -> Value.true_ + | B_imply (a, _) when Iter.exists Value.is_false a -> Value.true_ + | B_imply (a, b) when Iter.for_all Value.is_true a && Value.is_false b -> + Value.false_ + | B_ite (a, b, c) -> + if Value.is_true a then + b + else if Value.is_false a then + c + else + Error.errorf "non boolean value %a in ite" Value.pp a + | B_equiv (a, b) | B_eq (a, b) -> Value.bool (Value.equal a b) + | B_xor (a, b) | B_neq (a, b) -> Value.bool (not (Value.equal a b)) + | B_atom v -> v + | B_opaque_bool t -> Error.errorf "cannot evaluate opaque bool %a" pp t + | B_not _ | B_and _ | B_or _ | B_imply _ -> + Error.errorf "non boolean value in boolean connective" + *) + +(* + module T = Base_types.Term module Ty = Base_types.Ty module Fun = Base_types.Fun diff --git a/src/base/Form.mli b/src/base/Form.mli new file mode 100644 index 00000000..e184db65 --- /dev/null +++ b/src/base/Form.mli @@ -0,0 +1,48 @@ +(** Formulas (boolean terms). + + This module defines function symbols, constants, and views + to manipulate boolean formulas in {!Sidekick_base}. + This is useful to have the ability to use boolean connectives instead + of being limited to clauses; by using {!Sidekick_th_bool_static}, + the formulas are turned into clauses automatically for you. +*) + +open Types_ + +type term = Term.t + +type ('a, 'args) view = ('a, 'args) Sidekick_core.Bool_view.t = + | B_bool of bool + | B_not of 'a + | B_and of 'args + | B_or of 'args + | B_imply of 'args * 'a + | B_equiv of 'a * 'a + | B_xor of 'a * 'a + | B_eq of 'a * 'a + | B_neq of 'a * 'a + | B_ite of 'a * 'a * 'a + | B_atom of 'a + +val view : term -> (term, term list) view +val bool : Term.store -> bool -> term +val not_ : Term.store -> term -> term +val and_ : Term.store -> term -> term -> term +val or_ : Term.store -> term -> term -> term +val eq : Term.store -> term -> term -> term +val neq : Term.store -> term -> term -> term +val imply : Term.store -> term -> term -> term +val equiv : Term.store -> term -> term -> term +val xor : Term.store -> term -> term -> term +val ite : Term.store -> term -> term -> term + +(* *) + +val and_l : Term.store -> term list -> term +val or_l : Term.store -> term list -> term +val imply_l : Term.store -> term list -> term -> term +val mk_of_view : Term.store -> (term, term list) view -> term + +(* TODO? + val make : Term.store -> (term, term list) view -> term +*) diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index c89d4f06..4dff3026 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -1,4 +1,4 @@ -(** {1 Sidekick base} +(** Sidekick base This library is a starting point for writing concrete implementations of SMT solvers with Sidekick. @@ -14,26 +14,35 @@ etc. Logic formats such as SMT-LIB 2.6 are in fact based on a similar notion of statements, and a [.smt2] files contains a list of statements. - *) +*) -module Term = Sidekick_core.Term -module Base_types = Base_types -module ID = ID -module Stat = Stat -module Value = Base_types.Value -module Term_cell = Base_types.Term_cell -module Statement = Base_types.Statement -module Data = Base_types.Data -module Select = Base_types.Select -module Form = Form -module LRA_view = Base_types.LRA_view -module LRA_pred = Base_types.LRA_pred -module LRA_op = Base_types.LRA_op -module LIA_view = Base_types.LIA_view -module LIA_pred = Base_types.LIA_pred -module LIA_op = Base_types.LIA_op -module Solver_arg = Solver_arg -module Lit = Lit -module Proof = Proof -module Proof_quip = Proof_quip module Types_ = Types_ +module Term = Sidekick_core.Term +module Ty = Ty +module ID = ID +module Form = Form +include Arith_types_ +module Data_ty = Data_ty +module Cstor = Data_ty.Cstor +module Select = Data_ty.Select +module Statement = Statement +module Uconst = Uconst + +(* TODO + + module Value = Value + module Statement = Statement + module Data = Data + module Select = Select + + module LRA_view = Types_.LRA_view + module LRA_pred = Base_types.LRA_pred + module LRA_op = Base_types.LRA_op + module LIA_view = Base_types.LIA_view + module LIA_pred = Base_types.LIA_pred + module LIA_op = Base_types.LIA_op +*) + +(* +module Proof_quip = Proof_quip +*) diff --git a/src/base/Solver_arg.ml b/src/base/Solver_arg.ml deleted file mode 100644 index e41b17d3..00000000 --- a/src/base/Solver_arg.ml +++ /dev/null @@ -1,4 +0,0 @@ -open! Base_types -module Term = Term -module Fun = Fun -module Ty = Ty diff --git a/src/base/Solver_arg.mli b/src/base/Solver_arg.mli deleted file mode 100644 index 6ee03009..00000000 --- a/src/base/Solver_arg.mli +++ /dev/null @@ -1,15 +0,0 @@ -(** Concrete implementation of {!Sidekick_core.TERM} - - this module gathers most definitions above in a form - that is compatible with what Sidekick expects for terms, functions, etc. -*) - -open Base_types - -include - Sidekick_core.TERM - with type Term.t = Term.t - and type Fun.t = Fun.t - and type Ty.t = Ty.t - and type Term.store = Term.store - and type Ty.store = Ty.store diff --git a/src/base/Statement.ml b/src/base/Statement.ml new file mode 100644 index 00000000..9c2d0595 --- /dev/null +++ b/src/base/Statement.ml @@ -0,0 +1,48 @@ +open Sidekick_core +open Types_ + +type t = statement = + | Stmt_set_logic of string + | 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_define of definition list + | Stmt_assert of term + | Stmt_assert_clause of term list + | Stmt_check_sat of (bool * term) list + | Stmt_get_model + | Stmt_get_value of term list + | Stmt_exit + +(** Pretty print a statement *) +let pp out = function + | Stmt_set_logic s -> Fmt.fprintf out "(set-logic %s)" s + | Stmt_set_option l -> + Fmt.fprintf out "(@[set-logic@ %a@])" (Util.pp_list Fmt.string) l + | Stmt_set_info (a, b) -> Fmt.fprintf out "(@[set-info@ %s@ %s@])" a b + | Stmt_check_sat [] -> Fmt.string out "(check-sat)" + | Stmt_check_sat l -> + let pp_pair out (b, t) = + if b then + Term.pp_debug out t + else + 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_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 + | Stmt_exit -> Fmt.string out "(exit)" + | Stmt_data l -> + Fmt.fprintf out "(@[declare-datatypes@ %a@])" (Util.pp_list Data_ty.pp) l + | Stmt_get_model -> Fmt.string out "(get-model)" + | Stmt_get_value l -> + Fmt.fprintf out "(@[get-value@ (@[%a@])@])" (Util.pp_list Term.pp_debug) l + | Stmt_define _ -> assert false +(* TODO *) diff --git a/src/base/Statement.mli b/src/base/Statement.mli new file mode 100644 index 00000000..eb917451 --- /dev/null +++ b/src/base/Statement.mli @@ -0,0 +1,24 @@ +(** Statements. + + A statement is an instruction for the SMT solver to do something, + like asserting that a formula is true, declaring a new constant, + or checking satisfiabilty of the current set of assertions. *) + +open Types_ + +type t = statement = + | Stmt_set_logic of string + | 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_define of definition list + | Stmt_assert of term + | Stmt_assert_clause of term list + | Stmt_check_sat of (bool * term) list + | Stmt_get_model + | Stmt_get_value of term list + | Stmt_exit + +include Sidekick_sigs.PRINT with type t := t diff --git a/src/base/Ty.ml b/src/base/Ty.ml index fcdbe96f..7370d0bd 100644 --- a/src/base/Ty.ml +++ b/src/base/Ty.ml @@ -4,6 +4,8 @@ open Sidekick_core include Sidekick_core.Term open Types_ +let pp = pp_debug + type Const.view += Ty of ty_view type data = Types_.data @@ -14,8 +16,7 @@ let ops_ty : Const.ops = (match ty with | Ty_real -> Fmt.string out "Real" | Ty_int -> Fmt.string out "Int" - | Ty_uninterpreted { id; _ } -> ID.pp out id - | Ty_data d -> ID.pp out d.data.data_id) + | Ty_uninterpreted { id; _ } -> ID.pp out id) | _ -> () let equal a b = @@ -24,8 +25,7 @@ let ops_ty : Const.ops = (match a, b with | Ty_int, Ty_int | Ty_real, Ty_real -> true | Ty_uninterpreted u1, Ty_uninterpreted u2 -> ID.equal u1.id u2.id - | Ty_data d1, Ty_data d2 -> ID.equal d1.data.data_id d2.data.data_id - | (Ty_real | Ty_int | Ty_uninterpreted _ | Ty_data _), _ -> false) + | (Ty_real | Ty_int | Ty_uninterpreted _), _ -> false) | _ -> false let hash = function @@ -33,8 +33,7 @@ let ops_ty : Const.ops = (match a with | Ty_real -> Hash.int 2 | Ty_int -> Hash.int 3 - | Ty_uninterpreted u -> Hash.combine2 10 (ID.hash u.id) - | Ty_data d -> Hash.combine2 30 (ID.hash d.data.data_id)) + | Ty_uninterpreted u -> Hash.combine2 10 (ID.hash u.id)) | _ -> assert false end) @@ -51,8 +50,6 @@ let real tst : ty = mk_ty0 tst Ty_real let uninterpreted tst id : t = mk_ty0 tst (Ty_uninterpreted { id; finite = false }) -let data tst data : t = mk_ty0 tst (Ty_data { data }) - let is_uninterpreted (self : t) = match view self with | E_const { Const.c_view = Ty (Ty_uninterpreted _); _ } -> true diff --git a/src/base/Ty.mli b/src/base/Ty.mli index dac21a9a..dfd9fbf2 100644 --- a/src/base/Ty.mli +++ b/src/base/Ty.mli @@ -7,11 +7,12 @@ end type t = ty type data = Types_.data +include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t + val bool : store -> t val real : store -> t val int : store -> t val uninterpreted : store -> ID.t -> t -val data : store -> data -> t val is_uninterpreted : t -> bool (* TODO: separate functor? diff --git a/src/base/Uconst.ml b/src/base/Uconst.ml new file mode 100644 index 00000000..8a6cd14a --- /dev/null +++ b/src/base/Uconst.ml @@ -0,0 +1,51 @@ +open Types_ + +type ty = Term.t +type t = Types_.uconst = { uc_id: ID.t; uc_ty: ty } + +let[@inline] id self = self.uc_id +let[@inline] ty self = self.uc_ty +let equal a b = ID.equal a.uc_id b.uc_id +let compare a b = ID.compare a.uc_id b.uc_id +let hash a = ID.hash a.uc_id +let pp out c = ID.pp out c.uc_id + +type Const.view += Uconst of t + +let ops = + (module struct + let pp out = function + | Uconst c -> pp out c + | _ -> assert false + + let equal a b = + match a, b with + | Uconst a, Uconst b -> equal a b + | _ -> false + + let hash = function + | Uconst c -> Hash.combine2 522660 (hash c) + | _ -> assert false + end : Const.DYN_OPS) + +let[@inline] make uc_id uc_ty : t = { uc_id; uc_ty } + +let uconst tst (self : t) : Term.t = + Term.const tst @@ Const.make (Uconst self) ops ~ty:self.uc_ty + +let uconst_of_id tst id ty = uconst tst @@ make id ty + +let uconst_of_id' tst id args ret = + let ty = Term.arrow_l tst args ret in + uconst_of_id tst id ty + +module As_key = struct + type nonrec t = t + + let compare = compare + let equal = equal + let hash = hash +end + +module Map = CCMap.Make (As_key) +module Tbl = CCHashtbl.Make (As_key) diff --git a/src/base/Uconst.mli b/src/base/Uconst.mli new file mode 100644 index 00000000..ed7faa59 --- /dev/null +++ b/src/base/Uconst.mli @@ -0,0 +1,23 @@ +(** Uninterpreted constants *) + +open Types_ + +type ty = Term.t +type t = Types_.uconst = { uc_id: ID.t; uc_ty: ty } + +val id : t -> ID.t +val ty : t -> ty + +type Const.view += private Uconst of t + +include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t + +val make : ID.t -> ty -> t +(** Make a new uninterpreted function. *) + +val uconst : Term.store -> t -> Term.t +val uconst_of_id : Term.store -> ID.t -> ty -> Term.t +val uconst_of_id' : Term.store -> ID.t -> ty list -> ty -> Term.t + +module Map : CCMap.S with type key = t +module Tbl : CCHashtbl.S with type key = t diff --git a/src/base/solver/dune b/src/base/solver/dune deleted file mode 100644 index 35b17f20..00000000 --- a/src/base/solver/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name sidekick_base_solver) - (public_name sidekick-base.solver) - (synopsis "Instantiation of solver and theories for Sidekick_base") - (libraries sidekick-base sidekick.core sidekick.smt-solver - sidekick.th-bool-static sidekick.mini-cc sidekick.th-data sidekick.th-lra - sidekick.zarith) - (flags :standard -warn-error -a+8 -safe-string -color always -open - Sidekick_util)) diff --git a/src/base/solver/sidekick_base_solver.ml b/src/base/solver/sidekick_base_solver.ml deleted file mode 100644 index 75b2f777..00000000 --- a/src/base/solver/sidekick_base_solver.ml +++ /dev/null @@ -1,142 +0,0 @@ -(** SMT Solver and Theories for [Sidekick_base]. - - This contains instances of the SMT solver, and theories, - from {!Sidekick_core}, using data structures from - {!Sidekick_base}. *) - -open! Sidekick_base - -(** Argument to the SMT solver *) -module Solver_arg = struct - module T = Sidekick_base.Solver_arg - module Lit = Sidekick_base.Lit - - let view_as_cc = Term.cc_view - let mk_eq = Term.eq - let is_valid_literal _ = true - - module Proof_trace = Sidekick_base.Proof.Proof_trace - module Rule_core = Sidekick_base.Proof.Rule_core - module Rule_sat = Sidekick_base.Proof.Rule_sat - - type step_id = Proof_trace.A.step_id - type rule = Proof_trace.A.rule -end - -module Solver = Sidekick_smt_solver.Make (Solver_arg) -(** SMT solver, obtained from {!Sidekick_smt_solver} *) - -(** Theory of datatypes *) -module Th_data = Sidekick_th_data.Make (struct - module S = Solver - open! Base_types - open! Sidekick_th_data - module Cstor = Cstor - - let as_datatype ty = - match Ty.view ty with - | Ty_atomic { def = Ty_data data; _ } -> - Ty_data { cstors = Lazy.force data.data.data_cstors |> ID.Map.values } - | Ty_atomic { def = _; args; finite = _ } -> - Ty_app { args = Iter.of_list args } - | Ty_bool | Ty_real | Ty_int -> Ty_app { args = Iter.empty } - - let view_as_data t = - match Term.view t with - | Term.App_fun ({ fun_view = Fun.Fun_cstor c; _ }, args) -> T_cstor (c, args) - | Term.App_fun ({ fun_view = Fun.Fun_select sel; _ }, args) -> - assert (CCArray.length args = 1); - T_select (sel.select_cstor, sel.select_i, CCArray.get args 0) - | Term.App_fun ({ fun_view = Fun.Fun_is_a c; _ }, args) -> - assert (CCArray.length args = 1); - T_is_a (c, CCArray.get args 0) - | _ -> T_other t - - let mk_eq = Term.eq - let mk_cstor tst c args : Term.t = Term.app_fun tst (Fun.cstor c) args - let mk_sel tst c i u = Term.app_fun tst (Fun.select_idx c i) [| u |] - - let mk_is_a tst c u : Term.t = - if c.cstor_arity = 0 then - Term.eq tst u (Term.const tst (Fun.cstor c)) - else - Term.app_fun tst (Fun.is_a c) [| u |] - - let ty_is_finite = Ty.finite - let ty_set_is_finite = Ty.set_finite - - module P = Proof.Rule_data -end) - -(** Reducing boolean formulas to clauses *) -module Th_bool = Sidekick_th_bool_static.Make (struct - module S = Solver - - type term = S.T.Term.t - - include Form - module P = Proof.Rule_bool -end) - -module Gensym = struct - type t = { tst: Term.store; mutable fresh: int } - - let create tst : t = { tst; fresh = 0 } - let tst self = self.tst - let copy s = { s with tst = s.tst } - - let fresh_term (self : t) ~pre (ty : Ty.t) : Term.t = - let name = Printf.sprintf "_sk_lra_%s%d" pre self.fresh in - self.fresh <- 1 + self.fresh; - let id = ID.make name in - Term.const self.tst @@ Fun.mk_undef_const id ty -end - -(** Theory of Linear Rational Arithmetic *) -module Th_lra = Sidekick_arith_lra.Make (struct - module S = Solver - module T = Term - module Z = Sidekick_zarith.Int - module Q = Sidekick_zarith.Rational - - type term = S.T.Term.t - type ty = S.T.Ty.t - - module LRA = Sidekick_arith_lra - - let mk_eq = Form.eq - - let mk_lra store l = - match l with - | LRA.LRA_other x -> x - | LRA.LRA_pred (p, x, y) -> T.lra store (Pred (p, x, y)) - | LRA.LRA_op (op, x, y) -> T.lra store (Op (op, x, y)) - | LRA.LRA_const c -> T.lra store (Const c) - | LRA.LRA_mult (c, x) -> T.lra store (Mult (c, x)) - - let mk_bool = T.bool - - let rec view_as_lra t = - match T.view t with - | T.LRA l -> - let module LRA = Sidekick_arith_lra in - (match l with - | Const c -> LRA.LRA_const c - | Pred (p, a, b) -> LRA.LRA_pred (p, a, b) - | Op (op, a, b) -> LRA.LRA_op (op, a, b) - | Mult (c, x) -> LRA.LRA_mult (c, x) - | To_real x -> view_as_lra x - | Var x -> LRA.LRA_other x) - | T.Eq (a, b) when Ty.equal (T.ty a) (Ty.real ()) -> LRA.LRA_pred (Eq, a, b) - | _ -> LRA.LRA_other t - - let ty_lra _st = Ty.real () - let has_ty_real t = Ty.equal (T.ty t) (Ty.real ()) - let lemma_lra = Proof.lemma_lra - - module Gensym = Gensym -end) - -let th_bool : Solver.theory = Th_bool.theory -let th_data : Solver.theory = Th_data.theory -let th_lra : Solver.theory = Th_lra.theory diff --git a/src/base/types_.ml b/src/base/types_.ml index 69e0070e..31b31f89 100644 --- a/src/base/types_.ml +++ b/src/base/types_.ml @@ -9,33 +9,16 @@ type term = Term.t type ty = Term.t type value = Term.t -type fun_view = - | Fun_undef of ty (* simple undefined constant *) - | Fun_select of select - | Fun_cstor of cstor - | Fun_is_a of cstor - | Fun_def of { - pp: 'a. ('a Fmt.printer -> 'a array Fmt.printer) option; - abs: self:term -> term array -> term * bool; (* remove the sign? *) - do_cc: bool; (* participate in congruence closure? *) - relevant: 'a. ID.t -> 'a array -> int -> bool; (* relevant argument? *) - ty: ID.t -> term array -> ty; (* compute type *) - eval: value array -> value; (* evaluate term *) - } - (** Methods on the custom term view whose arguments are ['a]. - Terms must be printable, and provide some additional theory handles. +type uconst = { uc_id: ID.t; uc_ty: ty } +(** Uninterpreted constant. *) - - [relevant] must return a subset of [args] (possibly the same set). - The terms it returns will be activated and evaluated whenever possible. - Terms in [args \ relevant args] are considered for - congruence but not for evaluation. -*) - -and ty_view = +type ty_view = | Ty_int | Ty_real | Ty_uninterpreted of { id: ID.t; mutable finite: bool } - | Ty_data of { data: data } +(* TODO: remove (lives in Data_ty now) + | Ty_data of { data: data } +*) and data = { data_id: ID.t; From 97a5c8efa3bd86826c521b76168e2bdc6883a6c2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 7 Aug 2022 22:42:35 -0400 Subject: [PATCH 070/174] detail --- src/smtlib/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/smtlib/dune b/src/smtlib/dune index c7c1369d..2083bacf 100644 --- a/src/smtlib/dune +++ b/src/smtlib/dune @@ -2,5 +2,5 @@ (name sidekick_smtlib) (public_name sidekick-bin.smtlib) (libraries containers zarith sidekick.core sidekick.util sidekick-base - sidekick-base.solver smtlib-utils sidekick.tef) + smtlib-utils sidekick.tef) (flags :standard -warn-error -a+8 -open Sidekick_util)) From 010451145cb2aba0ae2ea3ba633eb38a8c448da6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:16:54 -0400 Subject: [PATCH 071/174] fix(core-logic): bad constant for ite --- src/core-logic/t_builtins.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml index b5b1e923..7dcb1b66 100644 --- a/src/core-logic/t_builtins.ml +++ b/src/core-logic/t_builtins.ml @@ -61,7 +61,7 @@ let c_ite store = DB.pi_db ~var_name:"A" store ~var_ty:type_ @@ arrow_l store [ bool store; v; v ] v in - const store @@ Const.make C_eq ops ~ty + const store @@ Const.make C_ite ops ~ty let c_not store = let b = bool store in From 7aa113f37929330f50d4350229653ec4c8b0df94 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:17:37 -0400 Subject: [PATCH 072/174] feat(core): make CC_view part of the core library; with default CC view --- src/core/CC_view.ml | 38 ++++++++++++++++++++++++++++++++++++ src/core/CC_view.mli | 33 +++++++++++++++++++++++++++++++ src/core/Sidekick_core.ml | 9 ++++++++- src/core/default_cc_view.ml | 16 +++++++++++++++ src/core/default_cc_view.mli | 3 +++ 5 files changed, 98 insertions(+), 1 deletion(-) create mode 100644 src/core/CC_view.ml create mode 100644 src/core/CC_view.mli create mode 100644 src/core/default_cc_view.ml create mode 100644 src/core/default_cc_view.mli diff --git a/src/core/CC_view.ml b/src/core/CC_view.ml new file mode 100644 index 00000000..e319f5ef --- /dev/null +++ b/src/core/CC_view.ml @@ -0,0 +1,38 @@ +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't +(* do not enter *) + +let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = + match v with + | Bool b -> Bool b + | App_fun (f, args) -> App_fun (f_f f, f_ts args) + | App_ho (f, a) -> App_ho (f_t f, f_t a) + | Not t -> Not (f_t t) + | If (a, b, c) -> If (f_t a, f_t b, f_t c) + | Eq (a, b) -> Eq (f_t a, f_t b) + | Opaque t -> Opaque (f_t t) + +let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = + match v with + | Bool _ -> () + | App_fun (f, args) -> + f_f f; + f_ts args + | App_ho (f, a) -> + f_t f; + f_t a + | Not t -> f_t t + | If (a, b, c) -> + f_t a; + f_t b; + f_t c + | Eq (a, b) -> + f_t a; + f_t b + | Opaque t -> f_t t diff --git a/src/core/CC_view.mli b/src/core/CC_view.mli new file mode 100644 index 00000000..0794bc13 --- /dev/null +++ b/src/core/CC_view.mli @@ -0,0 +1,33 @@ +(** View terms through the lens of a Congruence Closure *) + +(** A view of a term fron the point of view of a congruence closure. + + - ['f] is the type of function symbols + - ['t] is the type of terms + - ['ts] is the type of sequences of terms (arguments of function application) + *) +type ('f, 't, 'ts) t = + | Bool of bool + | App_fun of 'f * 'ts + | App_ho of 't * 't + | If of 't * 't * 't + | Eq of 't * 't + | Not of 't + | Opaque of 't (** do not enter *) + +val map_view : + f_f:('a -> 'b) -> + f_t:('c -> 'd) -> + f_ts:('e -> 'f) -> + ('a, 'c, 'e) t -> + ('b, 'd, 'f) t +(** Map function over a view, one level deep. + Each function maps over a different type, e.g. [f_t] maps over terms *) + +val iter_view : + f_f:('a -> unit) -> + f_t:('b -> unit) -> + f_ts:('c -> unit) -> + ('a, 'b, 'c) t -> + unit +(** Iterate over a view, one level deep. *) diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index ca4699d7..f56f095d 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -14,7 +14,7 @@ module Fmt = CCFormat -(* re-export *) +(** {2 Re-exports from core-logic} *) module Const = Sidekick_core_logic.Const @@ -23,7 +23,14 @@ module Term = struct include Sidekick_core_logic.T_builtins end +(** {2 view} *) + module Bool_view = Bool_view +module CC_view = CC_view +module Default_cc_view = Default_cc_view + +(** {2 Main modules} *) + module Bvar = Sidekick_core_logic.Bvar module Lit = Lit module Proof_step = Proof_step diff --git a/src/core/default_cc_view.ml b/src/core/default_cc_view.ml new file mode 100644 index 00000000..84e0ad7e --- /dev/null +++ b/src/core/default_cc_view.ml @@ -0,0 +1,16 @@ +open Sidekick_core_logic +module View = CC_view + +let view_as_cc (t : Term.t) : _ CC_view.t = + let f, args = Term.unfold_app t in + match Term.view f, args with + | _, [ _; t; u ] when T_builtins.is_eq f -> View.Eq (t, u) + | Term.E_const { Const.c_view = T_builtins.C_ite; _ }, [ _ty; a; b; c ] -> + View.If (a, b, c) + | Term.E_const { Const.c_view = T_builtins.C_not; _ }, [ a ] -> View.Not a + | _ -> + (match Term.view t with + | Term.E_app (f, a) -> View.App_ho (f, a) + | Term.E_const { Const.c_view = T_builtins.C_true; _ } -> View.Bool true + | Term.E_const { Const.c_view = T_builtins.C_false; _ } -> View.Bool false + | _ -> View.Opaque t) diff --git a/src/core/default_cc_view.mli b/src/core/default_cc_view.mli new file mode 100644 index 00000000..9cc83695 --- /dev/null +++ b/src/core/default_cc_view.mli @@ -0,0 +1,3 @@ +open Sidekick_core_logic + +val view_as_cc : Term.t -> (Const.t, Term.t, Term.t list) CC_view.t From 2a8eb0c166f5ce6345d8c3e84bafd02a8e65c063 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:22:33 -0400 Subject: [PATCH 073/174] refactor tests for mini-cc --- unittest/mini-cc/dune | 4 + unittest/mini-cc/sidekick_test_minicc.ml | 172 +++++++++++++++++++++++ 2 files changed, 176 insertions(+) create mode 100644 unittest/mini-cc/dune create mode 100644 unittest/mini-cc/sidekick_test_minicc.ml diff --git a/unittest/mini-cc/dune b/unittest/mini-cc/dune new file mode 100644 index 00000000..9c211a70 --- /dev/null +++ b/unittest/mini-cc/dune @@ -0,0 +1,4 @@ +(test + (name sidekick_test_minicc) + (libraries sidekick.mini-cc sidekick-base alcotest) + (flags :standard -warn-error -a+8)) diff --git a/unittest/mini-cc/sidekick_test_minicc.ml b/unittest/mini-cc/sidekick_test_minicc.ml new file mode 100644 index 00000000..00e3ccaa --- /dev/null +++ b/unittest/mini-cc/sidekick_test_minicc.ml @@ -0,0 +1,172 @@ +open! Sidekick_base +module A = Alcotest + +(* *) + +module T = Term +module CC = Sidekick_mini_cc + +module Setup () = struct + let tst = Term.Store.create () + let ( @-> ) l ret = Term.arrow_l tst l ret + let ty_i = Uconst.uconst_of_id tst (ID.make "$i") (Term.type_ tst) + let ty_bool = Ty.bool tst + let fun_f = Uconst.uconst_of_id tst (ID.make "f") ([ ty_i ] @-> ty_i) + let fun_g = Uconst.uconst_of_id tst (ID.make "g") ([ ty_i; ty_i ] @-> ty_i) + let fun_p = Uconst.uconst_of_id tst (ID.make "p") ([ ty_i ] @-> ty_bool) + let a = Uconst.uconst_of_id tst (ID.make "a") ty_i + let b = Uconst.uconst_of_id tst (ID.make "b") ty_i + let c = Uconst.uconst_of_id tst (ID.make "c") ty_i + let d1 = Uconst.uconst_of_id tst (ID.make "d1") ty_i + let d2 = Uconst.uconst_of_id tst (ID.make "d2") ty_i + let true_ = Term.true_ tst + let false_ = Term.false_ tst + let const c = Term.const tst c + let app_l f l = Term.app_l tst f l + let not_ x = Term.not tst x + let eq a b = Term.eq tst a b + let neq a b = Term.not tst (eq a b) + let ite a b c = Term.ite tst a b c + let f t1 = app_l fun_f [ t1 ] + let g t1 t2 = app_l fun_g [ t1; t2 ] + let p t1 = app_l fun_p [ t1 ] +end + +let l : unit Alcotest.test_case list ref = ref [] +let mk_test name f = l := (name, `Quick, f) :: !l + +let () = + mk_test "test_p_a_b" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(p a) true; + CC.add_lit cc S.(p b) false; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(eq a b) true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_p_a_b_2" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(p a) true; + CC.add_lit cc S.(not_ @@ p b) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(eq a b) true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_f_f_f_a" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(neq a (f (f (f (f (f (f a))))))) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(eq a (f a)) true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_repeated_f_f_f_a" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + for _i = 0 to 10 do + CC.add_lit cc S.(neq a (f (f (f (f (f (f a))))))) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(eq a (f a)) true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + CC.clear cc + done; + () + +let () = + mk_test "test_trans" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(eq a b) true; + CC.add_lit cc S.(eq b c) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(neq (f a) (f c)) true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_true" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.true_ true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.false_ true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_repeated_true" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + for _i = 0 to 10 do + CC.add_lit cc S.true_ true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.false_ true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + CC.clear cc + done; + () + +let () = + mk_test "test_false" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.false_ true; + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = + mk_test "test_not_false" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(not_ false_) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + () + +let () = + mk_test "test_ite" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + for _i = 0 to 10 do + CC.add_lit cc S.(eq a b) true; + CC.add_lit cc S.(p (ite (eq a c) d1 d2)) true; + CC.add_lit cc S.(not_ (p d1)) true; + CC.add_lit cc S.(p d2) true; + A.(check bool) "is-sat" (CC.check_sat cc) true; + CC.add_lit cc S.(eq b c) true; + (* force (p d1) *) + A.(check bool) "is-unsat" (CC.check_sat cc) false; + CC.clear cc + done; + () + +(* from the following PO: + `cl (- a = (g a c)), + (- b = (g a c)), + (- c = (g c b)), + (- a = (g c c)), + (- (g c (g c b)) = (g (g c c) b)), + (+ (g a b) = (g a c))))` +*) +let () = + mk_test "test_reg_1" @@ fun () -> + let module S = Setup () in + let cc = CC.create_default S.tst in + CC.add_lit cc S.(eq a (g a c)) true; + CC.add_lit cc S.(eq b (g a c)) true; + CC.add_lit cc S.(eq c (g c b)) true; + CC.add_lit cc S.(eq a (g c c)) true; + CC.add_lit cc S.(eq (g c (g c b)) (g (g c c) b)) true; + CC.add_lit cc S.(eq (g a b) (g a c)) false; + (* goal *) + A.(check bool) "is-unsat" (CC.check_sat cc) false; + () + +let () = Alcotest.run ~and_exit:true "mini-cc tests" [ "mini-cc", !l ] From f17e689a3c4ac2fd480a51f5c541523164fe5ce7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:22:48 -0400 Subject: [PATCH 074/174] feat(cc): adapt to the new CC_view --- src/cc/CC.ml | 32 +- src/cc/CC.mli | 7 +- src/cc/Sidekick_cc.ml | 1 - src/cc/Sidekick_cc.mli | 2 - src/cc/mini/Sidekick_mini_cc.ml | 337 ---------------------- src/cc/mini/Sidekick_mini_cc.mli | 44 --- src/cc/mini/dune | 5 - src/cc/mini/tests/dune | 4 - src/cc/mini/tests/sidekick_test_minicc.ml | 179 ------------ src/cc/signature.ml | 4 +- src/cc/types_.ml | 2 +- src/cc/view.ml | 38 --- src/cc/view.mli | 33 --- 13 files changed, 19 insertions(+), 669 deletions(-) delete mode 100644 src/cc/mini/Sidekick_mini_cc.ml delete mode 100644 src/cc/mini/Sidekick_mini_cc.mli delete mode 100644 src/cc/mini/dune delete mode 100644 src/cc/mini/tests/dune delete mode 100644 src/cc/mini/tests/sidekick_test_minicc.ml diff --git a/src/cc/CC.ml b/src/cc/CC.ml index c8722d3f..004dec85 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -1,6 +1,6 @@ open Types_ -type view_as_cc = Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t +type view_as_cc = Term.t -> (Const.t, Term.t, Term.t list) CC_view.t type e_node = E_node.t (** A node of the congruence closure *) @@ -165,7 +165,7 @@ end (* compute up-to-date signature *) let update_sig (s : signature) : Signature.t = - View.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) + CC_view.map_view s ~f_f:(fun x -> x) ~f_t:find_ ~f_ts:(List.map find_) (* find whether the given (parent) term corresponds to some signature in [signatures_] *) @@ -466,19 +466,19 @@ and compute_sig0 (self : t) (n : e_node) : Signature.t option = | Eq (a, b) -> let a = deref_sub a in let b = deref_sub b in - return @@ View.Eq (a, b) - | Not u -> return @@ View.Not (deref_sub u) + return @@ CC_view.Eq (a, b) + | Not u -> return @@ CC_view.Not (deref_sub u) | App_fun (f, args) -> - let args = args |> Iter.map deref_sub |> Iter.to_list in + let args = List.map deref_sub args in if args <> [] then - return @@ View.App_fun (f, args) + return @@ CC_view.App_fun (f, args) else None | App_ho (f, a) -> let f = deref_sub f in let a = deref_sub a in - return @@ View.App_ho (f, a) - | If (a, b, c) -> return @@ View.If (deref_sub a, deref_sub b, deref_sub c) + return @@ CC_view.App_ho (f, a) + | If (a, b, c) -> return @@ CC_view.If (deref_sub a, deref_sub b, deref_sub c) let[@inline] add_term self t : e_node = add_term_rec_ self t let mem_term = mem @@ -950,19 +950,9 @@ module Make (A : ARG) : BUILD = struct create_ ?stat ?size tst proof ~view_as_cc:A.view_as_cc end -module Default = struct - include Make (struct - let view_as_cc (t : Term.t) : _ View.t = - let f, args = Term.unfold_app t in - match Term.view f, args with - | _, [ _; t; u ] when Term.is_eq f -> View.Eq (t, u) - | _ -> - (match Term.view t with - | Term.E_app (f, a) -> View.App_ho (f, a) - | Term.E_const c -> View.App_fun (c, Iter.empty) - | _ -> View.Opaque t) - end) -end +module Default = Make (Sidekick_core.Default_cc_view) let create (module A : ARG) ?stat ?size tst proof : t = create_ ?stat ?size tst proof ~view_as_cc:A.view_as_cc + +let create_default = Default.create diff --git a/src/cc/CC.mli b/src/cc/CC.mli index 9107db9e..4041f697 100644 --- a/src/cc/CC.mli +++ b/src/cc/CC.mli @@ -255,7 +255,7 @@ val pop_levels : t -> int -> unit val get_model : t -> E_node.t Iter.t Iter.t (** get all the equivalence classes so they can be merged in the model *) -type view_as_cc = Term.t -> (Const.t, Term.t, Term.t Iter.t) View.t +type view_as_cc = Term.t -> (Const.t, Term.t, Term.t list) CC_view.t (** Arguments to a congruence closure's implementation *) module type ARG = sig @@ -275,7 +275,6 @@ module type BUILD = sig end module Make (_ : ARG) : BUILD -module Default : BUILD val create : (module ARG) -> @@ -291,6 +290,10 @@ val create : as well. *) +val create_default : + ?stat:Stat.t -> ?size:[ `Small | `Big ] -> Term.store -> Proof_trace.t -> t +(** Same as {!create} but with the default CC view *) + (**/**) module Debug_ : sig diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index ad7dc973..49cb02fe 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,4 +1,3 @@ -open Sidekick_core module View = View module E_node = E_node module Expl = Expl diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 0facab95..9d2e149e 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -1,7 +1,5 @@ (** Congruence Closure Implementation *) -open Sidekick_core - module type DYN_MONOID_PLUGIN = Sigs_plugin.DYN_MONOID_PLUGIN module type MONOID_PLUGIN_ARG = Sigs_plugin.MONOID_PLUGIN_ARG module type MONOID_PLUGIN_BUILDER = Sigs_plugin.MONOID_PLUGIN_BUILDER diff --git a/src/cc/mini/Sidekick_mini_cc.ml b/src/cc/mini/Sidekick_mini_cc.ml deleted file mode 100644 index 059ad1b5..00000000 --- a/src/cc/mini/Sidekick_mini_cc.ml +++ /dev/null @@ -1,337 +0,0 @@ -open Sidekick_core -module CC_view = Sidekick_cc.View - -module type ARG = sig - val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) CC_view.t -end - -module type S = sig - type t - - val create : Term.store -> t - val clear : t -> unit - val add_lit : t -> Term.t -> bool -> unit - val check_sat : t -> bool - val classes : t -> Term.t Iter.t Iter.t -end - -module Make (A : ARG) = struct - open CC_view - module T = Term - module T_tbl = Term.Tbl - - type node = { - n_t: Term.t; - mutable n_next: node; (* next in class *) - mutable n_size: int; (* size of class *) - mutable n_parents: node list; - mutable n_root: node; (* root of the class *) - } - - type signature = (Const.t, node, node list) CC_view.t - - module Node = struct - type t = node - - let[@inline] equal (n1 : t) n2 = T.equal n1.n_t n2.n_t - let[@inline] hash (n : t) = T.hash n.n_t - let[@inline] size (n : t) = n.n_size - let[@inline] is_root n = n == n.n_root - let[@inline] root n = n.n_root - let[@inline] term n = n.n_t - let pp out n = T.pp_debug out n.n_t - let add_parent (self : t) ~p : unit = self.n_parents <- p :: self.n_parents - - let make (t : T.t) : t = - let rec n = - { n_t = t; n_size = 1; n_next = n; n_parents = []; n_root = n } - in - n - - (* iterate over the class *) - let iter_cls (n0 : t) f : unit = - let rec aux n = - f n; - let n' = n.n_next in - if equal n' n0 then - () - else - aux n' - in - aux n0 - end - - module Signature = struct - type t = signature - - let equal (s1 : t) s2 : bool = - match s1, s2 with - | Bool b1, Bool b2 -> b1 = b2 - | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 - | App_fun (f1, l1), App_fun (f2, l2) -> - Const.equal f1 f2 && CCList.equal Node.equal l1 l2 - | App_ho (f1, a1), App_ho (f2, a2) -> Node.equal f1 f2 && Node.equal a1 a2 - | Not n1, Not n2 -> Node.equal n1 n2 - | If (a1, b1, c1), If (a2, b2, c2) -> - Node.equal a1 a2 && Node.equal b1 b2 && Node.equal c1 c2 - | Eq (a1, b1), Eq (a2, b2) -> Node.equal a1 a2 && Node.equal b1 b2 - | Opaque u1, Opaque u2 -> Node.equal u1 u2 - | Bool _, _ - | App_fun _, _ - | App_ho _, _ - | If _, _ - | Eq _, _ - | Opaque _, _ - | Not _, _ -> - false - - let hash (s : t) : int = - let module H = CCHash in - match s with - | Bool b -> H.combine2 10 (H.bool b) - | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list Node.hash l) - | App_ho (f, a) -> H.combine3 30 (Node.hash f) (Node.hash a) - | Eq (a, b) -> H.combine3 40 (Node.hash a) (Node.hash b) - | Opaque u -> H.combine2 50 (Node.hash u) - | If (a, b, c) -> H.combine4 60 (Node.hash a) (Node.hash b) (Node.hash c) - | Not u -> H.combine2 70 (Node.hash u) - - let pp out = function - | Bool b -> Fmt.bool out b - | App_fun (f, []) -> Const.pp out f - | App_fun (f, l) -> - Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list Node.pp) l - | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" Node.pp f Node.pp a - | Opaque t -> Node.pp out t - | Not u -> Fmt.fprintf out "(@[not@ %a@])" Node.pp u - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" Node.pp a Node.pp b - | If (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" Node.pp a Node.pp b Node.pp c - end - - module Sig_tbl = CCHashtbl.Make (Signature) - - type t = { - mutable ok: bool; (* unsat? *) - tbl: node T_tbl.t; - sig_tbl: node Sig_tbl.t; - mutable combine: (node * node) list; - mutable pending: node list; (* refresh signature *) - true_: node; - false_: node; - } - - let create tst : t = - let true_ = Term.true_ tst in - let false_ = Term.false_ tst in - let self = - { - ok = true; - tbl = T_tbl.create 128; - sig_tbl = Sig_tbl.create 128; - combine = []; - pending = []; - true_ = Node.make true_; - false_ = Node.make false_; - } - in - T_tbl.add self.tbl true_ self.true_; - T_tbl.add self.tbl false_ self.false_; - self - - let clear (self : t) : unit = - let { ok = _; tbl; sig_tbl; pending = _; combine = _; true_; false_ } = - self - in - self.ok <- true; - self.pending <- []; - self.combine <- []; - T_tbl.clear tbl; - Sig_tbl.clear sig_tbl; - T_tbl.add tbl true_.n_t true_; - T_tbl.add tbl false_.n_t false_; - () - - let sub_ t k : unit = - match A.view_as_cc t with - | Bool _ | Opaque _ -> () - | App_fun (_, args) -> args k - | App_ho (f, a) -> - k f; - k a - | Eq (a, b) -> - k a; - k b - | Not u -> k u - | If (a, b, c) -> - k a; - k b; - k c - - let rec add_t (self : t) (t : Term.t) : node = - match T_tbl.find self.tbl t with - | n -> n - | exception Not_found -> - let node = Node.make t in - T_tbl.add self.tbl t node; - (* add sub-terms, and add [t] to their parent list *) - sub_ t (fun u -> - let n_u = Node.root @@ add_t self u in - Node.add_parent n_u ~p:node); - (* need to compute signature *) - self.pending <- node :: self.pending; - node - - let find_t_ (self : t) (t : Term.t) : node = - try T_tbl.find self.tbl t |> Node.root - with Not_found -> - Error.errorf "mini-cc.find_t: no node for %a" T.pp_debug t - - exception E_unsat - - let compute_sig (self : t) (n : node) : Signature.t option = - let[@inline] return x = Some x in - match A.view_as_cc n.n_t with - | Bool _ | Opaque _ -> None - | Eq (a, b) -> - let a = find_t_ self a in - let b = find_t_ self b in - return @@ Eq (a, b) - | Not u -> return @@ Not (find_t_ self u) - | App_fun (f, args) -> - let args = args |> Iter.map (find_t_ self) |> Iter.to_list in - if args <> [] then - return @@ App_fun (f, args) - else - None - | App_ho (f, a) -> - let f = find_t_ self f in - let a = find_t_ self a in - return @@ App_ho (f, a) - | If (a, b, c) -> - return @@ If (find_t_ self a, find_t_ self b, find_t_ self c) - - let update_sig_ (self : t) (n : node) : unit = - match compute_sig self n with - | None -> () - | Some (Eq (a, b)) -> - if Node.equal a b then ( - (* reduce to [true] *) - let n2 = self.true_ in - Log.debugf 5 (fun k -> - k "(@[mini-cc.congruence-by-eq@ %a@ %a@])" Node.pp n Node.pp n2); - self.combine <- (n, n2) :: self.combine - ) - | Some (Not u) when Node.equal u self.true_ -> - self.combine <- (n, self.false_) :: self.combine - | Some (Not u) when Node.equal u self.false_ -> - self.combine <- (n, self.true_) :: self.combine - | Some (If (a, b, _)) when Node.equal a self.true_ -> - self.combine <- (n, b) :: self.combine - | Some (If (a, _, c)) when Node.equal a self.false_ -> - self.combine <- (n, c) :: self.combine - | Some s -> - Log.debugf 5 (fun k -> k "(@[mini-cc.update-sig@ %a@])" Signature.pp s); - (match Sig_tbl.find self.sig_tbl s with - | n2 when Node.equal n n2 -> () - | n2 -> - (* collision, merge *) - Log.debugf 5 (fun k -> - k "(@[mini-cc.congruence-by-sig@ %a@ %a@])" Node.pp n Node.pp n2); - self.combine <- (n, n2) :: self.combine - | exception Not_found -> Sig_tbl.add self.sig_tbl s n) - - let[@inline] is_bool self n = - Node.equal self.true_ n || Node.equal self.false_ n - - (* merge the two classes *) - let merge_ self n1 n2 : unit = - let n1 = Node.root n1 in - let n2 = Node.root n2 in - if not @@ Node.equal n1 n2 then ( - (* merge into largest class, or into a boolean *) - let n1, n2 = - if is_bool self n1 then - n1, n2 - else if is_bool self n2 then - n2, n1 - else if Node.size n1 > Node.size n2 then - n1, n2 - else - n2, n1 - in - Log.debugf 5 (fun k -> - k "(@[mini-cc.merge@ :into %a@ %a@])" Node.pp n1 Node.pp n2); - - if is_bool self n1 && is_bool self n2 then ( - Log.debugf 5 (fun k -> k "(mini-cc.conflict.merge-true-false)"); - self.ok <- false; - raise E_unsat - ); - - self.pending <- List.rev_append n2.n_parents self.pending; - - (* will change signature *) - - (* merge parent lists *) - n1.n_parents <- List.rev_append n2.n_parents n1.n_parents; - n1.n_size <- n2.n_size + n1.n_size; - - (* update root pointer in [n2.class] *) - Node.iter_cls n2 (fun n -> n.n_root <- n1); - - (* merge classes [next] pointers *) - let n1_next = n1.n_next in - n1.n_next <- n2.n_next; - n2.n_next <- n1_next - ) - - let[@inline] check_ok_ self = if not self.ok then raise_notrace E_unsat - - (* fixpoint of the congruence closure *) - let fixpoint (self : t) : unit = - while not (CCList.is_empty self.pending && CCList.is_empty self.combine) do - check_ok_ self; - while not @@ CCList.is_empty self.pending do - let n = List.hd self.pending in - self.pending <- List.tl self.pending; - update_sig_ self n - done; - while not @@ CCList.is_empty self.combine do - let n1, n2 = List.hd self.combine in - self.combine <- List.tl self.combine; - merge_ self n1 n2 - done - done - - (* API *) - - let add_lit (self : t) (p : T.t) (sign : bool) : unit = - match A.view_as_cc p with - | Eq (t1, t2) when sign -> - let n1 = add_t self t1 in - let n2 = add_t self t2 in - self.combine <- (n1, n2) :: self.combine - | _ -> - (* just merge with true/false *) - let n = add_t self p in - let n2 = - if sign then - self.true_ - else - self.false_ - in - self.combine <- (n, n2) :: self.combine - - let check_sat (self : t) : bool = - try - fixpoint self; - true - with E_unsat -> - self.ok <- false; - false - - let classes self : _ Iter.t = - T_tbl.values self.tbl |> Iter.filter Node.is_root - |> Iter.map (fun n -> Node.iter_cls n |> Iter.map Node.term) -end diff --git a/src/cc/mini/Sidekick_mini_cc.mli b/src/cc/mini/Sidekick_mini_cc.mli deleted file mode 100644 index fd4b4493..00000000 --- a/src/cc/mini/Sidekick_mini_cc.mli +++ /dev/null @@ -1,44 +0,0 @@ -(** Mini congruence closure - - This implementation is as simple as possible, and doesn't provide - backtracking, theories, or explanations. - It just decides the satisfiability of a set of (dis)equations. -*) - -open Sidekick_core -module CC_view = Sidekick_cc.View - -(** Argument for the functor {!Make} - - It only requires a Term.t structure, and a congruence-oriented view. *) -module type ARG = sig - val view_as_cc : Term.t -> (Const.t, Term.t, Term.t Iter.t) CC_view.t -end - -(** Main signature for an instance of the mini congruence closure *) -module type S = sig - type t - (** An instance of the congruence closure. Mutable *) - - val create : Term.store -> t - (** New instance *) - - val clear : t -> unit - (** Fully reset the congruence closure's state *) - - val add_lit : t -> Term.t -> bool -> unit - (** [add_lit cc p sign] asserts that [p] is true if [sign], - or [p] is false if [not sign]. If [p] is an equation and [sign] - is [true], this adds a new equation to the congruence relation. *) - - val check_sat : t -> bool - (** [check_sat cc] returns [true] if the current state is satisfiable, [false] - if it's unsatisfiable. *) - - val classes : t -> Term.t Iter.t Iter.t - (** Traverse the set of classes in the congruence closure. - This should be called only if {!check} returned [Sat]. *) -end - -(** Instantiate the congruence closure for the given Term.t structure. *) -module Make (_ : ARG) : S diff --git a/src/cc/mini/dune b/src/cc/mini/dune deleted file mode 100644 index 23187086..00000000 --- a/src/cc/mini/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name Sidekick_mini_cc) - (public_name sidekick.mini-cc) - (libraries containers iter sidekick.cc sidekick.core sidekick.util) - (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) diff --git a/src/cc/mini/tests/dune b/src/cc/mini/tests/dune deleted file mode 100644 index dfcb4819..00000000 --- a/src/cc/mini/tests/dune +++ /dev/null @@ -1,4 +0,0 @@ -(library - (name sidekick_test_minicc) - (libraries sidekick.mini-cc sidekick-base alcotest) - (flags :standard -warn-error -a+8)) diff --git a/src/cc/mini/tests/sidekick_test_minicc.ml b/src/cc/mini/tests/sidekick_test_minicc.ml deleted file mode 100644 index 1a3969bb..00000000 --- a/src/cc/mini/tests/sidekick_test_minicc.ml +++ /dev/null @@ -1,179 +0,0 @@ -open! Sidekick_base -module A = Alcotest - -module CC = Sidekick_mini_cc.Make (struct - module T = Sidekick_base.Solver_arg - - let view_as_cc = Term.cc_view -end) - -module Setup () = struct - let tst = Term.create () - let ( @-> ) l ret = Ty.Fun.mk l ret - let ty_i = Ty.atomic_uninterpreted (ID.make "$i") - let ty_bool = Ty.bool () - let fun_f = Fun.mk_undef (ID.make "f") ([ ty_i ] @-> ty_i) - let fun_g = Fun.mk_undef (ID.make "g") ([ ty_i; ty_i ] @-> ty_i) - let fun_p = Fun.mk_undef (ID.make "p") ([ ty_i ] @-> ty_bool) - let fun_a = Fun.mk_undef_const (ID.make "a") ty_i - let fun_b = Fun.mk_undef_const (ID.make "b") ty_i - let fun_c = Fun.mk_undef_const (ID.make "c") ty_i - let fun_d1 = Fun.mk_undef_const (ID.make "d1") ty_i - let fun_d2 = Fun.mk_undef_const (ID.make "d2") ty_i - let true_ = Term.true_ tst - let false_ = Term.false_ tst - let const c = Term.const tst c - let app_a f l = Term.app_fun tst f l - let app_l f l = Term.app_fun tst f (CCArray.of_list l) - let not_ x = Term.not_ tst x - let eq a b = Term.eq tst a b - let neq a b = Term.not_ tst (eq a b) - let ite a b c = Term.ite tst a b c - let a = const fun_a - let b = const fun_b - let c = const fun_c - let d1 = const fun_d1 - let d2 = const fun_d2 - let f t1 = app_l fun_f [ t1 ] - let g t1 t2 = app_l fun_g [ t1; t2 ] - let p t1 = app_l fun_p [ t1 ] -end - -let l : unit Alcotest.test_case list ref = ref [] -let mk_test name f = l := (name, `Quick, f) :: !l - -let () = - mk_test "test_p_a_b" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(p a) true; - CC.add_lit cc S.(p b) false; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(eq a b) true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_p_a_b_2" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(p a) true; - CC.add_lit cc S.(not_ @@ p b) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(eq a b) true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_f_f_f_a" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(neq a (f (f (f (f (f (f a))))))) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(eq a (f a)) true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_repeated_f_f_f_a" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - for _i = 0 to 10 do - CC.add_lit cc S.(neq a (f (f (f (f (f (f a))))))) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(eq a (f a)) true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - CC.clear cc - done; - () - -let () = - mk_test "test_trans" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(eq a b) true; - CC.add_lit cc S.(eq b c) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(neq (f a) (f c)) true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_true" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.true_ true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.false_ true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_repeated_true" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - for _i = 0 to 10 do - CC.add_lit cc S.true_ true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.false_ true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - CC.clear cc - done; - () - -let () = - mk_test "test_false" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.false_ true; - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let () = - mk_test "test_not_false" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(not_ false_) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - () - -let () = - mk_test "test_ite" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - for _i = 0 to 10 do - CC.add_lit cc S.(eq a b) true; - CC.add_lit cc S.(p (ite (eq a c) d1 d2)) true; - CC.add_lit cc S.(not_ (p d1)) true; - CC.add_lit cc S.(p d2) true; - A.(check bool) "is-sat" (CC.check_sat cc) true; - CC.add_lit cc S.(eq b c) true; - (* force (p d1) *) - A.(check bool) "is-unsat" (CC.check_sat cc) false; - CC.clear cc - done; - () - -(* from the following PO: - `cl (- a = (g a c)), - (- b = (g a c)), - (- c = (g c b)), - (- a = (g c c)), - (- (g c (g c b)) = (g (g c c) b)), - (+ (g a b) = (g a c))))` -*) -let () = - mk_test "test_reg_1" @@ fun () -> - let module S = Setup () in - let cc = CC.create S.tst in - CC.add_lit cc S.(eq a (g a c)) true; - CC.add_lit cc S.(eq b (g a c)) true; - CC.add_lit cc S.(eq c (g c b)) true; - CC.add_lit cc S.(eq a (g c c)) true; - CC.add_lit cc S.(eq (g c (g c b)) (g (g c c) b)) true; - CC.add_lit cc S.(eq (g a b) (g a c)) false; - (* goal *) - A.(check bool) "is-unsat" (CC.check_sat cc) false; - () - -let tests = "mini-cc", List.rev !l diff --git a/src/cc/signature.ml b/src/cc/signature.ml index 8fdc5ee7..fa1adf7c 100644 --- a/src/cc/signature.ml +++ b/src/cc/signature.ml @@ -1,13 +1,13 @@ (** A signature is a shallow term shape where immediate subterms are representative *) -open View +open Sidekick_core.CC_view open Types_ type t = signature let equal (s1 : t) s2 : bool = - let open View in + let open CC_view in match s1, s2 with | Bool b1, Bool b2 -> b1 = b2 | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 diff --git a/src/cc/types_.ml b/src/cc/types_.ml index c1e1bae1..86fba51b 100644 --- a/src/cc/types_.ml +++ b/src/cc/types_.ml @@ -18,7 +18,7 @@ type e_node = { An equivalence class is represented by its "root" element, the representative. *) -and signature = (Const.t, e_node, e_node list) View.t +and signature = (Const.t, e_node, e_node list) CC_view.t and explanation_forest_link = | FL_none diff --git a/src/cc/view.ml b/src/cc/view.ml index e319f5ef..e69de29b 100644 --- a/src/cc/view.ml +++ b/src/cc/view.ml @@ -1,38 +0,0 @@ -type ('f, 't, 'ts) t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't -(* do not enter *) - -let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = - match v with - | Bool b -> Bool b - | App_fun (f, args) -> App_fun (f_f f, f_ts args) - | App_ho (f, a) -> App_ho (f_t f, f_t a) - | Not t -> Not (f_t t) - | If (a, b, c) -> If (f_t a, f_t b, f_t c) - | Eq (a, b) -> Eq (f_t a, f_t b) - | Opaque t -> Opaque (f_t t) - -let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = - match v with - | Bool _ -> () - | App_fun (f, args) -> - f_f f; - f_ts args - | App_ho (f, a) -> - f_t f; - f_t a - | Not t -> f_t t - | If (a, b, c) -> - f_t a; - f_t b; - f_t c - | Eq (a, b) -> - f_t a; - f_t b - | Opaque t -> f_t t diff --git a/src/cc/view.mli b/src/cc/view.mli index 038ea1a6..e69de29b 100644 --- a/src/cc/view.mli +++ b/src/cc/view.mli @@ -1,33 +0,0 @@ -(** View terms through the lens of the Congruence Closure *) - -(** A view of a term fron the point of view of the congruence closure. - - - ['f] is the type of function symbols - - ['t] is the type of terms - - ['ts] is the type of sequences of terms (arguments of function application) - *) -type ('f, 't, 'ts) t = - | Bool of bool - | App_fun of 'f * 'ts - | App_ho of 't * 't - | If of 't * 't * 't - | Eq of 't * 't - | Not of 't - | Opaque of 't (** do not enter *) - -val map_view : - f_f:('a -> 'b) -> - f_t:('c -> 'd) -> - f_ts:('e -> 'f) -> - ('a, 'c, 'e) t -> - ('b, 'd, 'f) t -(** Map function over a view, one level deep. - Each function maps over a different type, e.g. [f_t] maps over terms *) - -val iter_view : - f_f:('a -> unit) -> - f_t:('b -> unit) -> - f_ts:('c -> unit) -> - ('a, 'b, 'c) t -> - unit -(** Iterate over a view, one level deep. *) From 95beb2bf273b6c7933bcac991d078f171563298d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:49:47 -0400 Subject: [PATCH 075/174] core: add better printer --- src/core/Sidekick_core.ml | 1 + src/core/t_printer.ml | 86 +++++++++++++++++++++++++++++++++++++++ src/core/t_printer.mli | 21 ++++++++++ 3 files changed, 108 insertions(+) create mode 100644 src/core/t_printer.ml create mode 100644 src/core/t_printer.mli diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index f56f095d..892440a6 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -21,6 +21,7 @@ module Const = Sidekick_core_logic.Const module Term = struct include Sidekick_core_logic.Term include Sidekick_core_logic.T_builtins + include T_printer end (** {2 view} *) diff --git a/src/core/t_printer.ml b/src/core/t_printer.ml new file mode 100644 index 00000000..7dc82b61 --- /dev/null +++ b/src/core/t_printer.ml @@ -0,0 +1,86 @@ +open Sidekick_core_logic + +type term = Sidekick_core_logic.Term.t + +type hook = recurse:term Fmt.printer -> Fmt.t -> term -> bool +(** Printing hook, responsible for printing certain subterms *) + +module Hooks = struct + type t = hook list + + let empty = [] + let add h l = h :: l +end + +let pp_builtins_ : hook = + fun ~recurse out t -> + match Default_cc_view.view_as_cc t with + | CC_view.If (a, b, c) -> + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" recurse a recurse b recurse c; + true + | CC_view.Eq (a, b) -> + Fmt.fprintf out "(@[=@ %a@ %a@])" recurse a recurse b; + true + | _ -> false + +let default_ : Hooks.t = Hooks.(empty |> add pp_builtins_) +let default_hooks = ref default_ + +(* debug printer *) +let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = + let open Term in + let rec loop k ~depth names out e = + let pp' = loop' k ~depth:(depth + 1) names in + + let hook_fired = List.exists (fun h -> h ~recurse:pp' out e) hooks in + if not hook_fired then ( + match Term.view e with + | E_type 0 -> Fmt.string out "Type" + | E_type i -> Fmt.fprintf out "Type(%d)" i + | E_var v -> Fmt.string out (Var.name v) + (* | E_var v -> Fmt.fprintf out "(@[%s : %a@])" v.v_name pp v.v_ty *) + | E_bound_var v -> + let idx = v.Bvar.bv_idx in + (match CCList.nth_opt names idx with + | Some n when n <> "" -> Fmt.fprintf out "%s[%d]" n idx + | _ -> Fmt.fprintf out "_[%d]" idx) + | E_const c -> Const.pp out c + | (E_app _ | E_lam _) when depth > max_depth -> Fmt.fprintf out "@<1>…" + | E_app _ -> + let f, args = unfold_app e in + Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args + | E_lam ("", _ty, bod) -> + Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_lam (n, _ty, bod) -> + Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod + | E_pi (_, ty, bod) when is_closed bod -> + (* actually just an arrow *) + Fmt.fprintf out "(@[%a@ -> %a@])" + (loop k ~depth:(depth + 1) names) + ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_pi ("", _ty, bod) -> + Fmt.fprintf out "(@[Pi _:@[%a@].@ %a@])" pp' _ty + (loop (k + 1) ~depth:(depth + 1) ("" :: names)) + bod + | E_pi (n, _ty, bod) -> + Fmt.fprintf out "(@[Pi %s:@[%a@].@ %a@])" n pp' _ty + (loop (k + 1) ~depth:(depth + 1) (n :: names)) + bod + ) + and loop' k ~depth names out e = + match Term.view e with + | E_type _ | E_var _ | E_bound_var _ | E_const _ -> + loop k ~depth names out e (* atomic expr *) + | E_app _ | E_lam _ | E_pi _ -> + Fmt.fprintf out "(%a)" (loop k ~depth names) e + in + Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e + +let pp_with hooks out e : unit = expr_pp_with_ ~max_depth:max_int ~hooks out e +let pp out e = pp_with !default_hooks out e diff --git a/src/core/t_printer.mli b/src/core/t_printer.mli new file mode 100644 index 00000000..2ac0cbc4 --- /dev/null +++ b/src/core/t_printer.mli @@ -0,0 +1,21 @@ +(** Extensible printer for {!Sidekick_core_logic.Term.t} *) + +type term = Sidekick_core_logic.Term.t + +type hook = recurse:term Fmt.printer -> Fmt.t -> term -> bool +(** Printing hook, responsible for printing certain subterms *) + +module Hooks : sig + type t + + val empty : t + val add : hook -> t -> t +end + +val default_hooks : Hooks.t ref + +val pp_with : Hooks.t -> term Fmt.printer +(** Print using the hooks *) + +val pp : term Fmt.printer +(** Print using {!default_hooks} *) From 8003cdcebb456a55e56620eaa0b7edd03460dc3b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:52:20 -0400 Subject: [PATCH 076/174] sidekick-mini-cc: remove functor --- src/mini-cc/Sidekick_mini_cc.ml | 340 +++++++++++++++++++++++++++++++ src/mini-cc/Sidekick_mini_cc.mli | 40 ++++ src/mini-cc/dune | 5 + 3 files changed, 385 insertions(+) create mode 100644 src/mini-cc/Sidekick_mini_cc.ml create mode 100644 src/mini-cc/Sidekick_mini_cc.mli create mode 100644 src/mini-cc/dune diff --git a/src/mini-cc/Sidekick_mini_cc.ml b/src/mini-cc/Sidekick_mini_cc.ml new file mode 100644 index 00000000..efae41e3 --- /dev/null +++ b/src/mini-cc/Sidekick_mini_cc.ml @@ -0,0 +1,340 @@ +open Sidekick_core + +module type ARG = sig + val view_as_cc : Term.t -> (Const.t, Term.t, Term.t list) CC_view.t +end + +module type S = sig + type t + + val create : Term.store -> t + val clear : t -> unit + val add_lit : t -> Term.t -> bool -> unit + val check_sat : t -> bool + val classes : t -> Term.t Iter.t Iter.t +end + +open CC_view +module T = Term +module T_tbl = Term.Tbl + +type node = { + n_t: Term.t; + mutable n_next: node; (* next in class *) + mutable n_size: int; (* size of class *) + mutable n_parents: node list; + mutable n_root: node; (* root of the class *) +} + +type signature = (Const.t, node, node list) CC_view.t + +module Node = struct + type t = node + + let[@inline] equal (n1 : t) n2 = T.equal n1.n_t n2.n_t + let[@inline] hash (n : t) = T.hash n.n_t + let[@inline] size (n : t) = n.n_size + let[@inline] is_root n = n == n.n_root + let[@inline] root n = n.n_root + let[@inline] term n = n.n_t + let pp out n = T.pp_debug out n.n_t + let add_parent (self : t) ~p : unit = self.n_parents <- p :: self.n_parents + + let make (t : T.t) : t = + let rec n = + { n_t = t; n_size = 1; n_next = n; n_parents = []; n_root = n } + in + n + + (* iterate over the class *) + let iter_cls (n0 : t) f : unit = + let rec aux n = + f n; + let n' = n.n_next in + if equal n' n0 then + () + else + aux n' + in + aux n0 +end + +module Signature = struct + type t = signature + + let equal (s1 : t) s2 : bool = + match s1, s2 with + | Bool b1, Bool b2 -> b1 = b2 + | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 + | App_fun (f1, l1), App_fun (f2, l2) -> + Const.equal f1 f2 && CCList.equal Node.equal l1 l2 + | App_ho (f1, a1), App_ho (f2, a2) -> Node.equal f1 f2 && Node.equal a1 a2 + | Not n1, Not n2 -> Node.equal n1 n2 + | If (a1, b1, c1), If (a2, b2, c2) -> + Node.equal a1 a2 && Node.equal b1 b2 && Node.equal c1 c2 + | Eq (a1, b1), Eq (a2, b2) -> Node.equal a1 a2 && Node.equal b1 b2 + | Opaque u1, Opaque u2 -> Node.equal u1 u2 + | Bool _, _ + | App_fun _, _ + | App_ho _, _ + | If _, _ + | Eq _, _ + | Opaque _, _ + | Not _, _ -> + false + + let hash (s : t) : int = + let module H = CCHash in + match s with + | Bool b -> H.combine2 10 (H.bool b) + | App_fun (f, l) -> H.combine3 20 (Const.hash f) (H.list Node.hash l) + | App_ho (f, a) -> H.combine3 30 (Node.hash f) (Node.hash a) + | Eq (a, b) -> H.combine3 40 (Node.hash a) (Node.hash b) + | Opaque u -> H.combine2 50 (Node.hash u) + | If (a, b, c) -> H.combine4 60 (Node.hash a) (Node.hash b) (Node.hash c) + | Not u -> H.combine2 70 (Node.hash u) + + let pp out = function + | Bool b -> Fmt.bool out b + | App_fun (f, []) -> Const.pp out f + | App_fun (f, l) -> + Fmt.fprintf out "(@[%a@ %a@])" Const.pp f (Util.pp_list Node.pp) l + | App_ho (f, a) -> Fmt.fprintf out "(@[%a@ %a@])" Node.pp f Node.pp a + | Opaque t -> Node.pp out t + | Not u -> Fmt.fprintf out "(@[not@ %a@])" Node.pp u + | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" Node.pp a Node.pp b + | If (a, b, c) -> + Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" Node.pp a Node.pp b Node.pp c +end + +module Sig_tbl = CCHashtbl.Make (Signature) + +type t = { + mutable ok: bool; (* unsat? *) + arg: (module ARG); + tbl: node T_tbl.t; + sig_tbl: node Sig_tbl.t; + mutable combine: (node * node) list; + mutable pending: node list; (* refresh signature *) + true_: node; + false_: node; +} + +let create ~arg tst : t = + let true_ = Term.true_ tst in + let false_ = Term.false_ tst in + let self = + { + ok = true; + arg; + tbl = T_tbl.create 128; + sig_tbl = Sig_tbl.create 128; + combine = []; + pending = []; + true_ = Node.make true_; + false_ = Node.make false_; + } + in + T_tbl.add self.tbl true_ self.true_; + T_tbl.add self.tbl false_ self.false_; + self + +let create_default tst : t = create ~arg:(module Default_cc_view) tst + +let clear (self : t) : unit = + let { ok = _; arg = _; tbl; sig_tbl; pending = _; combine = _; true_; false_ } + = + self + in + self.ok <- true; + self.pending <- []; + self.combine <- []; + T_tbl.clear tbl; + Sig_tbl.clear sig_tbl; + T_tbl.add tbl true_.n_t true_; + T_tbl.add tbl false_.n_t false_; + () + +let sub_ (self : t) t k : unit = + let (module A) = self.arg in + match A.view_as_cc t with + | Bool _ | Opaque _ -> () + | App_fun (_, args) -> List.iter k args + | App_ho (f, a) -> + k f; + k a + | Eq (a, b) -> + k a; + k b + | Not u -> k u + | If (a, b, c) -> + k a; + k b; + k c + +let rec add_t (self : t) (t : Term.t) : node = + match T_tbl.find self.tbl t with + | n -> n + | exception Not_found -> + let node = Node.make t in + T_tbl.add self.tbl t node; + (* add sub-terms, and add [t] to their parent list *) + sub_ self t (fun u -> + let n_u = Node.root @@ add_t self u in + Node.add_parent n_u ~p:node); + (* need to compute signature *) + self.pending <- node :: self.pending; + node + +let find_t_ (self : t) (t : Term.t) : node = + try T_tbl.find self.tbl t |> Node.root + with Not_found -> Error.errorf "mini-cc.find_t: no node for %a" T.pp_debug t + +exception E_unsat + +let compute_sig (self : t) (n : node) : Signature.t option = + let[@inline] return x = Some x in + let (module A) = self.arg in + match A.view_as_cc n.n_t with + | Bool _ | Opaque _ -> None + | Eq (a, b) -> + let a = find_t_ self a in + let b = find_t_ self b in + return @@ Eq (a, b) + | Not u -> return @@ Not (find_t_ self u) + | App_fun (f, args) -> + let args = List.map (find_t_ self) args in + if args <> [] then + return @@ App_fun (f, args) + else + None + | App_ho (f, a) -> + let f = find_t_ self f in + let a = find_t_ self a in + return @@ App_ho (f, a) + | If (a, b, c) -> return @@ If (find_t_ self a, find_t_ self b, find_t_ self c) + +let update_sig_ (self : t) (n : node) : unit = + match compute_sig self n with + | None -> () + | Some (Eq (a, b)) -> + if Node.equal a b then ( + (* reduce to [true] *) + let n2 = self.true_ in + Log.debugf 5 (fun k -> + k "(@[mini-cc.congruence-by-eq@ %a@ %a@])" Node.pp n Node.pp n2); + self.combine <- (n, n2) :: self.combine + ) + | Some (Not u) when Node.equal u self.true_ -> + self.combine <- (n, self.false_) :: self.combine + | Some (Not u) when Node.equal u self.false_ -> + self.combine <- (n, self.true_) :: self.combine + | Some (If (a, b, _)) when Node.equal a self.true_ -> + self.combine <- (n, b) :: self.combine + | Some (If (a, _, c)) when Node.equal a self.false_ -> + self.combine <- (n, c) :: self.combine + | Some s -> + Log.debugf 5 (fun k -> k "(@[mini-cc.update-sig@ %a@])" Signature.pp s); + (match Sig_tbl.find self.sig_tbl s with + | n2 when Node.equal n n2 -> () + | n2 -> + (* collision, merge *) + Log.debugf 5 (fun k -> + k "(@[mini-cc.congruence-by-sig@ %a@ %a@])" Node.pp n Node.pp n2); + self.combine <- (n, n2) :: self.combine + | exception Not_found -> Sig_tbl.add self.sig_tbl s n) + +let[@inline] is_bool self n = + Node.equal self.true_ n || Node.equal self.false_ n + +(* merge the two classes *) +let merge_ self n1 n2 : unit = + let n1 = Node.root n1 in + let n2 = Node.root n2 in + if not @@ Node.equal n1 n2 then ( + (* merge into largest class, or into a boolean *) + let n1, n2 = + if is_bool self n1 then + n1, n2 + else if is_bool self n2 then + n2, n1 + else if Node.size n1 > Node.size n2 then + n1, n2 + else + n2, n1 + in + Log.debugf 5 (fun k -> + k "(@[mini-cc.merge@ :into %a@ %a@])" Node.pp n1 Node.pp n2); + + if is_bool self n1 && is_bool self n2 then ( + Log.debugf 5 (fun k -> k "(mini-cc.conflict.merge-true-false)"); + self.ok <- false; + raise E_unsat + ); + + self.pending <- List.rev_append n2.n_parents self.pending; + + (* will change signature *) + + (* merge parent lists *) + n1.n_parents <- List.rev_append n2.n_parents n1.n_parents; + n1.n_size <- n2.n_size + n1.n_size; + + (* update root pointer in [n2.class] *) + Node.iter_cls n2 (fun n -> n.n_root <- n1); + + (* merge classes [next] pointers *) + let n1_next = n1.n_next in + n1.n_next <- n2.n_next; + n2.n_next <- n1_next + ) + +let[@inline] check_ok_ self = if not self.ok then raise_notrace E_unsat + +(* fixpoint of the congruence closure *) +let fixpoint (self : t) : unit = + while not (CCList.is_empty self.pending && CCList.is_empty self.combine) do + check_ok_ self; + while not @@ CCList.is_empty self.pending do + let n = List.hd self.pending in + self.pending <- List.tl self.pending; + update_sig_ self n + done; + while not @@ CCList.is_empty self.combine do + let n1, n2 = List.hd self.combine in + self.combine <- List.tl self.combine; + merge_ self n1 n2 + done + done + +(* API *) + +let add_lit (self : t) (p : T.t) (sign : bool) : unit = + let (module A) = self.arg in + match A.view_as_cc p with + | Eq (t1, t2) when sign -> + let n1 = add_t self t1 in + let n2 = add_t self t2 in + self.combine <- (n1, n2) :: self.combine + | _ -> + (* just merge with true/false *) + let n = add_t self p in + let n2 = + if sign then + self.true_ + else + self.false_ + in + self.combine <- (n, n2) :: self.combine + +let check_sat (self : t) : bool = + try + fixpoint self; + true + with E_unsat -> + self.ok <- false; + false + +let classes self : _ Iter.t = + T_tbl.values self.tbl |> Iter.filter Node.is_root + |> Iter.map (fun n -> Node.iter_cls n |> Iter.map Node.term) diff --git a/src/mini-cc/Sidekick_mini_cc.mli b/src/mini-cc/Sidekick_mini_cc.mli new file mode 100644 index 00000000..1aa24880 --- /dev/null +++ b/src/mini-cc/Sidekick_mini_cc.mli @@ -0,0 +1,40 @@ +(** Mini congruence closure + + This implementation is as simple as possible, and doesn't provide + backtracking, theories, or explanations. + It just decides the satisfiability of a set of (dis)equations. +*) + +open Sidekick_core + +(** Argument for the functor {!Make} + + It only requires a Term.t structure, and a congruence-oriented view. *) +module type ARG = sig + val view_as_cc : Term.t -> (Const.t, Term.t, Term.t list) CC_view.t +end + +type t +(** An instance of the congruence closure. Mutable *) + +val create : arg:(module ARG) -> Term.store -> t +(** Instantiate the congruence closure for the given argument structure. *) + +val create_default : Term.store -> t +(** Use the default cc view *) + +val clear : t -> unit +(** Fully reset the congruence closure's state *) + +val add_lit : t -> Term.t -> bool -> unit +(** [add_lit cc p sign] asserts that [p] is true if [sign], + or [p] is false if [not sign]. If [p] is an equation and [sign] + is [true], this adds a new equation to the congruence relation. *) + +val check_sat : t -> bool +(** [check_sat cc] returns [true] if the current state is satisfiable, [false] + if it's unsatisfiable. *) + +val classes : t -> Term.t Iter.t Iter.t +(** Traverse the set of classes in the congruence closure. + This should be called only if {!check} returned [Sat]. *) diff --git a/src/mini-cc/dune b/src/mini-cc/dune new file mode 100644 index 00000000..23187086 --- /dev/null +++ b/src/mini-cc/dune @@ -0,0 +1,5 @@ +(library + (name Sidekick_mini_cc) + (public_name sidekick.mini-cc) + (libraries containers iter sidekick.cc sidekick.core sidekick.util) + (flags :standard -warn-error -a+8 -w -32 -open Sidekick_util)) From 7d59846d72a1d1ba05f1225fcc8bb1678d69731c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:52:39 -0400 Subject: [PATCH 077/174] wip: refactor base --- src/base/Form.mli | 2 +- src/base/Statement.ml | 1 - src/base/Ty.ml | 1 - 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/base/Form.mli b/src/base/Form.mli index e184db65..4b635b29 100644 --- a/src/base/Form.mli +++ b/src/base/Form.mli @@ -34,7 +34,7 @@ val neq : Term.store -> term -> term -> term val imply : Term.store -> term -> term -> term val equiv : Term.store -> term -> term -> term val xor : Term.store -> term -> term -> term -val ite : Term.store -> term -> term -> term +val ite : Term.store -> term -> term -> term -> term (* *) diff --git a/src/base/Statement.ml b/src/base/Statement.ml index 9c2d0595..22abe1aa 100644 --- a/src/base/Statement.ml +++ b/src/base/Statement.ml @@ -1,4 +1,3 @@ -open Sidekick_core open Types_ type t = statement = diff --git a/src/base/Ty.ml b/src/base/Ty.ml index 7370d0bd..aaa431d5 100644 --- a/src/base/Ty.ml +++ b/src/base/Ty.ml @@ -1,6 +1,5 @@ (** Core types *) -open Sidekick_core include Sidekick_core.Term open Types_ From fc5ce9bf87dd4524ed6c47ec514ae877c1dd1427 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 8 Aug 2022 21:52:47 -0400 Subject: [PATCH 078/174] wip: make it compile --- src/smt/solver.ml | 3 -- src/smt/solver.mli | 2 + src/smtlib/Process.ml | 45 ++++++++++--------- src/smtlib/Process.mli | 9 +--- src/smtlib/dune | 2 +- {src/tests => unittest/old}/basic.cnf | 0 .../old}/basic.drup.expected | 0 {src/tests => unittest/old}/dune | 2 +- {src/tests => unittest/old}/regression/dune | 0 .../regression/reg_model_lra1.out.expected | 0 .../old}/regression/reg_model_lra1.smt2 | 0 {src/tests => unittest/old}/run_tests.ml | 7 +-- 12 files changed, 29 insertions(+), 41 deletions(-) rename {src/tests => unittest/old}/basic.cnf (100%) rename {src/tests => unittest/old}/basic.drup.expected (100%) rename {src/tests => unittest/old}/dune (93%) rename {src/tests => unittest/old}/regression/dune (100%) rename {src/tests => unittest/old}/regression/reg_model_lra1.out.expected (100%) rename {src/tests => unittest/old}/regression/reg_model_lra1.smt2 (100%) rename {src/tests => unittest/old}/run_tests.ml (79%) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 6f92f526..4b2aa8ab 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -69,8 +69,6 @@ type t = { count_solve: int Stat.counter; (* config: Config.t *) } -type solver = t - (** {2 Main} *) type theory = Theory.t @@ -117,7 +115,6 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = self let[@inline] solver self = self.solver -let[@inline] cc self = Solver_internal.cc self.si let[@inline] stats self = self.stat let[@inline] tst self = Solver_internal.tst self.si let[@inline] proof self = self.proof diff --git a/src/smt/solver.mli b/src/smt/solver.mli index 97628abd..d297cc6a 100644 --- a/src/smt/solver.mli +++ b/src/smt/solver.mli @@ -14,6 +14,8 @@ type t val registry : t -> Registry.t (** A solver contains a registry so that theories can share data *) +type theory = Theory.t + val mk_theory : name:string -> create_and_setup:(Solver_internal.t -> 'th) -> diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 17f685ed..8ff0297b 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -1,8 +1,8 @@ (** {2 Conversion into {!Term.t}} *) +open Sidekick_core module Profile = Sidekick_util.Profile open! Sidekick_base -module SBS = Sidekick_base_solver [@@@ocaml.warning "-32"] @@ -10,12 +10,11 @@ type 'a or_error = ('a, string) CCResult.t module E = CCResult module Fmt = CCFormat -module Solver = SBS.Solver +module Solver = Sidekick_smt_solver.Solver module Check_cc = struct - module Lit = Solver.Solver_internal.Lit - module SI = Solver.Solver_internal - module MCC = Sidekick_mini_cc.Make (SBS.Solver_arg) + module SI = Sidekick_smt_solver.Solver_internal + module MCC = Sidekick_mini_cc let pp_c out c = Fmt.fprintf out "(@[%a@])" (Util.pp_list ~sep:" ∨ " Lit.pp) c @@ -30,7 +29,7 @@ module Check_cc = struct let check_conflict si _cc (confl : Lit.t list) : unit = Log.debugf 15 (fun k -> k "(@[check-cc-conflict@ %a@])" pp_c confl); let tst = SI.tst si in - let cc = MCC.create tst in + let cc = MCC.create_default tst in (* add [¬confl] and check it's unsat *) List.iter (fun lit -> add_cc_lit cc @@ Lit.neg lit) confl; if MCC.check_sat cc then @@ -46,7 +45,7 @@ module Check_cc = struct Log.debugf 15 (fun k -> k "(@[check-cc-prop@ %a@ :reason %a@])" Lit.pp p pp_and reason); let tst = SI.tst si in - let cc = MCC.create tst in + let cc = MCC.create_default tst in (* add [reason & ¬lit] and check it's unsat *) List.iter (add_cc_lit cc) reason; add_cc_lit cc (Lit.neg p); @@ -62,10 +61,8 @@ module Check_cc = struct let theory = Solver.mk_theory ~name:"cc-check" ~create_and_setup:(fun si -> - let n_calls = - Stat.mk_int (Solver.Solver_internal.stats si) "check-cc.call" - in - Solver.Solver_internal.on_cc_conflict si (fun { cc; th; c } -> + let n_calls = Stat.mk_int (SI.stats si) "check-cc.call" in + SI.on_cc_conflict si (fun { cc; th; c } -> if not th then ( Stat.incr n_calls; check_conflict si cc c @@ -184,7 +181,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) | Solver.Sat m -> if pp_model then (* TODO: use actual {!Model} in the solver? or build it afterwards *) - Format.printf "(@[model@ %a@])@." Solver.Model.pp m; + Format.printf "(@[model@ %a@])@." Sidekick_smt_solver.Model.pp m; (* TODO if check then ( Solver.check_model s; @@ -210,12 +207,16 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) | Some step_id -> let proof = Solver.proof s in let proof_quip = - Profile.with_ "proof.to-quip" @@ fun () -> - Proof_quip.of_proof proof ~unsat:step_id + Profile.with_ "proof.to-quip" @@ fun () -> assert false + (* TODO + Proof_quip.of_proof proof ~unsat:step_id + *) in Profile.with_ "proof.write-file" @@ fun () -> with_file_out file @@ fun oc -> - Proof_quip.output oc proof_quip; + (* TODO + Proof_quip.output oc proof_quip; + *) flush oc) | _ -> ()); @@ -248,7 +249,7 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model (* TODO: more? *) in - let add_step r = Solver.Proof_trace.add_step (Solver.proof solver) r in + let add_step r = Proof_trace.add_step (Solver.proof solver) r in match stmt with | Statement.Stmt_set_logic logic -> @@ -283,7 +284,7 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model if pp_cnf then Format.printf "(@[assert@ %a@])@." Term.pp t; let lit = Solver.mk_lit_t solver t in Solver.add_clause solver [| lit |] - (add_step @@ Proof.Rule_sat.sat_input_clause (Iter.singleton lit)); + (add_step @@ fun () -> Proof_sat.sat_input_clause [ lit ]); E.return () | Statement.Stmt_assert_clause c_ts -> if pp_cnf then @@ -293,16 +294,16 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model (* proof of assert-input + preprocessing *) let pr = - let tst = Solver.tst solver in - let lits = Iter.of_list c_ts |> Iter.map (Lit.atom tst) in - add_step @@ Proof.Rule_sat.sat_input_clause lits + add_step @@ fun () -> + let lits = List.map Lit.atom c_ts in + Proof_sat.sat_input_clause lits in Solver.add_clause solver (CCArray.of_list c) pr; E.return () | Statement.Stmt_get_model -> (match Solver.last_res solver with - | Some (Solver.Sat m) -> Fmt.printf "%a@." Solver.Model.pp m + | Some (Solver.Sat m) -> Fmt.printf "%a@." Sidekick_smt_solver.Model.pp m | _ -> Error.errorf "cannot access model"); E.return () | Statement.Stmt_get_value l -> @@ -311,7 +312,7 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model let l = List.map (fun t -> - match Solver.Model.eval m t with + match Sidekick_smt_solver.Model.eval m t with | None -> Error.errorf "cannot evaluate %a" Term.pp t | Some u -> t, u) l diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index 1d67b33c..99785ff3 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -1,14 +1,7 @@ (** {1 Process Statements} *) open Sidekick_base - -module Solver : - Sidekick_smt_solver.S - with type T.Term.t = Term.t - and type T.Term.store = Term.store - and type T.Ty.t = Ty.t - and type T.Ty.store = Ty.store - and type Proof_trace.t = Proof.t +module Solver = Sidekick_smt_solver.Solver val th_bool : Solver.theory val th_data : Solver.theory diff --git a/src/smtlib/dune b/src/smtlib/dune index 2083bacf..e32fd5b9 100644 --- a/src/smtlib/dune +++ b/src/smtlib/dune @@ -2,5 +2,5 @@ (name sidekick_smtlib) (public_name sidekick-bin.smtlib) (libraries containers zarith sidekick.core sidekick.util sidekick-base - smtlib-utils sidekick.tef) + sidekick.mini-cc smtlib-utils sidekick.tef) (flags :standard -warn-error -a+8 -open Sidekick_util)) diff --git a/src/tests/basic.cnf b/unittest/old/basic.cnf similarity index 100% rename from src/tests/basic.cnf rename to unittest/old/basic.cnf diff --git a/src/tests/basic.drup.expected b/unittest/old/basic.drup.expected similarity index 100% rename from src/tests/basic.drup.expected rename to unittest/old/basic.drup.expected diff --git a/src/tests/dune b/unittest/old/dune similarity index 93% rename from src/tests/dune rename to unittest/old/dune index 7cab1b89..da6b7015 100644 --- a/src/tests/dune +++ b/unittest/old/dune @@ -3,7 +3,7 @@ (modules run_tests) (modes native) (libraries containers alcotest qcheck sidekick.util sidekick_test_simplex - sidekick_test_util sidekick_test_minicc) + sidekick_test_util) (flags :standard -warn-error -a+8 -color always)) (rule diff --git a/src/tests/regression/dune b/unittest/old/regression/dune similarity index 100% rename from src/tests/regression/dune rename to unittest/old/regression/dune diff --git a/src/tests/regression/reg_model_lra1.out.expected b/unittest/old/regression/reg_model_lra1.out.expected similarity index 100% rename from src/tests/regression/reg_model_lra1.out.expected rename to unittest/old/regression/reg_model_lra1.out.expected diff --git a/src/tests/regression/reg_model_lra1.smt2 b/unittest/old/regression/reg_model_lra1.smt2 similarity index 100% rename from src/tests/regression/reg_model_lra1.smt2 rename to unittest/old/regression/reg_model_lra1.smt2 diff --git a/src/tests/run_tests.ml b/unittest/old/run_tests.ml similarity index 79% rename from src/tests/run_tests.ml rename to unittest/old/run_tests.ml index d3b48e08..0f2f1334 100644 --- a/src/tests/run_tests.ml +++ b/unittest/old/run_tests.ml @@ -1,10 +1,5 @@ let tests : unit Alcotest.test list = - List.flatten - @@ [ - [ Sidekick_test_simplex.tests ]; - [ Sidekick_test_minicc.tests ]; - Sidekick_test_util.tests; - ] + List.flatten @@ [ [ Sidekick_test_simplex.tests ]; Sidekick_test_util.tests ] let props = List.flatten [ Sidekick_test_simplex.props; Sidekick_test_util.props ] From 95dcb0ae742486e9da5256d8bf3717c6811f6f3c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 9 Aug 2022 22:41:13 -0400 Subject: [PATCH 079/174] wip: refactor further --- src/base/Form.mli | 1 + src/base/Sidekick_base.ml | 1 + src/base/Ty.ml | 10 + src/base/Ty.mli | 2 + src/main/pure_sat_solver.ml | 385 +++++++++++++++++---------------- src/smtlib/Process.ml | 6 +- src/smtlib/Sidekick_smtlib.ml | 2 +- src/smtlib/Sidekick_smtlib.mli | 2 +- src/smtlib/Typecheck.ml | 302 +++++++++++++------------- 9 files changed, 374 insertions(+), 337 deletions(-) diff --git a/src/base/Form.mli b/src/base/Form.mli index 4b635b29..d8015407 100644 --- a/src/base/Form.mli +++ b/src/base/Form.mli @@ -35,6 +35,7 @@ val imply : Term.store -> term -> term -> term val equiv : Term.store -> term -> term -> term val xor : Term.store -> term -> term -> term val ite : Term.store -> term -> term -> term -> term +val distinct_l : Term.store -> term list -> term (* *) diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index 4dff3026..a2753e72 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -18,6 +18,7 @@ module Types_ = Types_ module Term = Sidekick_core.Term +module Const = Sidekick_core.Const module Ty = Ty module ID = ID module Form = Form diff --git a/src/base/Ty.ml b/src/base/Ty.ml index aaa431d5..2e2f7cc8 100644 --- a/src/base/Ty.ml +++ b/src/base/Ty.ml @@ -46,6 +46,16 @@ end let int tst : ty = mk_ty0 tst Ty_int let real tst : ty = mk_ty0 tst Ty_real +let is_real t = + match Term.view t with + | E_const { Const.c_view = Ty Ty_real; _ } -> true + | _ -> false + +let is_int t = + match Term.view t with + | E_const { Const.c_view = Ty Ty_int; _ } -> true + | _ -> false + let uninterpreted tst id : t = mk_ty0 tst (Ty_uninterpreted { id; finite = false }) diff --git a/src/base/Ty.mli b/src/base/Ty.mli index dfd9fbf2..1ac9ad8e 100644 --- a/src/base/Ty.mli +++ b/src/base/Ty.mli @@ -14,6 +14,8 @@ val real : store -> t val int : store -> t val uninterpreted : store -> ID.t -> t val is_uninterpreted : t -> bool +val is_real : t -> bool +val is_int : t -> bool (* TODO: separate functor? val finite : t -> bool diff --git a/src/main/pure_sat_solver.ml b/src/main/pure_sat_solver.ml index 88206499..a0f96058 100644 --- a/src/main/pure_sat_solver.ml +++ b/src/main/pure_sat_solver.ml @@ -1,224 +1,235 @@ (* pure SAT solver *) +open Sidekick_core module E = CCResult module SS = Sidekick_sat -module Lit = struct - type t = int +(* FIXME + (* TODO: on the fly compression *) + module Proof : sig + include module type of struct + include Proof_trace + end - let norm_sign t = - if t > 0 then - t, true - else - -t, false + type in_memory - let abs = abs - let sign t = t > 0 - let equal = CCInt.equal - let hash = CCHash.int - let neg x = -x - let pp = Fmt.int -end + val create_in_memory : unit -> t * in_memory + val to_string : in_memory -> string + val to_chan : out_channel -> in_memory -> unit + val create_to_file : string -> t + val close : t -> unit -(* TODO: on the fly compression *) -module Proof : sig - include Sidekick_sigs_proof_trace.S + type event = Sidekick_bin_lib.Drup_parser.event = + | Input of int list + | Add of int list + | Delete of int list - module Rule : - Sidekick_sat.PROOF_RULES - with type lit = Lit.t - and type rule = A.rule - and type step_id = A.step_id + val iter_events : in_memory -> event Iter.t + end = struct + include Proof_trace + module PT = Proof_term - type in_memory + let bpf = Printf.bprintf + let fpf = Printf.fprintf - val dummy : t - val create_in_memory : unit -> t * in_memory - val to_string : in_memory -> string - val to_chan : out_channel -> in_memory -> unit - val create_to_file : string -> t - val close : t -> unit + type lit = Lit.t + type in_memory = Buffer.t - type event = Sidekick_bin_lib.Drup_parser.event = - | Input of int list - | Add of int list - | Delete of int list + let to_string = Buffer.contents - val iter_events : in_memory -> event Iter.t + (* + type t = + | Dummy + | Inner of in_memory + | Out of { oc: out_channel; close: unit -> unit } + *) + + let[@inline] emit_lits_buf_ buf lits = lits (fun i -> bpf buf "%d " i) + let[@inline] emit_lits_out_ oc lits = lits (fun i -> fpf oc "%d " i) + + let create_in_memory () = + let buf = Buffer.create 1_024 in + let pr = + (module struct + let enabled () = true + let add_step s = assert false + + (* TODO: helper to flatten? + let pt : PT.t = s () in + match pt. + *) + + (* TODO *) + let add_unsat _ = () + + (* TODO *) + let delete _ = () + end : DYN) + in + pr, buf + + (* + module Rule = struct + type nonrec lit = lit + type nonrec rule = rule + type nonrec step_id = step_id + + let sat_input_clause lits self = + match self with + | Dummy -> () + | Inner buf -> + bpf buf "i "; + emit_lits_buf_ buf lits; + bpf buf "0\n" + | Out { oc; _ } -> + fpf oc "i "; + emit_lits_out_ oc lits; + fpf oc "0\n" + + let sat_redundant_clause lits ~hyps:_ self = + match self with + | Dummy -> () + | Inner buf -> + bpf buf "r "; + emit_lits_buf_ buf lits; + bpf buf "0\n" + | Out { oc; _ } -> + fpf oc "r "; + emit_lits_out_ oc lits; + fpf oc "0\n" + + let sat_unsat_core _ _ = () + end + + let del_clause () lits self = + match self with + | Dummy -> () + | Inner buf -> + bpf buf "d "; + emit_lits_buf_ buf lits; + bpf buf "0\n" + | Out { oc; _ } -> + fpf oc "d "; + emit_lits_out_ oc lits; + fpf oc "0\n" + + + let create_in_memory () : t * in_memory = + let buf = Buffer.create 1_024 in + Inner buf, buf + + let create_to_file file = + let oc, close = + match Filename.extension file with + | ".gz" -> + let cmd = Printf.sprintf "gzip -c - > \"%s\"" (String.escaped file) in + Log.debugf 1 (fun k -> k "proof file: command is %s" cmd); + let oc = Unix.open_process_out cmd in + oc, fun () -> ignore (Unix.close_process_out oc : Unix.process_status) + | ".drup" -> + let oc = open_out_bin file in + oc, fun () -> close_out_noerr oc + | s -> Error.errorf "unknown file extension '%s'" s + in + Out { oc; close } + + let close = function + | Dummy | Inner _ -> () + | Out { close; oc } -> + flush oc; + close () + + let to_string = Buffer.contents + let to_chan = Buffer.output_buffer + + module DP = Sidekick_bin_lib.Drup_parser + + type event = DP.event = + | Input of int list + | Add of int list + | Delete of int list + + (* parse the proof back *) + let iter_events (self : in_memory) : DP.event Iter.t = + let dp = DP.create_string (to_string self) in + DP.iter dp + + *) + end +*) + +module I_const : sig + val make : Term.store -> int -> Lit.t end = struct - let bpf = Printf.bprintf - let fpf = Printf.fprintf + type Const.view += I of int - type lit = Lit.t - type in_memory = Buffer.t + let ops = + (module struct + let equal a b = + match a, b with + | I a, I b -> a = b + | _ -> false - type t = - | Dummy - | Inner of in_memory - | Out of { oc: out_channel; close: unit -> unit } + let hash = function + | I i -> Hash.int i + | _ -> assert false - module A = struct - type step_id = unit - type rule = t -> unit + let pp out = function + | I i -> Fmt.int out i + | _ -> assert false + end : Const.DYN_OPS) - module Step_vec = Vec_unit - end - - open A - - let[@inline] add_step (self : t) r = r self - let add_unsat _ _ = () - let delete _ _ = () - - let[@inline] enabled (pr : t) = - match pr with - | Dummy -> false - | Inner _ | Out _ -> true - - let[@inline] emit_lits_buf_ buf lits = lits (fun i -> bpf buf "%d " i) - let[@inline] emit_lits_out_ oc lits = lits (fun i -> fpf oc "%d " i) - - module Rule = struct - type nonrec lit = lit - type nonrec rule = rule - type nonrec step_id = step_id - - let sat_input_clause lits self = - match self with - | Dummy -> () - | Inner buf -> - bpf buf "i "; - emit_lits_buf_ buf lits; - bpf buf "0\n" - | Out { oc; _ } -> - fpf oc "i "; - emit_lits_out_ oc lits; - fpf oc "0\n" - - let sat_redundant_clause lits ~hyps:_ self = - match self with - | Dummy -> () - | Inner buf -> - bpf buf "r "; - emit_lits_buf_ buf lits; - bpf buf "0\n" - | Out { oc; _ } -> - fpf oc "r "; - emit_lits_out_ oc lits; - fpf oc "0\n" - - let sat_unsat_core _ _ = () - end - - let del_clause () lits self = - match self with - | Dummy -> () - | Inner buf -> - bpf buf "d "; - emit_lits_buf_ buf lits; - bpf buf "0\n" - | Out { oc; _ } -> - fpf oc "d "; - emit_lits_out_ oc lits; - fpf oc "0\n" - - (* lifetime *) - - let dummy : t = Dummy - - let create_in_memory () : t * in_memory = - let buf = Buffer.create 1_024 in - Inner buf, buf - - let create_to_file file = - let oc, close = - match Filename.extension file with - | ".gz" -> - let cmd = Printf.sprintf "gzip -c - > \"%s\"" (String.escaped file) in - Log.debugf 1 (fun k -> k "proof file: command is %s" cmd); - let oc = Unix.open_process_out cmd in - oc, fun () -> ignore (Unix.close_process_out oc : Unix.process_status) - | ".drup" -> - let oc = open_out_bin file in - oc, fun () -> close_out_noerr oc - | s -> Error.errorf "unknown file extension '%s'" s - in - Out { oc; close } - - let close = function - | Dummy | Inner _ -> () - | Out { close; oc } -> - flush oc; - close () - - let to_string = Buffer.contents - let to_chan = Buffer.output_buffer - - module DP = Sidekick_bin_lib.Drup_parser - - type event = DP.event = - | Input of int list - | Add of int list - | Delete of int list - - (* parse the proof back *) - let iter_events (self : in_memory) : DP.event Iter.t = - let dp = DP.create_string (to_string self) in - DP.iter dp + let make tst i : Lit.t = + let t = Term.const tst @@ Const.make (I (abs i)) ops ~ty:(Term.bool tst) in + Lit.atom ~sign:(i > 0) t end -module Arg = struct - module Lit = Lit - - type lit = Lit.t - - module Proof_trace = Proof - module Proof_rules = Proof.Rule - - type proof = Proof.t - type step_id = Proof.A.step_id -end - -module SAT = Sidekick_sat.Make_pure_sat (Arg) +module SAT = Sidekick_sat module Dimacs = struct open Sidekick_base module BL = Sidekick_bin_lib module T = Term - let parse_file (solver : SAT.t) (file : string) : (unit, string) result = + let parse_file (solver : SAT.t) (tst : Term.store) (file : string) : + (unit, string) result = try CCIO.with_in file (fun ic -> let p = BL.Dimacs_parser.create ic in - BL.Dimacs_parser.iter p (fun c -> SAT.add_input_clause solver c); + BL.Dimacs_parser.iter p (fun c -> + (* convert on the fly *) + let c = List.map (I_const.make tst) c in + SAT.add_input_clause solver c); Ok ()) with e -> E.of_exn_trace e end -let check_proof (proof : Proof.in_memory) : bool = - Profile.with_ "pure-sat.check-proof" @@ fun () -> - let module SDRUP = Sidekick_drup.Make () in - let store = SDRUP.Clause.create () in - let checker = SDRUP.Checker.create store in - let ok = ref true in +(* FIXME + let check_proof (proof : Proof.in_memory) : bool = + Profile.with_ "pure-sat.check-proof" @@ fun () -> + let module SDRUP = Sidekick_drup.Make () in + let store = SDRUP.Clause.create () in + let checker = SDRUP.Checker.create store in + let ok = ref true in - let tr_clause c = - let c = List.rev_map SDRUP.Atom.of_int_dimacs c in - SDRUP.Clause.of_list store c - in + let tr_clause c = + let c = List.rev_map SDRUP.Atom.of_int_dimacs c in + SDRUP.Clause.of_list store c + in - Proof.iter_events proof (function - | Proof.Input c -> - let c = tr_clause c in - SDRUP.Checker.add_clause checker c - | Proof.Add c -> - let c = tr_clause c in - if not (SDRUP.Checker.is_valid_drup checker c) then ok := false; - SDRUP.Checker.add_clause checker c - | Proof.Delete c -> - let c = tr_clause c in - SDRUP.Checker.del_clause checker c); - !ok + Proof.iter_events proof (function + | Proof.Input c -> + let c = tr_clause c in + SDRUP.Checker.add_clause checker c + | Proof.Add c -> + let c = tr_clause c in + if not (SDRUP.Checker.is_valid_drup checker c) then ok := false; + SDRUP.Checker.add_clause checker c + | Proof.Delete c -> + let c = tr_clause c in + SDRUP.Checker.del_clause checker c); + !ok +*) let solve ?(check = false) ?in_memory_proof (solver : SAT.t) : (unit, string) result = @@ -236,7 +247,7 @@ let solve ?(check = false) ?in_memory_proof (solver : SAT.t) : | None -> Error.errorf "Cannot validate proof, no in-memory proof provided" | Some proof -> - let ok = check_proof proof in + let ok = true (* FIXME check_proof proof *) in if not ok then Error.errorf "Proof validation failed" ); diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 8ff0297b..afe6d5a1 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -326,9 +326,9 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model | Statement.Stmt_data _ -> E.return () | Statement.Stmt_define _ -> Error.errorf "cannot deal with definitions yet" -module Th_data = SBS.Th_data -module Th_bool = SBS.Th_bool -module Th_lra = SBS.Th_lra +module Th_data = Th_data +module Th_bool = Th_bool +module Th_lra = Th_lra let th_bool : Solver.theory = Th_bool.theory let th_data : Solver.theory = Th_data.theory diff --git a/src/smtlib/Sidekick_smtlib.ml b/src/smtlib/Sidekick_smtlib.ml index 002dc82a..47b0ee1d 100644 --- a/src/smtlib/Sidekick_smtlib.ml +++ b/src/smtlib/Sidekick_smtlib.ml @@ -6,7 +6,7 @@ module Process = Process module Solver = Process.Solver module Term = Sidekick_base.Term module Stmt = Sidekick_base.Statement -module Proof = Sidekick_base.Proof +module Proof_trace = Sidekick_core.Proof_trace type 'a or_error = ('a, string) CCResult.t diff --git a/src/smtlib/Sidekick_smtlib.mli b/src/smtlib/Sidekick_smtlib.mli index 039e9dc1..6f7e92f4 100644 --- a/src/smtlib/Sidekick_smtlib.mli +++ b/src/smtlib/Sidekick_smtlib.mli @@ -10,7 +10,7 @@ module Term = Sidekick_base.Term module Stmt = Sidekick_base.Statement module Process = Process module Solver = Process.Solver -module Proof = Sidekick_base.Proof +module Proof_trace = Sidekick_core.Proof_trace 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 3b800a79..7322b604 100644 --- a/src/smtlib/Typecheck.ml +++ b/src/smtlib/Typecheck.ml @@ -8,7 +8,7 @@ module PA = Smtlib_utils.V_2_6.Ast module BT = Sidekick_base module Ty = BT.Ty module T = BT.Term -module Fun = BT.Fun +module Uconst = BT.Uconst module Form = BT.Form module Stmt = BT.Statement @@ -21,8 +21,8 @@ let pp_loc_opt = Loc.pp_opt module StrTbl = CCHashtbl.Make (CCString) module Ctx = struct - type kind = K_ty of ty_kind | K_fun of Fun.t - and ty_kind = K_atomic of Ty.def + type kind = K_ty of ty_kind | K_fun of Term.t + and ty_kind = K_atomic of Ty.t type default_num = [ `Real | `Int ] @@ -58,7 +58,7 @@ module Ctx = struct CCFun.finally ~f ~h:(fun () -> List.iter (fun (v, _) -> StrTbl.remove self.lets v) bs) - let find_ty_def self (s : string) : Ty.def = + let find_ty_def self (s : string) : Ty.t = match StrTbl.get self.names s with | Some (_, K_ty (K_atomic def)) -> def | _ -> Error.errorf "expected %s to be an atomic type" s @@ -69,8 +69,8 @@ let errorf_ctx ctx msg = let ill_typed ctx fmt = errorf_ctx ctx ("ill-typed: " ^^ fmt) -let check_bool_ ctx t = - if not (Ty.equal (T.ty t) (Ty.bool ())) then +let check_bool_ (ctx : Ctx.t) t = + if not (Ty.equal (T.ty t) (Ty.bool ctx.tst)) then ill_typed ctx "expected bool, got `@[%a : %a@]`" T.pp t Ty.pp (T.ty t) let find_id_ ctx (s : string) : ID.t * Ctx.kind = @@ -78,15 +78,15 @@ let find_id_ ctx (s : string) : ID.t * Ctx.kind = with Not_found -> errorf_ctx ctx "name `%s` not in scope" s (* parse a type *) -let rec conv_ty ctx (t : PA.ty) : Ty.t = +let rec conv_ty (ctx : Ctx.t) (t : PA.ty) : Ty.t = match t with - | PA.Ty_bool -> Ty.bool () - | PA.Ty_real -> Ty.real () - | PA.Ty_app ("Int", []) -> Ty.int () + | PA.Ty_bool -> Ty.bool ctx.tst + | PA.Ty_real -> Ty.real ctx.tst + | PA.Ty_app ("Int", []) -> Ty.int ctx.tst | PA.Ty_app (f, l) -> - let def = Ctx.find_ty_def ctx f in + let ty_f = Ctx.find_ty_def ctx f in let l = List.map (conv_ty ctx) l in - Ty.atomic def l + Ty.app_l ctx.tst ty_f l | PA.Ty_arrow _ -> ill_typed ctx "cannot handle arrow types" let is_num s = @@ -113,122 +113,127 @@ let string_as_q (s : string) : Q.t option = Some x with _ -> None -let t_as_q t = - match Term.view t with - | T.LRA (Const n) -> Some n - | T.LIA (Const n) -> Some (Q.of_bigint n) - | _ -> None +(* TODO + let t_as_q t = + match Term.view t with + | T.LRA (Const n) -> Some n + | T.LIA (Const n) -> Some (Q.of_bigint n) + | _ -> None -let t_as_z t = - match Term.view t with - | T.LIA (Const n) -> Some n - | _ -> None + let t_as_z t = + match Term.view t with + | T.LIA (Const n) -> Some n + | _ -> None -let[@inline] is_real t = Ty.equal (T.ty t) (Ty.real ()) + let is_real = Ty.is_real -(* convert [t] to a real term *) -let cast_to_real (ctx : Ctx.t) (t : T.t) : T.t = - let rec conv t = - match T.view t with - | T.LRA _ -> t - | _ when Ty.equal (T.ty t) (Ty.real ()) -> t - | T.LIA (Const n) -> T.lra ctx.tst (Const (Q.of_bigint n)) - | T.LIA l -> - (* convert the whole structure to reals *) - let l = LIA_view.to_lra conv l in - T.lra ctx.tst l - | T.Ite (a, b, c) -> T.ite ctx.tst a (conv b) (conv c) - | _ -> errorf_ctx ctx "cannot cast term to real@ :term %a" T.pp t - in - conv t + (* convert [t] to a real term *) + let cast_to_real (ctx : Ctx.t) (t : T.t) : T.t = + let rec conv t = + match T.view t with + | T.LRA _ -> t + | _ when Ty.equal (T.ty t) (Ty.real ()) -> t + | T.LIA (Const n) -> T.lra ctx.tst (Const (Q.of_bigint n)) + | T.LIA l -> + (* convert the whole structure to reals *) + let l = LIA_view.to_lra conv l in + T.lra ctx.tst l + | T.Ite (a, b, c) -> T.ite ctx.tst a (conv b) (conv c) + | _ -> errorf_ctx ctx "cannot cast term to real@ :term %a" T.pp t + in + conv t -let conv_arith_op (ctx : Ctx.t) t (op : PA.arith_op) (l : T.t list) : T.t = - let tst = ctx.Ctx.tst in + let conv_arith_op (ctx : Ctx.t) t (op : PA.arith_op) (l : T.t list) : T.t = + let tst = ctx.Ctx.tst in - let mk_pred p a b = - if is_real a || is_real b then - T.lra tst (Pred (p, cast_to_real ctx a, cast_to_real ctx b)) - else - T.lia tst (Pred (p, a, b)) - and mk_op o a b = - if is_real a || is_real b then - T.lra tst (Op (o, cast_to_real ctx a, cast_to_real ctx b)) - else - T.lia tst (Op (o, a, b)) - in + let mk_pred p a b = + if is_real a || is_real b then + T.lra tst (Pred (p, cast_to_real ctx a, cast_to_real ctx b)) + else + T.lia tst (Pred (p, a, b)) + and mk_op o a b = + if is_real a || is_real b then + T.lra tst (Op (o, cast_to_real ctx a, cast_to_real ctx b)) + else + T.lia tst (Op (o, a, b)) + in - match op, l with - | PA.Leq, [ a; b ] -> mk_pred Leq a b - | PA.Lt, [ a; b ] -> mk_pred Lt a b - | PA.Geq, [ a; b ] -> mk_pred Geq a b - | PA.Gt, [ a; b ] -> mk_pred Gt a b - | PA.Add, [ a; b ] -> mk_op Plus a b - | PA.Add, a :: l -> List.fold_left (fun a b -> mk_op Plus a b) a l - | PA.Minus, [ a ] -> - (match t_as_q a, t_as_z a with - | _, Some n -> T.lia tst (Const (Z.neg n)) - | Some q, None -> T.lra tst (Const (Q.neg q)) - | None, None -> - let zero = - if is_real a then - T.lra tst (Const Q.zero) - else - T.lia tst (Const Z.zero) - in + match op, l with + | PA.Leq, [ a; b ] -> mk_pred Leq a b + | PA.Lt, [ a; b ] -> mk_pred Lt a b + | PA.Geq, [ a; b ] -> mk_pred Geq a b + | PA.Gt, [ a; b ] -> mk_pred Gt a b + | PA.Add, [ a; b ] -> mk_op Plus a b + | PA.Add, a :: l -> List.fold_left (fun a b -> mk_op Plus a b) a l + | PA.Minus, [ a ] -> + (match t_as_q a, t_as_z a with + | _, Some n -> T.lia tst (Const (Z.neg n)) + | Some q, None -> T.lra tst (Const (Q.neg q)) + | None, None -> + let zero = + if is_real a then + T.lra tst (Const Q.zero) + else + T.lia tst (Const Z.zero) + in - mk_op Minus zero a) - | PA.Minus, [ a; b ] -> mk_op Minus a b - | PA.Minus, a :: l -> List.fold_left (fun a b -> mk_op Minus a b) a l - | PA.Mult, [ a; b ] when is_real a || is_real b -> - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.mul a b)) - | Some a, _ -> T.lra tst (Mult (a, b)) - | _, Some b -> T.lra tst (Mult (b, a)) - | None, None -> - errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) - | PA.Mult, [ a; b ] -> - (match t_as_z a, t_as_z b with - | Some a, Some b -> T.lia tst (Const (Z.mul a b)) - | Some a, _ -> T.lia tst (Mult (a, b)) - | _, Some b -> T.lia tst (Mult (b, a)) - | None, None -> - errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) - | PA.Div, [ a; b ] when is_real a || is_real b -> - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.div a b)) - | _, Some b -> T.lra tst (Mult (Q.inv b, a)) - | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) - | PA.Div, [ a; b ] -> - (* becomes a real *) - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.div a b)) - | _, Some b -> - let a = cast_to_real ctx a in - T.lra tst (Mult (Q.inv b, a)) - | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) - | _ -> errorf_ctx ctx "cannot handle arith construct %a" PA.pp_term t + mk_op Minus zero a) + | PA.Minus, [ a; b ] -> mk_op Minus a b + | PA.Minus, a :: l -> List.fold_left (fun a b -> mk_op Minus a b) a l + | PA.Mult, [ a; b ] when is_real a || is_real b -> + (match t_as_q a, t_as_q b with + | Some a, Some b -> T.lra tst (Const (Q.mul a b)) + | Some a, _ -> T.lra tst (Mult (a, b)) + | _, Some b -> T.lra tst (Mult (b, a)) + | None, None -> + errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) + | PA.Mult, [ a; b ] -> + (match t_as_z a, t_as_z b with + | Some a, Some b -> T.lia tst (Const (Z.mul a b)) + | Some a, _ -> T.lia tst (Mult (a, b)) + | _, Some b -> T.lia tst (Mult (b, a)) + | None, None -> + errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) + | PA.Div, [ a; b ] when is_real a || is_real b -> + (match t_as_q a, t_as_q b with + | Some a, Some b -> T.lra tst (Const (Q.div a b)) + | _, Some b -> T.lra tst (Mult (Q.inv b, a)) + | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) + | PA.Div, [ a; b ] -> + (* becomes a real *) + (match t_as_q a, t_as_q b with + | Some a, Some b -> T.lra tst (Const (Q.div a b)) + | _, Some b -> + let a = cast_to_real ctx a in + T.lra tst (Mult (Q.inv b, a)) + | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) + | _ -> errorf_ctx ctx "cannot handle arith construct %a" PA.pp_term t +*) (* conversion of terms *) let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = let tst = ctx.Ctx.tst in match t with | PA.True -> T.true_ tst - | PA.False -> T.false_ tst - | PA.Const s when is_num s -> - (match string_as_z s, ctx.default_num with - | Some n, `Int -> T.lia tst (Const n) - | Some n, `Real -> T.lra tst (Const (Q.of_bigint n)) - | None, _ -> - (match string_as_q s with - | Some n -> T.lra tst (Const n) - | None -> errorf_ctx ctx "expected a number for %a" PA.pp_term t)) + | PA.False -> + T.false_ tst + (* FIXME + | PA.Const s when is_num s -> + (match string_as_z s, ctx.default_num with + | Some n, `Int -> T.lia tst (Const n) + | Some n, `Real -> T.lra tst (Const (Q.of_bigint n)) + | None, _ -> + (match string_as_q s with + | Some n -> T.lra tst (Const n) + | None -> errorf_ctx ctx "expected a number for %a" PA.pp_term t)) + *) | PA.Const f | PA.App (f, []) -> (* lookup in `let` table, then in type defs *) (match StrTbl.find ctx.Ctx.lets f with | u -> u | exception Not_found -> (match find_id_ ctx f with - | _, Ctx.K_fun f -> T.const tst f + | _, Ctx.K_fun f -> f | _, Ctx.K_ty _ -> errorf_ctx ctx "expected term, not type; got `%s`" f)) | PA.App ("xor", [ a; b ]) -> let a = conv_term ctx a in @@ -237,7 +242,7 @@ let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = | PA.App (f, args) -> let args = List.map (conv_term ctx) args in (match find_id_ ctx f with - | _, Ctx.K_fun f -> T.app_fun tst f (CCArray.of_list args) + | _, Ctx.K_fun f -> T.app_l tst f args | _, Ctx.K_ty _ -> errorf_ctx ctx "expected function, got type `%s` instead" f) | PA.If (a, b, c) -> @@ -271,20 +276,26 @@ let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = | PA.Eq (a, b) -> let a = conv_term ctx a in let b = conv_term ctx b in - if is_real a || is_real b then - Form.eq tst (cast_to_real ctx a) (cast_to_real ctx b) - else - Form.eq tst a b + (* FIXME + if is_real a || is_real b then + Form.eq tst (cast_to_real ctx a) (cast_to_real ctx b) + else + *) + Form.eq tst a b | PA.Imply (a, b) -> let a = conv_term ctx a in let b = conv_term ctx b in Form.imply tst a b | PA.Is_a (s, u) -> let u = conv_term ctx u in + let fail () = errorf_ctx ctx "expected `%s` to be a constructor" s in (match find_id_ ctx s with - | _, Ctx.K_fun { Fun.fun_view = Base_types.Fun_cstor c; _ } -> - Term.is_a tst c u - | _ -> errorf_ctx ctx "expected `%s` to be a constructor" s) + | _, Ctx.K_fun f -> + (match Term.view f with + | E_const { Const.c_view = Data_ty.Cstor c; _ } -> + Term.app tst (Data_ty.is_a tst c) u + | _ -> fail ()) + | _ -> fail ()) | PA.Match (_lhs, _l) -> errorf_ctx ctx "TODO: support match in %a" PA.pp_term t (* FIXME: do that properly, using [with_lets] with selectors @@ -360,9 +371,12 @@ let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = in A.match_ lhs cases *) - | PA.Arith (op, l) -> - let l = List.map (conv_term ctx) l in - conv_arith_op ctx t op l + + (* FIXME + | PA.Arith (op, l) -> + let l = List.map (conv_term ctx) l in + conv_arith_op ctx t op l + *) | PA.Cast (t, ty_expect) -> let t = conv_term ctx t in let ty_expect = conv_ty ctx ty_expect in @@ -414,8 +428,8 @@ let rec conv_statement ctx (s : PA.statement) : Stmt.t list = Ctx.set_loc ctx ?loc:(PA.loc s); conv_statement_aux ctx s -and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = - let tst = ctx.Ctx.tst in +and conv_statement_aux (ctx : Ctx.t) (stmt : PA.statement) : Stmt.t list = + let tst = ctx.tst in match PA.view stmt with | PA.Stmt_set_logic logic -> if is_lia logic then @@ -428,12 +442,14 @@ and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = | PA.Stmt_exit -> [ Stmt.Stmt_exit ] | PA.Stmt_decl_sort (s, n) -> let id = ID.make s in - Ctx.add_id_ ctx s id (Ctx.K_ty (Ctx.K_atomic (Ty.Ty_uninterpreted id))); + 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) ] | PA.Stmt_decl fr -> let f, args, ret = conv_fun_decl ctx fr in let id = ID.make f in - Ctx.add_id_ ctx f id (Ctx.K_fun (Fun.mk_undef' id args ret)); + 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) ] | PA.Stmt_data l -> (* first, read and declare each datatype (it can occur in the other @@ -448,7 +464,7 @@ and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = in let l = List.map pre_parse l in *) - let module Cstor = Base_types.Cstor in + let module Cstor = Data_ty.Cstor in let cstors_of_data data (cstors : PA.cstor list) : Cstor.t ID.Map.t = let parse_case { PA.cstor_name; cstor_args; cstor_ty_vars } = if cstor_ty_vars <> [] then @@ -461,30 +477,32 @@ and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = let select_id = ID.make name in let sel = { - Select.select_id; + Data_ty.select_id; select_ty = lazy (conv_ty ctx ty); select_cstor = cstor; select_i = i; } in (* now declare the selector *) - Ctx.add_id_ ctx name select_id (Ctx.K_fun (Fun.select sel)); + let c_sel = Data_ty.select tst sel in + Ctx.add_id_ ctx name select_id (Ctx.K_fun c_sel); sel) cstor_args in let rec cstor = { - Cstor.cstor_id; + Data_ty.cstor_id; cstor_is_a = ID.makef "(is _ %s)" cstor_name; (* every fun needs a name *) cstor_args = lazy (mk_selectors cstor); cstor_arity = 0; cstor_ty_as_data = data; - cstor_ty = data.Base_types.data_as_ty; + cstor_ty = data.data_as_ty; } in (* declare cstor *) - Ctx.add_id_ ctx cstor_name cstor_id (Ctx.K_fun (Fun.cstor cstor)); + let c_cstor = Data_ty.cstor tst cstor in + Ctx.add_id_ ctx cstor_name cstor_id (Ctx.K_fun c_cstor); cstor_id, cstor in let cstors = List.map parse_case cstors in @@ -500,25 +518,22 @@ and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = let data_id = ID.make data_name in let rec data = { - Data.data_id; + Data_ty.data_id; data_cstors = lazy (cstors_of_data data cstors); - data_as_ty = - lazy - (let def = Ty.Ty_data { data } in - Ty.atomic def []); + data_as_ty = lazy (Data_ty.data tst data); } in - Ctx.add_id_ ctx data_name data_id - (Ctx.K_ty (Ctx.K_atomic (Ty.Ty_data { data }))); + let ty_data = Data_ty.data tst data in + Ctx.add_id_ ctx data_name data_id (Ctx.K_ty (Ctx.K_atomic ty_data)); data) l in (* now force definitions *) List.iter - (fun { Data.data_cstors = (lazy m); data_as_ty = (lazy _); _ } -> + (fun { Data_ty.data_cstors = (lazy m); data_as_ty = (lazy _); _ } -> ID.Map.iter - (fun _ ({ Cstor.cstor_args = (lazy l); _ } as r) -> - r.Base_types.cstor_arity <- List.length l) + (fun _ ({ Data_ty.cstor_args = (lazy l); _ } as r) -> + r.cstor_arity <- List.length l) m; ()) l; @@ -541,13 +556,10 @@ and conv_statement_aux ctx (stmt : PA.statement) : Stmt.t list = (* turn [def f : ret := body] into [decl f : ret; assert f=body] *) let ret = conv_ty ctx fun_ret in let id = ID.make fun_name in - let f = Fun.mk_undef_const id ret in + 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 (T.const tst f) rhs); - ] + [ Stmt.Stmt_decl (id, [], ret); 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 -> From b9c0265cb9e1d086a740dfc19c9a96bd9d6850fe Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:07:30 -0400 Subject: [PATCH 080/174] feat(core): add Gensym module, add Proof_trace.close --- src/core/Sidekick_core.ml | 2 ++ src/core/gensym.ml | 48 +++++++++++++++++++++++++++++++++++++++ src/core/gensym.mli | 19 ++++++++++++++++ src/core/proof_term.ml | 4 +++- src/core/proof_term.mli | 2 ++ src/core/proof_trace.ml | 3 +++ src/core/proof_trace.mli | 4 ++++ 7 files changed, 81 insertions(+), 1 deletion(-) create mode 100644 src/core/gensym.ml create mode 100644 src/core/gensym.mli diff --git a/src/core/Sidekick_core.ml b/src/core/Sidekick_core.ml index 892440a6..50d22c6d 100644 --- a/src/core/Sidekick_core.ml +++ b/src/core/Sidekick_core.ml @@ -24,6 +24,8 @@ module Term = struct include T_printer end +module Gensym = Gensym + (** {2 view} *) module Bool_view = Bool_view diff --git a/src/core/gensym.ml b/src/core/gensym.ml new file mode 100644 index 00000000..f4b8abd1 --- /dev/null +++ b/src/core/gensym.ml @@ -0,0 +1,48 @@ +open Sidekick_core_logic + +type term = Term.t +type ty = Term.t + +type Const.view += + | Fresh of { + id: int; (** Id of this constant *) + gensym_id: int; (** Id of the gensym *) + pre: string; (** Printing prefix *) + ty: ty; + } + +let ops = + (module struct + let equal a b = + match a, b with + | Fresh a, Fresh b -> a.id = b.id && a.gensym_id = b.gensym_id + | _ -> false + + let hash = function + | Fresh { id; gensym_id; _ } -> + Hash.combine3 15232 (Hash.int id) (Hash.int gensym_id) + | _ -> assert false + + let pp out = function + | Fresh { id; pre; _ } -> Fmt.fprintf out "$%s[%d]" pre id + | _ -> assert false + end : Const.DYN_OPS) + +type t = { tst: Term.store; self_id: int; mutable fresh: int } + +(* TODO: use atomic *) +let id_ = ref 0 + +let create tst : t = + let self_id = !id_ in + incr id_; + { tst; self_id; fresh = 0 } + +let fresh_term (self : t) ~pre (ty : ty) : Term.t = + let id = self.fresh in + self.fresh <- 1 + self.fresh; + let c = + Term.const self.tst + @@ Const.make (Fresh { id; gensym_id = self.self_id; pre; ty }) ops ~ty + in + c diff --git a/src/core/gensym.mli b/src/core/gensym.mli new file mode 100644 index 00000000..05a42b20 --- /dev/null +++ b/src/core/gensym.mli @@ -0,0 +1,19 @@ +(** Fresh symbol generation *) + +open Sidekick_core_logic + +type term = Term.t +type ty = Term.t + +type t +(** Fresh symbol generator. + + The theory needs to be able to create new terms with fresh names, + to be used as placeholders for complex formulas during Tseitin + encoding. *) + +val create : Term.store -> t +(** New (stateful) generator instance. *) + +val fresh_term : t -> pre:string -> ty -> term +(** Make a fresh term of the given type *) diff --git a/src/core/proof_term.ml b/src/core/proof_term.ml index d4b81516..2859c0ac 100644 --- a/src/core/proof_term.ml +++ b/src/core/proof_term.ml @@ -10,6 +10,7 @@ type rule_apply = { term_args: Term.t list; subst_args: Subst.t list; premises: step_id list; + indices: int list; } type t = @@ -31,7 +32,7 @@ let let_ bs r = | _ -> P_let (bs, r) let apply_rule ?(lits = []) ?(terms = []) ?(substs = []) ?(premises = []) - rule_name : t = + ?(indices = []) rule_name : t = P_apply { rule_name; @@ -39,4 +40,5 @@ let apply_rule ?(lits = []) ?(terms = []) ?(substs = []) ?(premises = []) subst_args = substs; term_args = terms; premises; + indices; } diff --git a/src/core/proof_term.mli b/src/core/proof_term.mli index 351f9cfb..85076798 100644 --- a/src/core/proof_term.mli +++ b/src/core/proof_term.mli @@ -14,6 +14,7 @@ type rule_apply = { term_args: Term.t list; subst_args: Subst.t list; premises: step_id list; + indices: int list; } type t = @@ -35,5 +36,6 @@ val apply_rule : ?terms:Term.t list -> ?substs:Subst.t list -> ?premises:step_id list -> + ?indices:int list -> string -> t diff --git a/src/core/proof_trace.ml b/src/core/proof_trace.ml index 6b12bfce..39c73263 100644 --- a/src/core/proof_trace.ml +++ b/src/core/proof_trace.ml @@ -28,6 +28,7 @@ module type DYN = sig val add_step : Proof_term.delayed -> step_id val add_unsat : step_id -> unit val delete : step_id -> unit + val close : unit -> unit end type t = (module DYN) @@ -36,6 +37,7 @@ let[@inline] enabled ((module Tr) : t) : bool = Tr.enabled () let[@inline] add_step ((module Tr) : t) rule : step_id = Tr.add_step rule let[@inline] add_unsat ((module Tr) : t) s : unit = Tr.add_unsat s let[@inline] delete ((module Tr) : t) s : unit = Tr.delete s +let[@inline] close ((module Tr) : t) : unit = Tr.close () let make (d : (module DYN)) : t = d let dummy_step_id : step_id = -1l @@ -45,4 +47,5 @@ let dummy : t = let add_step _ = dummy_step_id let add_unsat _ = () let delete _ = () + let close _ = () end) diff --git a/src/core/proof_trace.mli b/src/core/proof_trace.mli index 703308ec..67ef05cb 100644 --- a/src/core/proof_trace.mli +++ b/src/core/proof_trace.mli @@ -42,6 +42,9 @@ val delete : t -> step_id -> unit (** Forget a step that won't be used in the rest of the trace. Only useful for performance/memory considerations. *) +val close : t -> unit +(** [close p] closes the proof, and can dispose of underlying resources *) + (** {2 Dummy backend} *) val dummy_step_id : step_id @@ -58,6 +61,7 @@ module type DYN = sig val add_step : Proof_term.delayed -> step_id val add_unsat : step_id -> unit val delete : step_id -> unit + val close : unit -> unit end val make : (module DYN) -> t From 647d66a196f0b99eee35950d0d36b6fb9bfc064a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:07:54 -0400 Subject: [PATCH 081/174] feat(th-data): use lists, not iter/array; add Proof_rules --- src/th-data/Sidekick_th_data.ml | 96 +++++++++++++++++---------------- src/th-data/proof_rules.ml | 27 ++++++++++ src/th-data/proof_rules.mli | 33 ++++++++++++ src/th-data/th_intf.ml | 51 +++--------------- 4 files changed, 116 insertions(+), 91 deletions(-) create mode 100644 src/th-data/proof_rules.ml create mode 100644 src/th-data/proof_rules.mli diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 956bec1b..3bf30e6c 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -27,8 +27,8 @@ module C = struct | Finite, Finite -> Finite | _ -> Infinite - let sum = Iter.fold ( + ) Finite - let product = Iter.fold ( * ) Finite + let sum = List.fold_left ( + ) Finite + let product = List.fold_left ( * ) Finite let to_string = function | Finite -> "finite" @@ -65,18 +65,19 @@ end = struct (* cut infinite loop *) let res = match A.as_datatype ty with - | Ty_other -> false + | Ty_other { sub = [] } -> false + | Ty_other { sub } -> List.exists is_direct_recursion sub | Ty_arrow (_, ret) -> is_direct_recursion ret - | Ty_app { args } -> Iter.exists is_direct_recursion args | Ty_data { cstors } -> - Iter.flat_map A.Cstor.ty_args cstors - |> Iter.exists is_direct_recursion + List.exists + (fun c -> List.exists is_direct_recursion @@ A.Cstor.ty_args c) + cstors in Ty_tbl.replace dr_tbl ty res; res in let is_direct_recursion_cstor (c : A.Cstor.t) : bool = - Iter.exists is_direct_recursion (A.Cstor.ty_args c) + List.exists is_direct_recursion (A.Cstor.ty_args c) in let rec get_cell (ty : ty) : ty_cell = @@ -88,20 +89,20 @@ end = struct Ty_tbl.add self.cards ty cell; let card = match A.as_datatype ty with - | Ty_other -> + | Ty_other { sub = [] } -> if A.ty_is_finite ty then C.Finite else C.Infinite - | Ty_app { args } -> Iter.map get_card args |> C.product + | Ty_other { sub } -> List.map get_card sub |> C.product | Ty_arrow (args, ret) -> - C.(get_card ret ^ C.product @@ Iter.map get_card args) + C.(get_card ret ^ C.product @@ List.map get_card args) | Ty_data { cstors } -> let c = cstors - |> Iter.map (fun c -> + |> List.map (fun c -> let card = - C.product (Iter.map get_card @@ A.Cstor.ty_args c) + C.product (List.map get_card @@ A.Cstor.ty_args c) in (* we can use [c] as base constructor if it's finite, or at least if it doesn't directly depend on [ty] in @@ -150,17 +151,17 @@ end = struct let name = "th-data.cstor" (* associate to each class a unique constructor term in the class (if any) *) - type t = { c_n: E_node.t; c_cstor: A.Cstor.t; c_args: E_node.t array } + type t = { c_n: E_node.t; c_cstor: A.Cstor.t; c_args: E_node.t list } let pp out (v : t) = Fmt.fprintf out "(@[%s@ :cstor %a@ :n %a@ :args [@[%a@]]@])" name - A.Cstor.pp v.c_cstor E_node.pp v.c_n (Util.pp_array E_node.pp) v.c_args + A.Cstor.pp v.c_cstor E_node.pp v.c_n (Util.pp_list E_node.pp) v.c_args (* attach data to constructor terms *) let of_term cc n (t : Term.t) : _ option * _ list = match A.view_as_data t with | T_cstor (cstor, args) -> - let args = CCArray.map (CC.add_term cc) args in + let args = List.map (CC.add_term cc) args in Some { c_n = n; c_cstor = cstor; c_args = args }, [] | _ -> None, [] @@ -186,20 +187,22 @@ end = struct let t1 = E_node.term c1.c_n in let t2 = E_node.term c2.c_n in mk_expl t1 t2 @@ Proof_trace.add_step proof - @@ fun () -> A.P.lemma_cstor_inj t1 t2 i + @@ fun () -> Proof_rules.lemma_cstor_inj t1 t2 i in - assert (CCArray.length c1.c_args = CCArray.length c2.c_args); + assert (List.length c1.c_args = List.length c2.c_args); let acts = ref [] in - Util.array_iteri2 c1.c_args c2.c_args ~f:(fun i u1 u2 -> - acts := CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts); + CCList.iteri2 + (fun i u1 u2 -> + acts := CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts) + c1.c_args c2.c_args; Ok (c1, !acts) ) else ( (* different function: disjointness *) let expl = let t1 = E_node.term c1.c_n and t2 = E_node.term c2.c_n in mk_expl t1 t2 @@ Proof_trace.add_step proof - @@ fun () -> A.P.lemma_cstor_distinct t1 t2 + @@ fun () -> Proof_rules.lemma_cstor_distinct t1 t2 in Error (CC.Handler_action.Conflict expl) @@ -310,7 +313,7 @@ end = struct match A.view_as_data t, A.as_datatype ty with | T_cstor _, _ -> () | _, Ty_data { cstors; _ } -> - (match Iter.take 2 cstors |> Iter.to_rev_list with + (match cstors with | [ cstor ] when not (Term.Tbl.mem self.single_cstor_preproc_done t) -> (* single cstor: assert [t = cstor (sel-c-0 t, …, sel-c n t)] *) Log.debugf 50 (fun k -> @@ -322,8 +325,7 @@ end = struct let u = let sel_args = A.Cstor.ty_args cstor - |> Iter.mapi (fun i _ty -> A.mk_sel self.tst cstor i t) - |> Iter.to_array + |> List.mapi (fun i _ty -> A.mk_sel self.tst cstor i t) in A.mk_cstor self.tst cstor sel_args in @@ -333,10 +335,11 @@ end = struct let proof = let pr_isa = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_isa_split t [ Lit.atom (A.mk_is_a self.tst cstor t) ] + Proof_rules.lemma_isa_split t + [ Lit.atom (A.mk_is_a self.tst cstor t) ] and pr_eq_sel = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_select_cstor ~cstor_t:u t + Proof_rules.lemma_select_cstor ~cstor_t:u t in Proof_trace.add_step self.proof @@ fun () -> Proof_core.proof_r1 pr_isa pr_eq_sel @@ -394,7 +397,7 @@ end = struct name Term.pp_debug t is_true E_node.pp n Monoid_cstor.pp cstor); let pr = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_isa_cstor ~cstor_t:(E_node.term cstor.c_n) t + Proof_rules.lemma_isa_cstor ~cstor_t:(E_node.term cstor.c_n) t in let n_bool = CC.n_bool cc is_true in let expl = @@ -417,11 +420,11 @@ end = struct Log.debugf 5 (fun k -> k "(@[%s.on-new-term.select.reduce@ :n %a@ :sel get[%d]-%a@])" name E_node.pp n i A.Cstor.pp c_t); - assert (i < CCArray.length cstor.c_args); - let u_i = CCArray.get cstor.c_args i in + assert (i < List.length cstor.c_args); + let u_i = List.nth cstor.c_args i in let pr = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_select_cstor ~cstor_t:(E_node.term cstor.c_n) t + Proof_rules.lemma_select_cstor ~cstor_t:(E_node.term cstor.c_n) t in let expl = Expl.( @@ -441,7 +444,7 @@ end = struct []) | T_cstor _ | T_other _ -> [] - let cstors_of_ty (ty : ty) : A.Cstor.t Iter.t = + let cstors_of_ty (ty : ty) : A.Cstor.t list = match A.as_datatype ty with | Ty_data { cstors } -> cstors | _ -> assert false @@ -458,7 +461,7 @@ end = struct Monoid_cstor.pp c1); let pr = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_isa_cstor ~cstor_t:(E_node.term c1.c_n) + Proof_rules.lemma_isa_cstor ~cstor_t:(E_node.term c1.c_n) (E_node.term is_a2.is_a_n) in let n_bool = CC.n_bool cc is_true in @@ -484,13 +487,13 @@ end = struct Log.debugf 5 (fun k -> k "(@[%s.on-merge.select.reduce@ :n2 %a@ :sel get[%d]-%a@])" name E_node.pp n2 sel2.sel_idx Monoid_cstor.pp c1); - assert (sel2.sel_idx < CCArray.length c1.c_args); + assert (sel2.sel_idx < List.length c1.c_args); let pr = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_select_cstor ~cstor_t:(E_node.term c1.c_n) + Proof_rules.lemma_select_cstor ~cstor_t:(E_node.term c1.c_n) (E_node.term sel2.sel_n) in - let u_i = CCArray.get c1.c_args sel2.sel_idx in + let u_i = List.nth c1.c_args sel2.sel_idx in let expl = Expl.mk_theory (E_node.term sel2.sel_n) (E_node.term u_i) [ @@ -563,7 +566,7 @@ end = struct let mk_graph (self : t) cc : graph = let g : graph = N_tbl.create ~size:32 () in let traverse_sub cstor : _ list = - Util.array_to_list_map + List.map (fun sub_n -> sub_n, CC.find cc sub_n) cstor.Monoid_cstor.c_args in @@ -603,7 +606,7 @@ end = struct (fun (a, b) -> E_node.term a, E_node.term b.repr) path in - A.P.lemma_acyclicity path + Proof_rules.lemma_acyclicity path in let expl = let subs = @@ -648,8 +651,7 @@ end = struct let rhs = let args = A.Cstor.ty_args c - |> Iter.mapi (fun i _ty -> A.mk_sel self.tst c i u) - |> Iter.to_list |> CCArray.of_list + |> List.mapi (fun i _ty -> A.mk_sel self.tst c i u) in A.mk_cstor self.tst c args in @@ -657,7 +659,8 @@ end = struct k "(@[%s.assign-is-a@ :lhs %a@ :rhs %a@ :lit %a@])" name Term.pp_debug u Term.pp_debug rhs Lit.pp lit); let pr = - Proof_trace.add_step self.proof @@ fun () -> A.P.lemma_isa_sel t + Proof_trace.add_step self.proof @@ fun () -> + Proof_rules.lemma_isa_sel t in (* merge [u] and [rhs] *) CC.merge_t (SI.cc solver) u rhs @@ -676,19 +679,19 @@ end = struct Term.Tbl.add self.case_split_done t (); let c = cstors_of_ty (Term.ty t) - |> Iter.map (fun c -> A.mk_is_a self.tst c t) - |> Iter.map (fun t -> + |> List.map (fun c -> + let t = A.mk_is_a self.tst c t in let lit = SI.mk_lit solver t in (* TODO: set default polarity, depending on n° of args? *) lit) - |> Iter.to_rev_list in SI.add_clause_permanent solver acts c - (Proof_trace.add_step self.proof @@ fun () -> A.P.lemma_isa_split t c); + ( Proof_trace.add_step self.proof @@ fun () -> + Proof_rules.lemma_isa_split t c ); Iter.diagonal_l c (fun (l1, l2) -> let pr = Proof_trace.add_step self.proof @@ fun () -> - A.P.lemma_isa_disj (Lit.neg l1) (Lit.neg l2) + Proof_rules.lemma_isa_disj (Lit.neg l1) (Lit.neg l2) in SI.add_clause_permanent solver acts [ Lit.neg l1; Lit.neg l2 ] pr) ) @@ -752,8 +755,7 @@ end = struct let cstor_app = let args = A.Cstor.ty_args base_cstor - |> Iter.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) - |> Iter.to_array + |> List.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) in A.mk_cstor self.tst base_cstor args in @@ -776,7 +778,7 @@ end = struct | Some c -> Log.debugf 5 (fun k -> k "(@[th-data.mk-model.find-cstor@ %a@])" Monoid_cstor.pp c); - let args = CCArray.map (recurse si) c.c_args in + let args = List.map (recurse si) c.c_args in let t = A.mk_cstor self.tst c.c_cstor args in Some t diff --git a/src/th-data/proof_rules.ml b/src/th-data/proof_rules.ml new file mode 100644 index 00000000..5e65ef3c --- /dev/null +++ b/src/th-data/proof_rules.ml @@ -0,0 +1,27 @@ +open Sidekick_core + +let lemma_isa_cstor ~cstor_t t : Proof_term.t = + Proof_term.apply_rule ~terms:[ cstor_t; t ] "data.isa-cstor" + +let lemma_select_cstor ~cstor_t t : Proof_term.t = + Proof_term.apply_rule ~terms:[ cstor_t; t ] "data.select-cstor" + +let lemma_isa_split t lits : Proof_term.t = + Proof_term.apply_rule ~terms:[ t ] ~lits "data.isa-split" + +let lemma_isa_sel t : Proof_term.t = + Proof_term.apply_rule ~terms:[ t ] "data.isa-sel" + +let lemma_isa_disj l1 l2 : Proof_term.t = + Proof_term.apply_rule ~lits:[ l1; l2 ] "data.isa-disj" + +let lemma_cstor_inj t1 t2 i : Proof_term.t = + Proof_term.apply_rule ~terms:[ t1; t2 ] ~indices:[ i ] "data.cstor-inj" + +let lemma_cstor_distinct t1 t2 : Proof_term.t = + Proof_term.apply_rule ~terms:[ t1; t2 ] "data.cstor-distinct" + +let lemma_acyclicity ts : Proof_term.t = + Proof_term.apply_rule + ~terms:(CCList.flat_map (fun (t1, t2) -> [ t1; t2 ]) ts) + "data.acyclicity" diff --git a/src/th-data/proof_rules.mli b/src/th-data/proof_rules.mli new file mode 100644 index 00000000..a2010781 --- /dev/null +++ b/src/th-data/proof_rules.mli @@ -0,0 +1,33 @@ +open Sidekick_core + +val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t +(** [lemma_isa_cstor (d …) (is-c t)] returns the clause + [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) + +val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t +(** [lemma_select_cstor (c t1…tn) (sel-c-i t)] + returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) + +val lemma_isa_split : Term.t -> Lit.t list -> Proof_term.t +(** [lemma_isa_split t lits] is the proof of + [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) + +val lemma_isa_sel : Term.t -> Proof_term.t +(** [lemma_isa_sel (is-c t)] is the proof of + [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) + +val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.t +(** [lemma_isa_disj (is-c t) (is-d t)] is the proof + of [¬ (is-c t) \/ ¬ (is-c t)] *) + +val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.t +(** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of + [c t1…tn = c u1…un |- ti = ui] *) + +val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.t +(** [lemma_isa_distinct (c …) (d …)] is the proof + of the unit clause [|- (c …) ≠ (d …)] *) + +val lemma_acyclicity : (Term.t * Term.t) list -> Proof_term.t +(** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] + by acyclicity. *) diff --git a/src/th-data/th_intf.ml b/src/th-data/th_intf.ml index e26304da..88369491 100644 --- a/src/th-data/th_intf.ml +++ b/src/th-data/th_intf.ml @@ -9,51 +9,16 @@ type ty = Term.t - ['t] is the representation of terms *) type ('c, 't) data_view = - | T_cstor of 'c * 't array + | T_cstor of 'c * 't list | T_select of 'c * int * 't | T_is_a of 'c * 't | T_other of 't (** View of types in a way that is directly useful for the theory of datatypes *) type ('c, 'ty) data_ty_view = - | Ty_arrow of 'ty Iter.t * 'ty - | Ty_app of { args: 'ty Iter.t } + | Ty_arrow of 'ty list * 'ty | Ty_data of { cstors: 'c } - | Ty_other - -module type PROOF_RULES = sig - val lemma_isa_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t - (** [lemma_isa_cstor (d …) (is-c t)] returns the clause - [(c …) = t |- is-c t] or [(d …) = t |- ¬ (is-c t)] *) - - val lemma_select_cstor : cstor_t:Term.t -> Term.t -> Proof_term.t - (** [lemma_select_cstor (c t1…tn) (sel-c-i t)] - returns a proof of [t = c t1…tn |- (sel-c-i t) = ti] *) - - val lemma_isa_split : Term.t -> Lit.t list -> Proof_term.t - (** [lemma_isa_split t lits] is the proof of - [is-c1 t \/ is-c2 t \/ … \/ is-c_n t] *) - - val lemma_isa_sel : Term.t -> Proof_term.t - (** [lemma_isa_sel (is-c t)] is the proof of - [is-c t |- t = c (sel-c-1 t)…(sel-c-n t)] *) - - val lemma_isa_disj : Lit.t -> Lit.t -> Proof_term.t - (** [lemma_isa_disj (is-c t) (is-d t)] is the proof - of [¬ (is-c t) \/ ¬ (is-c t)] *) - - val lemma_cstor_inj : Term.t -> Term.t -> int -> Proof_term.t - (** [lemma_cstor_inj (c t1…tn) (c u1…un) i] is the proof of - [c t1…tn = c u1…un |- ti = ui] *) - - val lemma_cstor_distinct : Term.t -> Term.t -> Proof_term.t - (** [lemma_isa_distinct (c …) (d …)] is the proof - of the unit clause [|- (c …) ≠ (d …)] *) - - val lemma_acyclicity : (Term.t * Term.t) list -> Proof_term.t - (** [lemma_acyclicity pairs] is a proof of [t1=u1, …, tn=un |- false] - by acyclicity. *) -end + | Ty_other of { sub: 'ty list } (* TODO: remove? or make compute_card use that? *) @@ -66,7 +31,7 @@ module type DATA_TY = sig val finite : t -> bool val set_finite : t -> bool -> unit val view : t -> (cstor, t) data_ty_view - val cstor_args : cstor -> t Iter.t + val cstor_args : cstor -> t list end module type ARG = sig @@ -79,20 +44,20 @@ module type ARG = sig type t (** Constructor *) - val ty_args : t -> ty Iter.t + val ty_args : t -> ty list (** Type arguments, for a polymorphic constructor *) include Sidekick_sigs.EQ with type t := t include Sidekick_sigs.PRINT with type t := t end - val as_datatype : ty -> (Cstor.t Iter.t, ty) data_ty_view + val as_datatype : ty -> (Cstor.t list, ty) data_ty_view (** Try to view type as a datatype (with its constructors) *) val view_as_data : Term.t -> (Cstor.t, Term.t) data_view (** Try to view Term.t as a datatype Term.t *) - val mk_cstor : Term.store -> Cstor.t -> Term.t array -> Term.t + val mk_cstor : Term.store -> Cstor.t -> Term.t list -> Term.t (** Make a constructor application Term.t *) val mk_is_a : Term.store -> Cstor.t -> Term.t -> Term.t @@ -110,6 +75,4 @@ module type ARG = sig val ty_set_is_finite : ty -> bool -> unit (** Modify the "finite" field (see {!ty_is_finite}) *) - - module P : PROOF_RULES end From 81f159d25d8b402684413a751d4f6e0e19e543c7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:08:09 -0400 Subject: [PATCH 082/174] feat(th-bool): add proof_rules, use std gensym --- src/th-bool-static/Sidekick_th_bool_static.ml | 66 +++++++++---------- .../Sidekick_th_bool_static.mli | 1 + src/th-bool-static/intf.ml | 39 +---------- src/th-bool-static/proof_rules.ml | 19 ++++++ src/th-bool-static/proof_rules.mli | 20 ++++++ 5 files changed, 74 insertions(+), 71 deletions(-) create mode 100644 src/th-bool-static/proof_rules.ml create mode 100644 src/th-bool-static/proof_rules.mli diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index dde8ae39..bb982b86 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -2,6 +2,7 @@ open Sidekick_core module Intf = Intf open Intf module SI = SMT.Solver_internal +module Proof_rules = Proof_rules module T = Term module type ARG = Intf.ARG @@ -9,9 +10,9 @@ module type ARG = Intf.ARG module Make (A : ARG) : sig val theory : SMT.theory end = struct - type state = { tst: T.store; gensym: A.Gensym.t } + type state = { tst: T.store; gensym: Gensym.t } - let create tst : state = { tst; gensym = A.Gensym.create tst } + let create tst : state = { tst; gensym = Gensym.create tst } let[@inline] not_ tst t = A.mk_bool tst (B_not t) let[@inline] eq tst a b = A.mk_bool tst (B_eq (a, b)) @@ -44,7 +45,7 @@ end = struct let[@inline] ret u = Some (u, Iter.of_list !steps) in (* proof is [t <=> u] *) let ret_bequiv t1 u = - (add_step_ @@ mk_step_ @@ fun () -> A.P.lemma_bool_equiv t1 u); + (add_step_ @@ mk_step_ @@ fun () -> Proof_rules.lemma_bool_equiv t1 u); ret u in @@ -55,21 +56,21 @@ end = struct | B_not _ -> None | B_atom _ -> None | B_and a -> - if Iter.exists is_false a then + if List.exists is_false a then ret (T.false_ tst) - else if Iter.for_all is_true a then + else if List.for_all is_true a then ret (T.true_ tst) else None | B_or a -> - if Iter.exists is_true a then + if List.exists is_true a then ret (T.true_ tst) - else if Iter.for_all is_false a then + else if List.for_all is_false a then ret (T.false_ tst) else None | B_imply (args, u) -> - if Iter.exists is_false args then + if List.exists is_false args then ret (T.true_ tst) else if is_true u then ret (T.true_ tst) @@ -83,11 +84,11 @@ end = struct (match A.view_as_bool a with | B_bool true -> add_step_eq t b ~using:(Option.to_list prf_a) - ~c0:(mk_step_ @@ fun () -> A.P.lemma_ite_true ~ite:t); + ~c0:(mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); ret b | B_bool false -> add_step_eq t c ~using:(Option.to_list prf_a) - ~c0:(mk_step_ @@ fun () -> A.P.lemma_ite_false ~ite:t); + ~c0:(mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t); ret c | _ -> None) | B_equiv (a, b) when is_true a -> ret_bequiv t b @@ -104,7 +105,7 @@ end = struct | B_eq _ | B_neq _ -> None let fresh_term self ~for_t ~pre ty = - let u = A.Gensym.fresh_term self.gensym ~pre ty in + let u = Gensym.fresh_term self.gensym ~pre ty in Log.debugf 20 (fun k -> k "(@[sidekick.bool.proxy@ :t %a@ :for %a@])" T.pp_debug u T.pp_debug for_t); @@ -139,26 +140,26 @@ end = struct PA.add_clause [ Lit.neg lit; Lit.neg a; b ] (if is_xor then - mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-e+" [ t ] + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e+" [ t ] else - mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-e" [ t; t_a ]); + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-e" [ t; t_a ]); PA.add_clause [ Lit.neg lit; Lit.neg b; a ] (if is_xor then - mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-e-" [ t ] + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e-" [ t ] else - mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-e" [ t; t_b ]); + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-e" [ t; t_b ]); PA.add_clause [ lit; a; b ] (if is_xor then - mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-i" [ t; t_a ] + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-i" [ t; t_a ] else - mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-i+" [ t ]); + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i+" [ t ]); PA.add_clause [ lit; Lit.neg a; Lit.neg b ] (if is_xor then - mk_step_ @@ fun () -> A.P.lemma_bool_c "xor-i" [ t; t_b ] + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-i" [ t; t_b ] else - mk_step_ @@ fun () -> A.P.lemma_bool_c "eq-i-" [ t ]) + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i-" [ t ]) in (* make a literal for [t], with a proof of [|- abs(t) = abs(lit)] *) @@ -166,23 +167,21 @@ end = struct | B_bool _ -> () | B_not _ -> () | B_and l -> - let t_subs = Iter.to_list l in let lit = PA.mk_lit t in - let subs = List.map PA.mk_lit t_subs in + let subs = List.map PA.mk_lit l in (* add clauses *) List.iter2 (fun t_u u -> PA.add_clause [ Lit.neg lit; u ] - (mk_step_ @@ fun () -> A.P.lemma_bool_c "and-e" [ t; t_u ])) - t_subs subs; + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-e" [ t; t_u ])) + l subs; PA.add_clause (lit :: List.map Lit.neg subs) - (mk_step_ @@ fun () -> A.P.lemma_bool_c "and-i" [ t ]) + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) | B_or l -> - let t_subs = Iter.to_list l in - let subs = List.map PA.mk_lit t_subs in + let subs = List.map PA.mk_lit l in let lit = PA.mk_lit t in (* add clauses *) @@ -190,13 +189,12 @@ end = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (mk_step_ @@ fun () -> A.P.lemma_bool_c "or-i" [ t; t_u ])) - t_subs subs; + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-i" [ t; t_u ])) + l subs; PA.add_clause (Lit.neg lit :: subs) - (mk_step_ @@ fun () -> A.P.lemma_bool_c "or-e" [ t ]) + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) | B_imply (t_args, t_u) -> (* transform into [¬args \/ u] on the fly *) - let t_args = Iter.to_list t_args in let args = List.map (fun t -> Lit.neg (PA.mk_lit t)) t_args in let u = PA.mk_lit t_u in let subs = u :: args in @@ -209,18 +207,18 @@ end = struct (fun t_u u -> PA.add_clause [ Lit.neg u; lit ] - (mk_step_ @@ fun () -> A.P.lemma_bool_c "imp-i" [ t; t_u ])) + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-i" [ t; t_u ])) (t_u :: t_args) subs; PA.add_clause (Lit.neg lit :: subs) - (mk_step_ @@ fun () -> A.P.lemma_bool_c "imp-e" [ t ]) + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-e" [ t ]) | B_ite (a, b, c) -> let lit_a = PA.mk_lit a in PA.add_clause [ Lit.neg lit_a; PA.mk_lit (eq self.tst t b) ] - (mk_step_ @@ fun () -> A.P.lemma_ite_true ~ite:t); + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); PA.add_clause [ lit_a; PA.mk_lit (eq self.tst t c) ] - (mk_step_ @@ fun () -> A.P.lemma_ite_false ~ite:t) + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) | B_eq _ | B_neq _ -> () | B_equiv (a, b) -> equiv_ si ~t ~is_xor:false a b | B_xor (a, b) -> equiv_ si ~t ~is_xor:true a b diff --git a/src/th-bool-static/Sidekick_th_bool_static.mli b/src/th-bool-static/Sidekick_th_bool_static.mli index b83dc6c6..98699c86 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.mli +++ b/src/th-bool-static/Sidekick_th_bool_static.mli @@ -4,6 +4,7 @@ *) module Intf = Intf +module Proof_rules = Proof_rules open Intf module type ARG = Intf.ARG diff --git a/src/th-bool-static/intf.ml b/src/th-bool-static/intf.ml index a348d9df..952b1023 100644 --- a/src/th-bool-static/intf.ml +++ b/src/th-bool-static/intf.ml @@ -19,46 +19,11 @@ type ('a, 'args) bool_view = ('a, 'args) Bool_view.t = | B_ite of 'a * 'a * 'a | B_atom of 'a -module type PROOF_RULES = sig - val lemma_bool_tauto : Lit.t Iter.t -> Proof_term.t - (** Boolean tautology lemma (clause) *) - - val lemma_bool_c : string -> term list -> Proof_term.t - (** Basic boolean logic lemma for a clause [|- c]. - [proof_bool_c b name cs] is the Proof_term.t designated by [name]. *) - - val lemma_bool_equiv : term -> term -> Proof_term.t - (** Boolean tautology lemma (equivalence) *) - - val lemma_ite_true : ite:term -> Proof_term.t - (** lemma [a ==> ite a b c = b] *) - - val lemma_ite_false : ite:term -> Proof_term.t - (** lemma [¬a ==> ite a b c = c] *) -end - (** Argument to the theory *) module type ARG = sig - val view_as_bool : term -> (term, term Iter.t) bool_view + val view_as_bool : term -> (term, term list) bool_view (** Project the term into the boolean view. *) - val mk_bool : Term.store -> (term, term array) bool_view -> term + val mk_bool : Term.store -> (term, term list) bool_view -> term (** Make a term from the given boolean view. *) - - module P : PROOF_RULES - - (** Fresh symbol generator. - - The theory needs to be able to create new terms with fresh names, - to be used as placeholders for complex formulas during Tseitin - encoding. *) - module Gensym : sig - type t - - val create : Term.store -> t - (** New (stateful) generator instance. *) - - val fresh_term : t -> pre:string -> ty -> term - (** Make a fresh term of the given type *) - end end diff --git a/src/th-bool-static/proof_rules.ml b/src/th-bool-static/proof_rules.ml new file mode 100644 index 00000000..82288385 --- /dev/null +++ b/src/th-bool-static/proof_rules.ml @@ -0,0 +1,19 @@ +open Sidekick_core + +type term = Term.t +type lit = Lit.t + +let lemma_bool_tauto lits : Proof_term.t = + Proof_term.apply_rule "bool.tauto" ~lits + +let lemma_bool_c name terms : Proof_term.t = + Proof_term.apply_rule ("bool.c." ^ name) ~terms + +let lemma_bool_equiv t u : Proof_term.t = + Proof_term.apply_rule "bool.equiv" ~terms:[ t; u ] + +let lemma_ite_true ~ite : Proof_term.t = + Proof_term.apply_rule "bool.ite.true" ~terms:[ ite ] + +let lemma_ite_false ~ite : Proof_term.t = + Proof_term.apply_rule "bool.ite.false" ~terms:[ ite ] diff --git a/src/th-bool-static/proof_rules.mli b/src/th-bool-static/proof_rules.mli new file mode 100644 index 00000000..0379b4c5 --- /dev/null +++ b/src/th-bool-static/proof_rules.mli @@ -0,0 +1,20 @@ +open Sidekick_core + +type term = Term.t +type lit = Lit.t + +val lemma_bool_tauto : lit list -> Proof_term.t +(** Boolean tautology lemma (clause) *) + +val lemma_bool_c : string -> term list -> Proof_term.t +(** Basic boolean logic lemma for a clause [|- c]. + [proof_bool_c b name cs] is the Proof_term.t designated by [name]. *) + +val lemma_bool_equiv : term -> term -> Proof_term.t +(** Boolean tautology lemma (equivalence) *) + +val lemma_ite_true : ite:term -> Proof_term.t +(** lemma [a ==> ite a b c = b] *) + +val lemma_ite_false : ite:term -> Proof_term.t +(** lemma [¬a ==> ite a b c = c] *) From 8777682e0753590cdc520ffcfaba5c5c33547e57 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:08:33 -0400 Subject: [PATCH 083/174] detail in core_logic --- src/core-logic/term.ml | 4 ++-- src/core-logic/term.mli | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 2c0330eb..cf9f06f6 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -157,10 +157,10 @@ module Store = struct (* TODO: use atomic? CCAtomic? *) let n = ref 0 - let create () : t = + let create ?(size = 256) () : t = let s_uid = !n in incr n; - { s_uid; s_exprs = Hcons.create ~size:256 () } + { s_uid; s_exprs = Hcons.create ~size () } (* check that [e] belongs in this store *) let[@inline] check_e_uid (self : t) (e : term) = diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index dfb2a65f..66e3e93b 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -99,7 +99,7 @@ val ty : t -> t module Store : sig type t = store - val create : unit -> t + val create : ?size:int -> unit -> t end val type_ : store -> t From 1f79ee05f2bb7056cfd4ac4fcabf31f700cc6fcf Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:08:43 -0400 Subject: [PATCH 084/174] wip: make Base really usable, add th-data/th-bool --- src/base/Data_ty.ml | 28 +++++++++++++- src/base/Data_ty.mli | 8 ++++ src/base/Sidekick_base.ml | 14 ++++++- src/base/Solver.ml | 10 +++++ src/base/Term.ml | 3 ++ src/base/th_bool.ml | 8 ++++ src/base/th_data.ml | 77 +++++++++++++++++++++++++++++++++++++++ src/base/th_lra.ml | 48 ++++++++++++++++++++++++ 8 files changed, 194 insertions(+), 2 deletions(-) create mode 100644 src/base/Solver.ml create mode 100644 src/base/Term.ml create mode 100644 src/base/th_bool.ml create mode 100644 src/base/th_data.ml create mode 100644 src/base/th_lra.ml diff --git a/src/base/Data_ty.ml b/src/base/Data_ty.ml index 1503fe78..75c02dbf 100644 --- a/src/base/Data_ty.ml +++ b/src/base/Data_ty.ml @@ -64,7 +64,13 @@ module Cstor = struct let id c = c.cstor_id let hash c = ID.hash c.cstor_id - let ty_args c = Lazy.force c.cstor_args |> Iter.of_list |> Iter.map Select.ty + let ty_args c = Lazy.force c.cstor_args |> List.map Select.ty + + let select_idx c i = + let (lazy sels) = c.cstor_args in + if i >= List.length sels then invalid_arg "cstor.select_idx: out of bound"; + List.nth sels i + let equal a b = ID.equal a.cstor_id b.cstor_id let pp out c = ID.pp out c.cstor_id end @@ -111,3 +117,23 @@ let select tst s : Term.t = let is_a tst c : Term.t = Term.const tst @@ Const.make (Is_a c) ops ~ty:(Term.bool tst) + +let as_data t = + match Term.view t with + | E_const { Const.c_view = Data d; _ } -> Some d + | _ -> None + +let as_cstor t = + match Term.view t with + | E_const { Const.c_view = Cstor c; _ } -> Some c + | _ -> None + +let as_select t = + match Term.view t with + | E_const { Const.c_view = Select s; _ } -> Some s + | _ -> None + +let as_is_a t = + match Term.view t with + | E_const { Const.c_view = Is_a c; _ } -> Some c + | _ -> None diff --git a/src/base/Data_ty.mli b/src/base/Data_ty.mli index 875d099a..749bc22a 100644 --- a/src/base/Data_ty.mli +++ b/src/base/Data_ty.mli @@ -40,6 +40,9 @@ end module Cstor : sig type t = cstor + val ty_args : t -> ty list + val select_idx : t -> int -> select + include Sidekick_sigs.EQ_HASH_PRINT with type t := t end @@ -49,3 +52,8 @@ val select : Term.store -> select -> Term.t val is_a : Term.store -> cstor -> Term.t (* TODO: select_ : store -> cstor -> int -> term *) + +val as_data : ty -> data option +val as_select : term -> select option +val as_cstor : term -> cstor option +val as_is_a : term -> cstor option diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index a2753e72..d78f7213 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -17,7 +17,7 @@ *) module Types_ = Types_ -module Term = Sidekick_core.Term +module Term = Term module Const = Sidekick_core.Const module Ty = Ty module ID = ID @@ -27,7 +27,19 @@ module Data_ty = Data_ty module Cstor = Data_ty.Cstor module Select = Data_ty.Select module Statement = Statement +module Solver = Solver module Uconst = Uconst +module Th_data = Th_data +module Th_bool = Th_bool +(* FIXME + module Th_lra = Th_lra +*) + +let th_bool : Solver.theory = Th_bool.theory +let th_data : Solver.theory = Th_data.theory +(* FIXME + let th_lra : Solver.theory = Th_lra.theory +*) (* TODO diff --git a/src/base/Solver.ml b/src/base/Solver.ml new file mode 100644 index 00000000..837cabf3 --- /dev/null +++ b/src/base/Solver.ml @@ -0,0 +1,10 @@ +include Sidekick_smt_solver.Solver + +let default_arg = + (module struct + let view_as_cc = Term.view_as_cc + let is_valid_literal _ = true + end : Sidekick_smt_solver.Sigs.ARG) + +let create_default ?stat ?size ~proof ~theories tst : t = + create default_arg ?stat ?size ~proof ~theories tst () diff --git a/src/base/Term.ml b/src/base/Term.ml new file mode 100644 index 00000000..c85d1e19 --- /dev/null +++ b/src/base/Term.ml @@ -0,0 +1,3 @@ +include Sidekick_core.Term + +let view_as_cc = Sidekick_core.Default_cc_view.view_as_cc diff --git a/src/base/th_bool.ml b/src/base/th_bool.ml new file mode 100644 index 00000000..3f2086a8 --- /dev/null +++ b/src/base/th_bool.ml @@ -0,0 +1,8 @@ +(** Reducing boolean formulas to clauses *) + +let theory : Solver.theory = + Sidekick_th_bool_static.theory + (module struct + let view_as_bool = Form.view + let mk_bool = Form.mk_of_view + end : Sidekick_th_bool_static.ARG) diff --git a/src/base/th_data.ml b/src/base/th_data.ml new file mode 100644 index 00000000..20ffeb16 --- /dev/null +++ b/src/base/th_data.ml @@ -0,0 +1,77 @@ +(** Theory of datatypes *) + +open Sidekick_core + +let arg = + (module struct + module S = Solver + open! Sidekick_th_data + open Data_ty + module Cstor = Cstor + + (* TODO: we probably want to make sure cstors are not polymorphic?! + maybe work on a type/cstor that's applied to pre-selected variables, + like [Map A B] with [A],[B] used for the whole type *) + let unfold_pi t = + let rec unfold acc t = + match Term.view t with + | Term.E_pi (_, ty, bod) -> unfold (ty :: acc) bod + | _ -> List.rev acc, t + in + unfold [] t + + let as_datatype ty : _ data_ty_view = + let args, ret = unfold_pi ty in + if args <> [] then + Ty_arrow (args, ret) + else ( + match Data_ty.as_data ty, Term.view ty with + | Some d, _ -> + let cstors = Lazy.force d.data_cstors in + let cstors = ID.Map.fold (fun _ c l -> c :: l) cstors [] in + Ty_data { cstors } + | None, E_app (a, b) -> Ty_other { sub = [ a; b ] } + | None, E_pi (_, a, b) -> Ty_other { sub = [ a; b ] } + | None, (E_const _ | E_var _ | E_type _ | E_bound_var _ | E_lam _) -> + Ty_other { sub = [] } + ) + + let view_as_data t : _ data_view = + let h, args = Term.unfold_app t in + match + Data_ty.as_cstor h, Data_ty.as_select h, Data_ty.as_is_a h, args + with + | Some c, _, _, _ -> + (* TODO: check arity? store it in [c] ? *) + T_cstor (c, args) + | None, Some sel, _, [ arg ] -> + T_select (sel.select_cstor, sel.select_i, arg) + | None, None, Some c, [ arg ] -> T_is_a (c, arg) + | _ -> T_other t + + let mk_eq = Term.eq + let mk_cstor tst c args : Term.t = Term.app_l tst (Data_ty.cstor tst c) args + + let mk_sel tst c i u = + Term.app_l tst (Data_ty.select tst @@ Data_ty.Cstor.select_idx c i) [ u ] + + let mk_is_a tst c u : Term.t = + if c.cstor_arity = 0 then + Term.eq tst u (Data_ty.cstor tst c) + else + Term.app_l tst (Data_ty.is_a tst c) [ u ] + + (* NOTE: maybe finiteness should be part of the core typeclass for + type consts? or we have a registry for infinite types? *) + + let rec ty_is_finite ty = + match Term.view ty with + | E_const { Const.c_view = Uconst.Uconst _; _ } -> true + | E_const { Const.c_view = Data_ty.Data d; _ } -> true (* TODO: ?? *) + | E_pi (_, a, b) -> ty_is_finite a && ty_is_finite b + | _ -> true + + let ty_set_is_finite _ _ = () (* TODO: remove, use a weak table instead *) + end : Sidekick_th_data.ARG) + +let theory = Sidekick_th_data.make arg diff --git a/src/base/th_lra.ml b/src/base/th_lra.ml new file mode 100644 index 00000000..29e29d19 --- /dev/null +++ b/src/base/th_lra.ml @@ -0,0 +1,48 @@ +(* TODO + + + (** Theory of Linear Rational Arithmetic *) + module Th_lra = Sidekick_arith_lra.Make (struct + module S = Solver + module T = Term + module Z = Sidekick_zarith.Int + module Q = Sidekick_zarith.Rational + + type term = S.T.Term.t + type ty = S.T.Ty.t + + module LRA = Sidekick_arith_lra + + let mk_eq = Form.eq + + let mk_lra store l = + match l with + | LRA.LRA_other x -> x + | LRA.LRA_pred (p, x, y) -> T.lra store (Pred (p, x, y)) + | LRA.LRA_op (op, x, y) -> T.lra store (Op (op, x, y)) + | LRA.LRA_const c -> T.lra store (Const c) + | LRA.LRA_mult (c, x) -> T.lra store (Mult (c, x)) + + let mk_bool = T.bool + + let rec view_as_lra t = + match T.view t with + | T.LRA l -> + let module LRA = Sidekick_arith_lra in + (match l with + | Const c -> LRA.LRA_const c + | Pred (p, a, b) -> LRA.LRA_pred (p, a, b) + | Op (op, a, b) -> LRA.LRA_op (op, a, b) + | Mult (c, x) -> LRA.LRA_mult (c, x) + | To_real x -> view_as_lra x + | Var x -> LRA.LRA_other x) + | T.Eq (a, b) when Ty.equal (T.ty a) (Ty.real ()) -> LRA.LRA_pred (Eq, a, b) + | _ -> LRA.LRA_other t + + let ty_lra _st = Ty.real () + let has_ty_real t = Ty.equal (T.ty t) (Ty.real ()) + let lemma_lra = Proof.lemma_lra + + module Gensym = Gensym + end) +*) From d14617ca77cfcad4affab92d21031e6e3688d502 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:08:57 -0400 Subject: [PATCH 085/174] refactor: rush to have sidekick compile again. th-lra is commented out --- src/main/main.ml | 51 +++++++++++++++++++++++------------------- src/smtlib/Process.ml | 14 +++++++----- src/smtlib/Process.mli | 6 +++-- 3 files changed, 41 insertions(+), 30 deletions(-) diff --git a/src/main/main.ml b/src/main/main.ml index a998d1aa..a89f5018 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -9,6 +9,7 @@ module Fmt = CCFormat module Term = Sidekick_base.Term module Solver = Sidekick_smtlib.Solver module Process = Sidekick_smtlib.Process +module Proof = Sidekick_smtlib.Proof_trace open E.Infix type 'a or_error = ('a, string) E.t @@ -121,8 +122,7 @@ let check_limits () = raise Out_of_space let main_smt () : _ result = - let module Proof = Sidekick_smtlib.Proof in - let tst = Term.create ~size:4_096 () in + let tst = Term.Store.create ~size:4_096 () in let enable_proof_ = !check || !p_proof || !proof_file <> "" in Log.debugf 1 (fun k -> k "(@[proof-enable@ %B@])" enable_proof_); @@ -144,23 +144,26 @@ let main_smt () : _ result = run_with_tmp_file @@ fun temp_proof_file -> Log.debugf 1 (fun k -> k "(@[temp-proof-file@ %S@])" temp_proof_file); - let config = - if enable_proof_ then - Proof.Config.default |> Proof.Config.enable true - |> Proof.Config.store_on_disk_at temp_proof_file - else - Proof.Config.empty - in + (* FIXME + let config = + if enable_proof_ then + Proof.Config.default |> Proof.Config.enable true + |> Proof.Config.store_on_disk_at temp_proof_file + else + Proof.Config.empty + in - (* main proof object *) - let proof = Proof.create ~config () in + (* main proof object *) + let proof = Proof.create ~config () in + *) + let proof = Proof.dummy in let solver = let theories = (* TODO: probes, to load only required theories *) - [ Process.th_bool; Process.th_data; Process.th_lra ] + [ Process.th_bool; Process.th_data (* FIXME Process.th_lra *) ] in - Process.Solver.create ~proof ~theories tst () () + Process.Solver.create_default ~proof ~theories tst in let finally () = @@ -192,16 +195,17 @@ let main_smt () : _ result = res let main_cnf () : _ result = - let module Proof = Pure_sat_solver.Proof in let module S = Pure_sat_solver in let proof, in_memory_proof = - if !check then ( - let pr, inmp = Proof.create_in_memory () in - pr, Some inmp - ) else if !proof_file <> "" then - Proof.create_to_file !proof_file, None - else - Proof.dummy, None + (* FIXME + if !check then ( + let pr, inmp = Proof.create_in_memory () in + pr, Some inmp + ) else if !proof_file <> "" then + Proof.create_to_file !proof_file, None + else + *) + Proof.dummy, None in let stat = Stat.create () in @@ -211,9 +215,10 @@ let main_cnf () : _ result = Proof.close proof in CCFun.protect ~finally @@ fun () -> - let solver = S.SAT.create ~size:`Big ~proof ~stat () in + let tst = Term.Store.create () in + let solver = S.SAT.create_pure_sat ~size:`Big ~proof ~stat () in - S.Dimacs.parse_file solver !file >>= fun () -> + S.Dimacs.parse_file solver tst !file >>= fun () -> let r = S.solve ~check:!check ?in_memory_proof solver in (* FIXME: if in memory proof and !proof_file<>"", then dump proof into file now *) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index afe6d5a1..57f81096 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -10,7 +10,7 @@ type 'a or_error = ('a, string) CCResult.t module E = CCResult module Fmt = CCFormat -module Solver = Sidekick_smt_solver.Solver +module Solver = Sidekick_base.Solver module Check_cc = struct module SI = Sidekick_smt_solver.Solver_internal @@ -326,10 +326,14 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model | Statement.Stmt_data _ -> E.return () | Statement.Stmt_define _ -> Error.errorf "cannot deal with definitions yet" -module Th_data = Th_data -module Th_bool = Th_bool -module Th_lra = Th_lra +module Th_data = Sidekick_base.Th_data +module Th_bool = Sidekick_base.Th_bool +(* FIXME + module Th_lra = Sidekick_base.Th_lra +*) let th_bool : Solver.theory = Th_bool.theory let th_data : Solver.theory = Th_data.theory -let th_lra : Solver.theory = Th_lra.theory +(* FIXME + let th_lra : Solver.theory = Th_lra.theory +*) diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index 99785ff3..b731a92a 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -1,11 +1,13 @@ (** {1 Process Statements} *) open Sidekick_base -module Solver = Sidekick_smt_solver.Solver +module Solver = Sidekick_base.Solver val th_bool : Solver.theory val th_data : Solver.theory -val th_lra : Solver.theory +(* FIXME + val th_lra : Solver.theory +*) type 'a or_error = ('a, string) CCResult.t From 67d5f244c10d3e04f0482298b1a90dd6c827b4d2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:41:26 -0400 Subject: [PATCH 086/174] feat(Term): offer `is_type` and `is_a_type` --- src/core-logic/term.ml | 35 ++++++++++++++++++++--------------- src/core-logic/term.mli | 7 ++++++- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index cf9f06f6..c63b7690 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -30,13 +30,16 @@ let[@inline] has_fvars e = (e.flags lsr store_id_bits) land 1 == 1 let[@inline] store_uid e : int = e.flags land store_id_mask let[@inline] is_closed e : bool = db_depth e == 0 +(* slow path *) +let[@inline never] ty_force_delayed_ e f = + let ty = f () in + e.ty <- T_ty ty; + ty + let[@inline] ty e : term = match e.ty with | T_ty t -> t - | T_ty_delayed f -> - let ty = f () in - e.ty <- T_ty ty; - ty + | T_ty_delayed f -> ty_force_delayed_ e f (* open an application *) let unfold_app (e : term) : term * term list = @@ -225,16 +228,18 @@ let map_shallow_ ~make ~f (e : term) : term = exception IsSub -let[@inline] is_type_ e = +let[@inline] is_type e = match e.view with | E_type _ -> true | _ -> false +let[@inline] is_a_type (t : t) = is_type (ty t) + let iter_dag ?(seen = Tbl.create 8) ~iter_ty ~f e : unit = let rec loop e = if not (Tbl.mem seen e) then ( Tbl.add seen e (); - if iter_ty && not (is_type_ e) then loop (ty e); + if iter_ty && not (is_type e) then loop (ty e); f e; iter_shallow e ~f:(fun _ u -> loop u) ) @@ -276,7 +281,7 @@ let free_vars ?(init = Var.Set.empty) e : Var.Set.t = module Make_ = struct let compute_db_depth_ e : int = - if is_type_ e then + if is_type e then 0 else ( let d1 = db_depth @@ ty e in @@ -292,7 +297,7 @@ module Make_ = struct ) let compute_has_fvars_ e : bool = - if is_type_ e then + if is_type e then false else has_fvars (ty e) @@ -325,7 +330,7 @@ module Make_ = struct let rec loop e k : term = if is_closed e then e - else if is_type_ e then + else if is_type e then e else ( match view e with @@ -356,7 +361,7 @@ module Make_ = struct (* recurse in subterm [e], under [k] intermediate binders (so any bound variable under k is bound by them) *) let rec aux e k : term = - if is_type_ e then + if is_type e then e else if db_depth e < k then e @@ -425,8 +430,9 @@ module Make_ = struct db_0_replace_ ~make ty_bod_f ~by:a | _ -> Error.errorf - "@[<2>cannot apply %a,@ must have Pi type, but actual type is %a@]" - pp_debug f pp_debug ty_f) + "@[<2>cannot apply %a@ (to %a),@ must have Pi type, but actual type \ + is %a@]" + pp_debug f pp_debug a pp_debug ty_f) | E_pi (_, ty, bod) -> (* TODO: check the actual triplets for COC *) (*Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod;*) @@ -440,6 +446,7 @@ module Make_ = struct (* hashconsing + computing metadata + computing type (for new terms) *) let rec make_ (store : store) view : term = let e = { view; ty = T_ty_delayed ty_assert_false_; id = -1; flags = 0 } in + Log.debugf 50 (fun k -> k "term.make `%a`" pp_debug_with_ids e); let e2 = Hcons.hashcons store.s_exprs e in if e == e2 then ( (* new term, compute metadata *) @@ -485,7 +492,7 @@ module Make_ = struct let cache_ = T_int_tbl.create 16 in let rec loop k e = - if is_type_ e then + if is_type e then e else if not (has_fvars e) then (* no free variables, cannot change *) @@ -602,8 +609,6 @@ let map_shallow store ~f e : t = map_shallow_ ~make:(make_ store) ~f e (* re-export some internal things *) module Internal_ = struct - let is_type_ = is_type_ - let subst_ store ~recursive t subst = subst_ ~make:(make_ store) ~recursive t subst end diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index 66e3e93b..cf277f73 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -83,6 +83,12 @@ val contains : t -> sub:t -> bool val free_vars_iter : t -> var Iter.t val free_vars : ?init:Var.Set.t -> t -> Var.Set.t +val is_type : t -> bool +(** [is_type t] is true iff [view t] is [Type _] *) + +val is_a_type : t -> bool +(** [is_a_type t] is true if [is_ty (ty t)] *) + val is_closed : t -> bool (** Is the term closed (all bound variables are paired with a binder)? time: O(1) *) @@ -153,7 +159,6 @@ end (**/**) module Internal_ : sig - val is_type_ : t -> bool val subst_ : store -> recursive:bool -> t -> subst -> t end From b73c1bf46494b73d07597409c85be22127e3dcfd Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Wed, 10 Aug 2022 22:41:53 -0400 Subject: [PATCH 087/174] feat(bool): use binary symbols for boolean operators this helps in simplifying only fully applied boolean operators, and avoiding simplifying the binary function `(or)` to `(false)` --- src/base/Form.ml | 31 ++++------ src/base/Form.mli | 12 ++-- src/core/bool_view.ml | 8 +-- src/simplify/sidekick_simplify.ml | 14 +++-- src/th-bool-static/Sidekick_th_bool_static.ml | 59 ++++++++++--------- src/th-bool-static/intf.ml | 12 ++-- 6 files changed, 69 insertions(+), 67 deletions(-) diff --git a/src/base/Form.ml b/src/base/Form.ml index e931c08f..9a4971a2 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -5,12 +5,12 @@ module T = Term type ty = Term.t type term = Term.t -type ('a, 'args) view = ('a, 'args) Sidekick_core.Bool_view.t = +type 'a view = 'a Sidekick_core.Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'args - | B_or of 'args - | B_imply of 'args * 'a + | B_and of 'a * 'a + | B_or of 'a * 'a + | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a | B_eq of 'a * 'a @@ -29,18 +29,13 @@ let id_imply = ID.make "=>" exception Not_a_th_term let view_id_ fid args = - if ID.equal fid id_and then - B_and args - else if ID.equal fid id_or then - B_or args - else if ID.equal fid id_imply then ( - match args with - | [ arg; concl ] -> B_imply ([ arg ], concl) - | _ -> raise_notrace Not_a_th_term - ) else - raise_notrace Not_a_th_term + match args with + | [ a; b ] when ID.equal fid id_and -> B_and (a, b) + | [ a; b ] when ID.equal fid id_or -> B_or (a, b) + | [ a; b ] when ID.equal fid id_imply -> B_imply (a, b) + | _ -> raise_notrace Not_a_th_term -let view (t : T.t) : (T.t, _) view = +let view (t : T.t) : T.t view = let hd, args = T.unfold_app t in match T.view hd, args with | E_const { Const.c_view = T.C_true; _ }, [] -> B_bool true @@ -118,9 +113,9 @@ let distinct_l tst l = let mk_of_view tst = function | B_bool b -> T.bool_val tst b | B_atom t -> t - | B_and l -> and_l tst l - | B_or l -> or_l tst l - | B_imply (a, b) -> imply_l tst a b + | B_and (a, b) -> and_ tst a b + | B_or (a, b) -> or_ tst a b + | B_imply (a, b) -> imply tst a b | B_ite (a, b, c) -> ite tst a b c | B_equiv (a, b) -> equiv tst a b | B_xor (a, b) -> not_ tst (equiv tst a b) diff --git a/src/base/Form.mli b/src/base/Form.mli index d8015407..6b9c2c4f 100644 --- a/src/base/Form.mli +++ b/src/base/Form.mli @@ -11,12 +11,12 @@ open Types_ type term = Term.t -type ('a, 'args) view = ('a, 'args) Sidekick_core.Bool_view.t = +type 'a view = 'a Sidekick_core.Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'args - | B_or of 'args - | B_imply of 'args * 'a + | B_and of 'a * 'a + | B_or of 'a * 'a + | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a | B_eq of 'a * 'a @@ -24,7 +24,7 @@ type ('a, 'args) view = ('a, 'args) Sidekick_core.Bool_view.t = | B_ite of 'a * 'a * 'a | B_atom of 'a -val view : term -> (term, term list) view +val view : term -> term view val bool : Term.store -> bool -> term val not_ : Term.store -> term -> term val and_ : Term.store -> term -> term -> term @@ -42,7 +42,7 @@ val distinct_l : Term.store -> term list -> term val and_l : Term.store -> term list -> term val or_l : Term.store -> term list -> term val imply_l : Term.store -> term list -> term -> term -val mk_of_view : Term.store -> (term, term list) view -> term +val mk_of_view : Term.store -> term view -> term (* TODO? val make : Term.store -> (term, term list) view -> term diff --git a/src/core/bool_view.ml b/src/core/bool_view.ml index 6842efc7..f348cec5 100644 --- a/src/core/bool_view.ml +++ b/src/core/bool_view.ml @@ -1,12 +1,12 @@ (** Boolean-oriented view of terms *) (** View *) -type ('a, 'args) t = +type 'a t = | B_bool of bool | B_not of 'a - | B_and of 'args - | B_or of 'args - | B_imply of 'args * 'a + | B_and of 'a * 'a + | B_or of 'a * 'a + | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a | B_eq of 'a * 'a diff --git a/src/simplify/sidekick_simplify.ml b/src/simplify/sidekick_simplify.ml index 3a49c947..c2abd434 100644 --- a/src/simplify/sidekick_simplify.ml +++ b/src/simplify/sidekick_simplify.ml @@ -26,10 +26,14 @@ let normalize (self : t) (t : Term.t) : (Term.t * Proof_step.id) option = match Term.Tbl.find self.cache t with | res -> res | exception Not_found -> - let steps_u = ref Bag.empty in - let u = aux_rec ~steps:steps_u t self.hooks in - Term.Tbl.add self.cache t (u, !steps_u); - u, !steps_u + if Term.is_a_type t then + t, Bag.empty + else ( + let steps_u = ref Bag.empty in + let u = aux_rec ~steps:steps_u t self.hooks in + Term.Tbl.add self.cache t (u, !steps_u); + u, !steps_u + ) and loop_add ~steps t = let u, pr_u = loop t in steps := Bag.append !steps pr_u; @@ -39,7 +43,7 @@ let normalize (self : t) (t : Term.t) : (Term.t * Proof_step.id) option = match hooks with | [] -> let u = - Term.map_shallow self.tst ~f:(fun _inb u -> loop_add ~steps u) t + Term.map_shallow self.tst t ~f:(fun _inb sub_t -> loop_add ~steps sub_t) in if Term.equal t u then t diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index bb982b86..7c3b074f 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -55,25 +55,25 @@ end = struct | B_not u when is_false u -> ret_bequiv t (T.true_ tst) | B_not _ -> None | B_atom _ -> None - | B_and a -> - if List.exists is_false a then + | B_and (a, b) -> + if is_false a || is_false b then ret (T.false_ tst) - else if List.for_all is_true a then + else if is_true a && is_true b then ret (T.true_ tst) else None - | B_or a -> - if List.exists is_true a then + | B_or (a, b) -> + if is_true a || is_true b then ret (T.true_ tst) - else if List.for_all is_false a then + else if is_false a && is_false b then ret (T.false_ tst) else None - | B_imply (args, u) -> - if List.exists is_false args then - ret (T.true_ tst) - else if is_true u then + | B_imply (a, b) -> + if is_false a || is_true b then ret (T.true_ tst) + else if is_true a && is_false b then + ret (T.false_ tst) else None | B_ite (a, b, c) -> @@ -166,49 +166,52 @@ end = struct (match A.view_as_bool t with | B_bool _ -> () | B_not _ -> () - | B_and l -> + | B_and (a, b) -> let lit = PA.mk_lit t in - let subs = List.map PA.mk_lit l in + let subs = List.map PA.mk_lit [ a; b ] in (* add clauses *) - List.iter2 - (fun t_u u -> + List.iter + (fun u -> + let t_u = Lit.term u in PA.add_clause [ Lit.neg lit; u ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-e" [ t; t_u ])) - l subs; + subs; PA.add_clause (lit :: List.map Lit.neg subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) - | B_or l -> - let subs = List.map PA.mk_lit l in + | B_or (a, b) -> + let subs = List.map PA.mk_lit [ a; b ] in let lit = PA.mk_lit t in (* add clauses *) - List.iter2 - (fun t_u u -> + List.iter + (fun u -> + let t_u = Lit.term u in PA.add_clause [ Lit.neg u; lit ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-i" [ t; t_u ])) - l subs; + subs; PA.add_clause (Lit.neg lit :: subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) - | B_imply (t_args, t_u) -> - (* transform into [¬args \/ u] on the fly *) - let args = List.map (fun t -> Lit.neg (PA.mk_lit t)) t_args in - let u = PA.mk_lit t_u in - let subs = u :: args in + | B_imply (a, b) -> + (* transform into [¬a \/ b] on the fly *) + let n_a = PA.mk_lit ~sign:false a in + let b = PA.mk_lit b in + let subs = [ n_a; b ] in (* now the or-encoding *) let lit = PA.mk_lit t in (* add clauses *) - List.iter2 - (fun t_u u -> + List.iter + (fun u -> + let t_u = Lit.term u in PA.add_clause [ Lit.neg u; lit ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-i" [ t; t_u ])) - (t_u :: t_args) subs; + subs; PA.add_clause (Lit.neg lit :: subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-e" [ t ]) | B_ite (a, b, c) -> diff --git a/src/th-bool-static/intf.ml b/src/th-bool-static/intf.ml index 952b1023..1e36c444 100644 --- a/src/th-bool-static/intf.ml +++ b/src/th-bool-static/intf.ml @@ -6,12 +6,12 @@ type term = Term.t type ty = Term.t (** Boolean-oriented view of terms *) -type ('a, 'args) bool_view = ('a, 'args) Bool_view.t = +type 'a bool_view = 'a Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'args - | B_or of 'args - | B_imply of 'args * 'a + | B_and of 'a * 'a + | B_or of 'a * 'a + | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a | B_eq of 'a * 'a @@ -21,9 +21,9 @@ type ('a, 'args) bool_view = ('a, 'args) Bool_view.t = (** Argument to the theory *) module type ARG = sig - val view_as_bool : term -> (term, term list) bool_view + val view_as_bool : term -> term bool_view (** Project the term into the boolean view. *) - val mk_bool : Term.store -> (term, term list) bool_view -> term + val mk_bool : Term.store -> term bool_view -> term (** Make a term from the given boolean view. *) end From 4d02e2a1c7129ce81a01a9ad53e6ef4f4f84eafb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Aug 2022 23:09:48 -0400 Subject: [PATCH 088/174] fix(cc): bug in backtracking --- src/cc/CC.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index 004dec85..0af10dca 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -218,6 +218,7 @@ let raise_conflict_ (cc : t) ~th (e : Lit.t list) (p : Proof_term.step_id) : _ = Vec.clear cc.combine; Event.emit cc.on_conflict { cc; th; c = e }; Stat.incr cc.count_conflict; + Vec.clear cc.res_acts; raise (E_confl (Conflict (e, p))) let[@inline] all_classes self : repr Iter.t = From 593b693cafdef932e589dfeade0818db3f5f1e21 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Aug 2022 23:09:56 -0400 Subject: [PATCH 089/174] refactor lit a bit --- src/core/lit.ml | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/src/core/lit.ml b/src/core/lit.ml index 8b85e2a4..9ba770b6 100644 --- a/src/core/lit.ml +++ b/src/core/lit.ml @@ -5,21 +5,16 @@ type term = T.t type t = { lit_term: term; lit_sign: bool } let[@inline] neg l = { l with lit_sign = not l.lit_sign } -let[@inline] sign t = t.lit_sign -let[@inline] abs t = { t with lit_sign = true } -let[@inline] term (t : t) : term = t.lit_term -let[@inline] signed_term t = term t, sign t -let make ~sign t = { lit_sign = sign; lit_term = t } +let[@inline] sign l = l.lit_sign +let[@inline] abs l = { l with lit_sign = true } +let[@inline] term (l : t) : term = l.lit_term +let[@inline] signed_term l = term l, sign l +let[@inline] make_ ~sign t : t = { lit_sign = sign; lit_term = t } let atom ?(sign = true) (t : term) : t = let sign', t = T_builtins.abs t in - let sign = - if not sign' then - not sign - else - sign - in - make ~sign t + let sign = sign = sign' in + make_ ~sign t let make_eq ?sign store t u : t = let p = T_builtins.eq store t u in From e99192869da4d5e2f256c9d54476f89bd38f62ec Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Aug 2022 23:17:15 -0400 Subject: [PATCH 090/174] remove debug --- src/core-logic/term.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index c63b7690..5afb6c41 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -446,7 +446,6 @@ module Make_ = struct (* hashconsing + computing metadata + computing type (for new terms) *) let rec make_ (store : store) view : term = let e = { view; ty = T_ty_delayed ty_assert_false_; id = -1; flags = 0 } in - Log.debugf 50 (fun k -> k "term.make `%a`" pp_debug_with_ids e); let e2 = Hcons.hashcons store.s_exprs e in if e == e2 then ( (* new term, compute metadata *) From 85eef2d11752037dc79e0de017d1e9657be5baac Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Aug 2022 23:17:20 -0400 Subject: [PATCH 091/174] feat(base/data): fix types for cstor/select term builders --- src/base/Data_ty.ml | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/base/Data_ty.ml b/src/base/Data_ty.ml index 75c02dbf..6032707f 100644 --- a/src/base/Data_ty.ml +++ b/src/base/Data_ty.ml @@ -110,10 +110,19 @@ let data tst d : Term.t = Term.const tst @@ Const.make (Data d) ops ~ty:(Term.type_ tst) let cstor tst c : Term.t = - Term.const tst @@ Const.make (Cstor c) ops ~ty:(Lazy.force c.cstor_ty) + let ty_ret = Lazy.force c.cstor_ty in + let ty_args = + List.map (fun s -> Lazy.force s.select_ty) (Lazy.force c.cstor_args) + in + let ty = Term.arrow_l tst ty_args ty_ret in + Log.debugf 50 (fun k -> k "cstor %a (ty %a)" Cstor.pp c Term.pp ty); + Term.const tst @@ Const.make (Cstor c) ops ~ty let select tst s : Term.t = - Term.const tst @@ Const.make (Select s) ops ~ty:(Lazy.force s.select_ty) + let ty_ret = Lazy.force s.select_ty in + let ty_arg = data tst s.select_cstor.cstor_ty_as_data in + let ty = Term.arrow tst ty_arg ty_ret in + Term.const tst @@ Const.make (Select s) ops ~ty let is_a tst c : Term.t = Term.const tst @@ Const.make (Is_a c) ops ~ty:(Term.bool tst) From 85314379a501aa07fa6e7e2f0f66791deae27b40 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 12 Aug 2022 23:21:56 -0400 Subject: [PATCH 092/174] fix type of is_a --- src/base/Data_ty.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/base/Data_ty.ml b/src/base/Data_ty.ml index 6032707f..408e8dba 100644 --- a/src/base/Data_ty.ml +++ b/src/base/Data_ty.ml @@ -115,7 +115,6 @@ let cstor tst c : Term.t = List.map (fun s -> Lazy.force s.select_ty) (Lazy.force c.cstor_args) in let ty = Term.arrow_l tst ty_args ty_ret in - Log.debugf 50 (fun k -> k "cstor %a (ty %a)" Cstor.pp c Term.pp ty); Term.const tst @@ Const.make (Cstor c) ops ~ty let select tst s : Term.t = @@ -125,7 +124,9 @@ let select tst s : Term.t = Term.const tst @@ Const.make (Select s) ops ~ty let is_a tst c : Term.t = - Term.const tst @@ Const.make (Is_a c) ops ~ty:(Term.bool tst) + let ty_arg = Lazy.force c.cstor_ty in + let ty = Term.arrow tst ty_arg (Term.bool tst) in + Term.const tst @@ Const.make (Is_a c) ops ~ty let as_data t = match Term.view t with From 7d46a38e2cceeb64a28e9383f09d75cb52d8c962 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:29:35 -0400 Subject: [PATCH 093/174] fix compilation in unittest --- unittest/old/dune | 2 +- unittest/old/regression/dune | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unittest/old/dune b/unittest/old/dune index da6b7015..95f488d2 100644 --- a/unittest/old/dune +++ b/unittest/old/dune @@ -19,7 +19,7 @@ (targets basic.drup) (deps (:pb basic.cnf) - (:solver ../main/main.exe)) + (:solver ../../src/main/main.exe)) (action (run %{solver} %{pb} -t 2 -o %{targets}))) diff --git a/unittest/old/regression/dune b/unittest/old/regression/dune index a5440a9a..8bd5feb3 100644 --- a/unittest/old/regression/dune +++ b/unittest/old/regression/dune @@ -2,11 +2,11 @@ (targets reg_model_lra1.out) (deps (:file reg_model_lra1.smt2) - ../../main/main.exe) + (:main ../../../src/main/main.exe)) (action (with-stdout-to %{targets} - (bash "../../main/main.exe %{file} | tail -n +2")))) + (bash "%{main} %{file} | tail -n +2")))) (rule (alias runtest) From 632d5e3f40a2ac9128fa6cff14b24dccc2c4abda Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:29:49 -0400 Subject: [PATCH 094/174] fix(core-logic): ensure store IDs fit in 5 bits --- src/core-logic/term.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 5afb6c41..5147cf08 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -161,7 +161,8 @@ module Store = struct let n = ref 0 let create ?(size = 256) () : t = - let s_uid = !n in + (* store id, modulo 2^5 *) + let s_uid = !n land store_id_mask in incr n; { s_uid; s_exprs = Hcons.create ~size () } From c2eac5e2c34bc5bc8ad5d6ebcc1ecbd53e0b114b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:30:03 -0400 Subject: [PATCH 095/174] update doc --- src/tef/Sidekick_tef.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tef/Sidekick_tef.mli b/src/tef/Sidekick_tef.mli index 28c36807..8766d4a6 100644 --- a/src/tef/Sidekick_tef.mli +++ b/src/tef/Sidekick_tef.mli @@ -5,7 +5,7 @@ profiling probes will emit TEF events. Profiling is enabled if {!setup} is called, and if - the environment variable "TEF" is set to "1" or "true". + the environment variable "TRACE" is set to "1" or "true". The trace is emitted in the file "trace.json.gz" in the directory where the solver is launched; you can open it in chrome/chromium at "chrome://tracing". From 92edae353d64c06d450b020c121546c1227d9268 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:30:08 -0400 Subject: [PATCH 096/174] feat(sat): add `mk_plugin_cdcl_t` --- src/sat/solver.ml | 10 ++++++++++ src/sat/solver.mli | 19 +++++++++++++++++++ 2 files changed, 29 insertions(+) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index c4399c2e..5137508e 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -2022,6 +2022,16 @@ let plugin_cdcl_t (module P : THEORY_CDCL_T) : (module PLUGIN) = let has_theory = true end) +let mk_plugin_cdcl_t ~push_level ~pop_levels ?(partial_check = ignore) + ~final_check () : (module PLUGIN) = + (module struct + let push_level = push_level + let pop_levels = pop_levels + let partial_check = partial_check + let final_check = final_check + let has_theory = true + end) + let plugin_pure_sat : plugin = (module struct let push_level () = () diff --git a/src/sat/solver.mli b/src/sat/solver.mli index 808dde58..689bb6ba 100644 --- a/src/sat/solver.mli +++ b/src/sat/solver.mli @@ -154,6 +154,25 @@ val check_sat_propagations_only : val plugin_cdcl_t : (module THEORY_CDCL_T) -> (module PLUGIN) +val mk_plugin_cdcl_t : + push_level:(unit -> unit) -> + pop_levels:(int -> unit) -> + ?partial_check:(acts -> unit) -> + final_check:(acts -> unit) -> + unit -> + (module PLUGIN) +(** Create a plugin + @param push_level create a new backtrack level + @param pop_levels Pop [n] levels of the plugin + @param partial_check Assume the lits in the slice, possibly using the [slice] + to push new lits to be propagated or to raising a conflict or to add + new lemmas. + @param final_check Called at the end of the search in case a model has been found. + If no new clause is pushed, then proof search ends and "sat" is returned; + if lemmas are added, search is resumed; + if a conflict clause is added, search backtracks and then resumes. + *) + val create : ?stat:Stat.t -> ?size:[ `Tiny | `Small | `Big ] -> From eddbf139fce9d5b78846c1d7b701570733ed23e3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:30:21 -0400 Subject: [PATCH 097/174] refactor sudoku solver; make it compile; use new term repr --- examples/sudoku/sudoku_solve.ml | 178 ++++++++++++++++++-------------- sudoku_solve.sh | 3 + 2 files changed, 103 insertions(+), 78 deletions(-) create mode 100755 sudoku_solve.sh diff --git a/examples/sudoku/sudoku_solve.ml b/examples/sudoku/sudoku_solve.ml index df87a662..7280ae14 100644 --- a/examples/sudoku/sudoku_solve.ml +++ b/examples/sudoku/sudoku_solve.ml @@ -1,9 +1,6 @@ (** simple sudoku solver *) -module Fmt = CCFormat -module Vec = Sidekick_util.Vec -module Log = Sidekick_util.Log -module Profile = Sidekick_util.Profile +open Sidekick_util let errorf msg = Fmt.kasprintf failwith msg @@ -147,74 +144,73 @@ module Solver : sig val create : Grid.t -> t val solve : t -> Grid.t option end = struct - open Sidekick_sat.Solver_intf + open Sidekick_core - (* formulas *) - module F = struct - type t = bool * int * int * Cell.t + type Const.view += Cell_is of { x: int; y: int; value: Cell.t } - let equal (sign1, x1, y1, c1) (sign2, x2, y2, c2) = - sign1 = sign2 && x1 = x2 && y1 = y2 && Cell.equal c1 c2 + let ops = + (module struct + let pp out = function + | Cell_is { x; y; value } -> + Fmt.fprintf out "(%d:%d=%a)" x y Cell.pp value + | _ -> () - let hash (sign, x, y, c) = - CCHash.(combine4 (bool sign) (int x) (int y) (Cell.hash c)) + let hash = function + | Cell_is { x; y; value } -> + Hash.(combine3 (int x) (int y) (Cell.hash value)) + | _ -> assert false - let pp out (sign, x, y, c) = - Fmt.fprintf out "[@[(%d,%d) %s %a@]]" x y - (if sign then - "=" - else - "!=") - Cell.pp c + let equal a b = + match a, b with + | Cell_is a, Cell_is b -> + a.x = b.x && a.y = b.y && Cell.equal a.value b.value + | _ -> false + end : Const.DYN_OPS) - let neg (sign, x, y, c) = not sign, x, y, c + module Sat = Sidekick_sat - let norm_sign ((sign, _, _, _) as f) = - if sign then - f, true - else - neg f, false + let mk_cell tst x y value : Term.t = + Term.const tst + @@ Const.make (Cell_is { x; y; value }) ops ~ty:(Term.bool tst) - let make sign x y (c : Cell.t) : t = sign, x, y, c - end + let mk_cell_lit ?sign tst x y value : Lit.t = + Lit.atom ?sign @@ mk_cell tst x y value - module Theory = struct - include Sidekick_sat.Proof_dummy.Make (F) + module Theory : sig + type t - type proof = unit - type proof_step = unit + val grid : t -> Grid.t + val create : Term.store -> Grid.t -> t + val to_plugin : t -> Sat.plugin + end = struct + type t = { tst: Term.store; grid: Grid.t B_ref.t } - module Lit = F - - type lit = Lit.t - type t = { grid: Grid.t B_ref.t } - - let create g : t = { grid = B_ref.create g } let[@inline] grid self : Grid.t = B_ref.get self.grid let[@inline] set_grid self g : unit = B_ref.set self.grid g let push_level self = B_ref.push_level self.grid let pop_levels self n = B_ref.pop_levels self.grid n - let pp_c_ = Fmt.(list ~sep:(return "@ ∨ ")) F.pp + let pp_c_ = Fmt.(list ~sep:(return "@ ∨ ")) Lit.pp let[@inline] logs_conflict kind c : unit = Log.debugf 4 (fun k -> k "(@[conflict.%s@ %a@])" kind pp_c_ c) (* check that all cells are full *) - let check_full_ (self : t) (acts : (Lit.t, proof, proof_step) acts) : unit = - Profile.with_ "check-full" @@ fun () -> + let check_full_ (self : t) (acts : Sat.acts) : unit = + (*let@ () = Profile.with_ "check-full" in*) let (module A) = acts in Grid.all_cells (grid self) (fun (x, y, c) -> if Cell.is_empty c then ( let c = - CCList.init 9 (fun c -> F.make true x y (Cell.make (c + 1))) + CCList.init 9 (fun c -> + mk_cell_lit self.tst x y (Cell.make (c + 1))) in Log.debugf 4 (fun k -> k "(@[add-clause@ %a@])" pp_c_ c); - A.add_clause ~keep:true c () + A.add_clause ~keep:true c Proof_trace.dummy_step_id )) (* check constraints *) - let check_ (self : t) (acts : (Lit.t, proof, proof_step) acts) : unit = - Profile.with_ "check-constraints" @@ fun () -> + let check_ (self : t) (acts : Sat.acts) : unit = + (*let@ () = Profile.with_ "check-constraints" in*) Log.debugf 4 (fun k -> k "(@[sudoku.check@ @[:g %a@]@])" Grid.pp (B_ref.get self.grid)); let (module A) = acts in @@ -229,9 +225,14 @@ end = struct pairs (fun ((x1, y1, c1), (x2, y2, c2)) -> if Cell.equal c1 c2 then ( assert (x1 <> x2 || y1 <> y2); - let c = [ F.make false x1 y1 c1; F.make false x2 y2 c2 ] in + let c = + [ + mk_cell_lit self.tst ~sign:false x1 y1 c1; + mk_cell_lit self.tst ~sign:false x2 y2 c2; + ] + in logs_conflict ("all-diff." ^ kind) c; - A.raise_conflict c () + A.raise_conflict c Proof_trace.dummy_step_id )) in all_diff "rows" Grid.rows; @@ -239,67 +240,88 @@ end = struct all_diff "squares" Grid.squares; () - let trail_ (acts : (Lit.t, proof, proof_step) acts) = + let trail_ (acts : Sat.acts) = let (module A) = acts in A.iter_assumptions (* update current grid with the given slice *) - let add_slice (self : t) (acts : (Lit.t, proof, proof_step) acts) : unit = + let add_slice (self : t) (acts : Sat.acts) : unit = let (module A) = acts in - trail_ acts (function - | false, _, _, _ -> () - | true, x, y, c -> - assert (Cell.is_full c); - let grid = grid self in - let c' = Grid.get grid x y in - if Cell.is_empty c' then - set_grid self (Grid.set grid x y c) - else if Cell.neq c c' then ( - (* conflict: at most one value *) - let c = [ F.make false x y c; F.make false x y c' ] in - logs_conflict "at-most-one" c; - A.raise_conflict c () - )) + trail_ acts (fun lit -> + match Lit.sign lit, Term.view (Lit.term lit) with + | true, E_const { Const.c_view = Cell_is { x; y; value = c }; _ } -> + assert (Cell.is_full c); + let grid = grid self in + let c' = Grid.get grid x y in + if Cell.is_empty c' then + set_grid self (Grid.set grid x y c) + else if Cell.neq c c' then ( + (* conflict: at most one value *) + let c = + [ + mk_cell_lit self.tst ~sign:false x y c; + mk_cell_lit self.tst ~sign:false x y c'; + ] + in + logs_conflict "at-most-one" c; + A.raise_conflict c Proof_trace.dummy_step_id + ) + | _ -> ()) let partial_check (self : t) acts : unit = - Profile.with_ "partial-check" @@ fun () -> + (* let@ () = Profile.with_ "partial-check" in*) Log.debugf 4 (fun k -> - k "(@[sudoku.partial-check@ :trail [@[%a@]]@])" (Fmt.list F.pp) - (trail_ acts |> Iter.to_list)); + k "(@[sudoku.partial-check@ :trail [@[%a@]]@])" (Fmt.iter Lit.pp) + (trail_ acts)); add_slice self acts; check_ self acts let final_check (self : t) acts : unit = - Profile.with_ "final-check" @@ fun () -> + (*let@ () = Profile.with_ "final-check" in*) Log.debugf 4 (fun k -> k "(@[sudoku.final-check@])"); check_full_ self acts; check_ self acts + + let create tst g : t = { tst; grid = B_ref.create g } + + let to_plugin (self : t) : Sat.plugin = + Sat.mk_plugin_cdcl_t + ~push_level:(fun () -> push_level self) + ~pop_levels:(fun n -> pop_levels self n) + ~partial_check:(partial_check self) ~final_check:(final_check self) () end - module S = Sidekick_sat.Make_cdcl_t (Theory) - - type t = { grid0: Grid.t; solver: S.t } + type t = { grid0: Grid.t; tst: Term.store; theory: Theory.t; solver: Sat.t } let solve (self : t) : _ option = - Profile.with_ "sudoku.solve" @@ fun () -> + let@ () = Profile.with_ "sudoku.solve" in let assumptions = Grid.all_cells self.grid0 |> Iter.filter (fun (_, _, c) -> Cell.is_full c) - |> Iter.map (fun (x, y, c) -> F.make true x y c) + |> Iter.map (fun (x, y, c) -> mk_cell_lit self.tst x y c) |> Iter.to_rev_list in Log.debugf 2 (fun k -> - k "(@[sudoku.solve@ :assumptions %a@])" (Fmt.Dump.list F.pp) assumptions); + k "(@[sudoku.solve@ :assumptions %a@])" (Fmt.Dump.list Lit.pp) + assumptions); let r = - match S.solve self.solver ~assumptions with - | S.Sat _ -> Some (Theory.grid (S.theory self.solver)) - | S.Unsat _ -> None + match Sat.solve self.solver ~assumptions with + | Sat.Sat _ -> Some (Theory.grid self.theory) + | Sat.Unsat _ -> None in (* TODO: print some stats *) r let create g : t = - { solver = S.create ~proof:() (Theory.create g); grid0 = g } + let tst = Term.Store.create () in + let theory = Theory.create tst g in + let plugin : Sat.plugin = Theory.to_plugin theory in + { + tst; + solver = Sat.create ~proof:Proof_trace.dummy plugin; + theory; + grid0 = g; + } end let solve_grid (g : Grid.t) : Grid.t option = @@ -320,7 +342,7 @@ let chrono ~pp_time : (module CHRONO) = (module M) let solve_file ~pp_time file = - Profile.with_ "solve-file" @@ fun () -> + let@ () = Profile.with_ "solve-file" in let open (val chrono ~pp_time) in Format.printf "solve grids in file %S@." file; @@ -360,7 +382,7 @@ let solve_file ~pp_time file = () let () = - Sidekick_tef.with_setup @@ fun () -> + let@ () = Sidekick_tef.with_setup in Fmt.set_color_default true; let files = ref [] in let debug = ref 0 in diff --git a/sudoku_solve.sh b/sudoku_solve.sh new file mode 100755 index 00000000..278cce92 --- /dev/null +++ b/sudoku_solve.sh @@ -0,0 +1,3 @@ +#!/bin/sh +OPTS="--profile=release --display=quiet" +exec dune exec $OPTS examples/sudoku/sudoku_solve.exe -- $@ From 63802fe3d6977d9a7d839ce4713e0ce4a5269997 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:45:21 -0400 Subject: [PATCH 098/174] feat(stat): improve printing api --- src/main/main.ml | 2 +- src/smt/solver.ml | 2 +- src/util/Stat.ml | 3 ++- src/util/Stat.mli | 3 ++- 4 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/main/main.ml b/src/main/main.ml index a89f5018..ca6f432d 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -211,7 +211,7 @@ let main_cnf () : _ result = let stat = Stat.create () in let finally () = - if !p_stat then Fmt.printf "%a@." Stat.pp_all (Stat.all stat); + if !p_stat then Fmt.printf "%a@." Stat.pp stat; Proof.close proof in CCFun.protect ~finally @@ fun () -> diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 4b2aa8ab..4c6be1ca 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -134,7 +134,7 @@ let mk_lit_t (self : t) ?sign (t : term) : lit = (** {2 Main} *) -let pp_stats out (self : t) : unit = Stat.pp_all out (Stat.all @@ stats self) +let pp_stats out (self : t) : unit = Stat.pp out (stats self) (* add [c], without preprocessing its literals *) let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit = diff --git a/src/util/Stat.ml b/src/util/Stat.ml index d81b30c6..f024a9f0 100644 --- a/src/util/Stat.ml +++ b/src/util/Stat.ml @@ -37,11 +37,12 @@ let[@inline] incr x = x.count <- 1 + x.count let[@inline] incr_f x by = x.count <- by +. x.count let[@inline] set c x : unit = c.count <- x -let pp_all out l = +let pp_counters out l = let pp_w out = function | C_int { name; count } -> Fmt.fprintf out "@[:%s %d@]" name count | C_float { name; count } -> Fmt.fprintf out "@[:%s %.4f@]" name count in Fmt.fprintf out "(@[stats@ %a@])" Fmt.(iter ~sep:(return "@ ") pp_w) l +let pp out (self : t) = pp_counters out @@ all self let global = create () diff --git a/src/util/Stat.mli b/src/util/Stat.mli index c3da800c..53945c43 100644 --- a/src/util/Stat.mli +++ b/src/util/Stat.mli @@ -18,7 +18,8 @@ type ex_counter (** Existential counter *) val all : t -> ex_counter Iter.t -val pp_all : ex_counter Iter.t Fmt.printer +val pp_counters : ex_counter Iter.t Fmt.printer +val pp : t Fmt.printer val global : t (** Global statistics, by default *) From 6ccabc70aa310418596ed00a68ca40409dffb3b6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:45:38 -0400 Subject: [PATCH 099/174] feat(sudoku): add stats --- examples/sudoku/sudoku_solve.ml | 56 ++++++++++++++++++++++----------- 1 file changed, 37 insertions(+), 19 deletions(-) diff --git a/examples/sudoku/sudoku_solve.ml b/examples/sudoku/sudoku_solve.ml index 7280ae14..68850ed9 100644 --- a/examples/sudoku/sudoku_solve.ml +++ b/examples/sudoku/sudoku_solve.ml @@ -141,7 +141,7 @@ module B_ref = Sidekick_util.Backtrackable_ref module Solver : sig type t - val create : Grid.t -> t + val create : stat:Stat.t -> Grid.t -> t val solve : t -> Grid.t option end = struct open Sidekick_core @@ -180,15 +180,18 @@ end = struct type t val grid : t -> Grid.t - val create : Term.store -> Grid.t -> t + val create : stat:Stat.t -> Term.store -> Grid.t -> t val to_plugin : t -> Sat.plugin end = struct - type t = { tst: Term.store; grid: Grid.t B_ref.t } + type t = { + tst: Term.store; + grid: Grid.t B_ref.t; + stat_check_full: int Stat.counter; + stat_conflict: int Stat.counter; + } let[@inline] grid self : Grid.t = B_ref.get self.grid let[@inline] set_grid self g : unit = B_ref.set self.grid g - let push_level self = B_ref.push_level self.grid - let pop_levels self n = B_ref.pop_levels self.grid n let pp_c_ = Fmt.(list ~sep:(return "@ ∨ ")) Lit.pp let[@inline] logs_conflict kind c : unit = @@ -200,6 +203,7 @@ end = struct let (module A) = acts in Grid.all_cells (grid self) (fun (x, y, c) -> if Cell.is_empty c then ( + Stat.incr self.stat_check_full; let c = CCList.init 9 (fun c -> mk_cell_lit self.tst x y (Cell.make (c + 1))) @@ -214,7 +218,7 @@ end = struct Log.debugf 4 (fun k -> k "(@[sudoku.check@ @[:g %a@]@])" Grid.pp (B_ref.get self.grid)); let (module A) = acts in - let[@inline] all_diff kind f = + let[@inline] all_diff c_kind f = let pairs = f (grid self) |> Iter.flat_map (fun set -> @@ -231,7 +235,8 @@ end = struct mk_cell_lit self.tst ~sign:false x2 y2 c2; ] in - logs_conflict ("all-diff." ^ kind) c; + Stat.incr self.stat_conflict; + logs_conflict c_kind c; A.raise_conflict c Proof_trace.dummy_step_id )) in @@ -282,12 +287,18 @@ end = struct check_full_ self acts; check_ self acts - let create tst g : t = { tst; grid = B_ref.create g } + let create ~stat tst g : t = + { + tst; + grid = B_ref.create g; + stat_check_full = Stat.mk_int stat "sudoku.check-cell-full"; + stat_conflict = Stat.mk_int stat "sudoku.conflict"; + } let to_plugin (self : t) : Sat.plugin = Sat.mk_plugin_cdcl_t - ~push_level:(fun () -> push_level self) - ~pop_levels:(fun n -> pop_levels self n) + ~push_level:(fun () -> B_ref.push_level self.grid) + ~pop_levels:(fun n -> B_ref.pop_levels self.grid n) ~partial_check:(partial_check self) ~final_check:(final_check self) () end @@ -312,20 +323,20 @@ end = struct (* TODO: print some stats *) r - let create g : t = + let create ~stat g : t = let tst = Term.Store.create () in - let theory = Theory.create tst g in + let theory = Theory.create ~stat tst g in let plugin : Sat.plugin = Theory.to_plugin theory in { tst; - solver = Sat.create ~proof:Proof_trace.dummy plugin; + solver = Sat.create ~stat ~proof:Proof_trace.dummy plugin; theory; grid0 = g; } end -let solve_grid (g : Grid.t) : Grid.t option = - let s = Solver.create g in +let solve_grid ~stat (g : Grid.t) : Grid.t option = + let s = Solver.create ~stat g in Solver.solve s module type CHRONO = sig @@ -341,7 +352,7 @@ let chrono ~pp_time : (module CHRONO) = end in (module M) -let solve_file ~pp_time file = +let solve_file ~use_stats ~pp_time file = let@ () = Profile.with_ "solve-file" in let open (val chrono ~pp_time) in Format.printf "solve grids in file %S@." file; @@ -365,7 +376,8 @@ let solve_file ~pp_time file = Format.printf "@[@,#########################@,@[<2>solve grid:@ %a@]@]@." Grid.pp g; let open (val chrono ~pp_time) in - match solve_grid g with + let stat = Stat.create () in + (match solve_grid ~stat g with | None -> Format.printf "no solution%t@." pp_elapsed | Some g' when not @@ Grid.is_full g' -> errorf "grid %a@ is not full" Grid.pp g' @@ -376,7 +388,8 @@ let solve_file ~pp_time file = g | Some g' -> Format.printf "@[@[<2>solution%t:@ %a@]@,###################@]@." - pp_elapsed Grid.pp g') + pp_elapsed Grid.pp g'); + if use_stats then Fmt.printf "stats: %a@." Stat.pp stat) grids; Format.printf "@.solved %d grids%t@." (List.length grids) pp_elapsed; () @@ -387,17 +400,22 @@ let () = let files = ref [] in let debug = ref 0 in let pp_time = ref true in + let use_stats = ref false in let opts = [ "--debug", Arg.Set_int debug, " debug"; "-d", Arg.Set_int debug, " debug"; "--no-time", Arg.Clear pp_time, " do not print solve time"; + "--stat", Arg.Set use_stats, " print statistics"; ] |> Arg.align in Arg.parse opts (fun f -> files := f :: !files) "sudoku_solve [options] "; Log.set_debug !debug; - try List.iter (fun f -> solve_file ~pp_time:!pp_time f) !files + try + List.iter + (fun f -> solve_file ~pp_time:!pp_time ~use_stats:!use_stats f) + !files with Failure msg | Invalid_argument msg -> Format.printf "@{Error@}:@.%s@." msg; exit 1 From 517a5d2e5ff511a2e1be23d93c4b3e2fd8a3dcf0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 13 Aug 2022 13:55:01 -0400 Subject: [PATCH 100/174] better tracing --- src/sat/solver.ml | 5 +++++ src/smt/solver_internal.ml | 4 ---- src/smtlib/Process.ml | 6 +++--- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index 5137508e..007b2c34 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -1621,6 +1621,7 @@ let pick_branch_lit ~full self : bool = (* do some amount of search, until the number of conflicts or clause learnt reaches the given parameters *) let search (self : t) ~on_progress ~(max_conflicts : int) : unit = + let@ () = Profile.with_ "sat.search" in Log.debugf 3 (fun k -> k "(@[sat.search@ :max-conflicts %d@ :max-learnt %d@])" max_conflicts !(self.max_clauses_learnt)); @@ -1645,6 +1646,7 @@ let search (self : t) ~on_progress ~(max_conflicts : int) : unit = assert (self.elt_head = AVec.size self.trail); assert (self.elt_head = self.th_head); if max_conflicts > 0 && !n_conflicts >= max_conflicts then ( + Profile.instant "sat.restart"; Log.debug 1 "(sat.restarting)"; cancel_until self 0; Stat.incr self.n_restarts; @@ -1682,6 +1684,7 @@ let[@inline] eval st lit = fst @@ eval_level st lit (* fixpoint of propagation and decisions until a model is found, or a conflict is reached *) let solve_ ~on_progress (self : t) : unit = + let@ () = Profile.with_ "sat.solve" in Log.debugf 5 (fun k -> k "(@[sat.solve :assms %d@])" (AVec.size self.assumptions)); check_unsat_ self; @@ -1724,6 +1727,8 @@ let solve_ ~on_progress (self : t) : unit = check_is_conflict_ self c; Clause.iter self.store c ~f:(fun a -> insert_var_order self (Atom.var a)); + + Profile.instant "sat.th-conflict"; Log.debugf 5 (fun k -> k "(@[sat.theory-conflict-clause@ %a@])" (Clause.debug self.store) c); diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index eff96801..bf5adae7 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -73,10 +73,6 @@ let[@inline] cc (self : t) = self.cc let[@inline] tst self = self.tst let[@inline] proof self = self.proof let stats self = self.stat - -let[@inline] has_delayed_actions self = - not (Queue.is_empty self.delayed_actions) - let registry self = self.registry let simplifier self = self.simp let simplify_t self (t : Term.t) : _ option = Simplify.normalize self.simp t diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 57f81096..44a6ac2b 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -170,9 +170,9 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) in let res = - Profile.with_ "solve" (fun () -> - Solver.solve ~assumptions ?on_progress ?should_stop s - (* ?gc ?restarts ?time ?memory ?progress *)) + let@ () = Profile.with_ "process.solve" in + Solver.solve ~assumptions ?on_progress ?should_stop s + (* ?gc ?restarts ?time ?memory ?progress *) in let t2 = Sys.time () in Printf.printf "\r"; From ba2e19188284b6853a7d8129c497fe533bd5d25a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 14:15:45 -0400 Subject: [PATCH 101/174] detail --- src/smt/solver.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 4c6be1ca..cb08c429 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -177,7 +177,7 @@ let assert_term self t = assert_terms self [ t ] let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) ?(should_stop = fun _ _ -> false) ~assumptions (self : t) : res = - Profile.with_ "smt-solver.solve" @@ fun () -> + let@ () = Profile.with_ "smt-solver.solve" in let do_on_exit () = List.iter (fun f -> f ()) on_exit in let on_progress = From 6b09a562c5d1b80102a355c8bbc55834be61971d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 14:17:18 -0400 Subject: [PATCH 102/174] comment out tests for now --- unittest/old/dune | 29 +++++++++++++++-------------- unittest/old/regression/dune | 33 +++++++++++++++++---------------- 2 files changed, 32 insertions(+), 30 deletions(-) diff --git a/unittest/old/dune b/unittest/old/dune index 95f488d2..3c7bf9a0 100644 --- a/unittest/old/dune +++ b/unittest/old/dune @@ -15,17 +15,18 @@ (run ./run_tests.exe alcotest) ; run regressions first (run ./run_tests.exe qcheck --verbose)))) -(rule - (targets basic.drup) - (deps - (:pb basic.cnf) - (:solver ../../src/main/main.exe)) - (action - (run %{solver} %{pb} -t 2 -o %{targets}))) - -(rule - (alias runtest) - (locks /test) - (package sidekick-bin) - (action - (diff basic.drup.expected basic.drup))) +; FIXME +;(rule +; (targets basic.drup) +; (deps +; (:pb basic.cnf) +; (:solver ../../src/main/main.exe)) +; (action +; (run %{solver} %{pb} -t 2 -o %{targets}))) +; +;(rule +; (alias runtest) +; (locks /test) +; (package sidekick-bin) +; (action +; (diff basic.drup.expected basic.drup))) diff --git a/unittest/old/regression/dune b/unittest/old/regression/dune index 8bd5feb3..c4a26e7c 100644 --- a/unittest/old/regression/dune +++ b/unittest/old/regression/dune @@ -1,16 +1,17 @@ -(rule - (targets reg_model_lra1.out) - (deps - (:file reg_model_lra1.smt2) - (:main ../../../src/main/main.exe)) - (action - (with-stdout-to - %{targets} - (bash "%{main} %{file} | tail -n +2")))) - -(rule - (alias runtest) - (locks /test) - (package sidekick-bin) - (action - (diff reg_model_lra1.out.expected reg_model_lra1.out))) +; FIXME +;(rule +; (targets reg_model_lra1.out) +; (deps +; (:file reg_model_lra1.smt2) +; (:main ../../../src/main/main.exe)) +; (action +; (with-stdout-to +; %{targets} +; (bash "%{main} %{file} | tail -n +2")))) +; +;(rule +; (alias runtest) +; (locks /test) +; (package sidekick-bin) +; (action +; (diff reg_model_lra1.out.expected reg_model_lra1.out))) From 82691069f1a42c397c10b1e1cc5e91e8c4fab2f0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 22:32:21 -0400 Subject: [PATCH 103/174] perf: dune flags --- dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dune b/dune index 1b55029c..7a66c521 100644 --- a/dune +++ b/dune @@ -4,5 +4,5 @@ (_ (flags :standard -warn-error -a+8+9 -w +a-4-32-40-41-42-44-48-70 -color always -strict-sequence -safe-string -short-paths) - (ocamlopt_flags :standard -O3 -color always -unbox-closures + (ocamlopt_flags :standard -O3 -color always -inline 30 -unbox-closures -unbox-closures-factor 20))) From 23e70a192a20a4ba30d232b09869606d64bead6b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 22:32:28 -0400 Subject: [PATCH 104/174] perf(cc): more inlining; remove dead code --- src/cc/CC.ml | 9 +++++---- src/cc/Sidekick_cc.ml | 3 ++- src/cc/Sidekick_cc.mli | 2 +- src/cc/signature.ml | 11 ++--------- src/cc/sigs.ml | 4 ---- src/cc/view.ml | 0 src/cc/view.mli | 0 src/core/CC_view.ml | 4 ++-- 8 files changed, 12 insertions(+), 21 deletions(-) delete mode 100644 src/cc/sigs.ml delete mode 100644 src/cc/view.ml delete mode 100644 src/cc/view.mli diff --git a/src/cc/CC.ml b/src/cc/CC.ml index 0af10dca..417e2253 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -180,14 +180,15 @@ let add_signature self (s : signature) (n : e_node) : unit = on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); Sig_tbl.add self.signatures_tbl s n -let push_pending self t : unit = +let[@inline] push_pending self t : unit = Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); Vec.push self.pending t -let push_action self (a : Handler_action.t) : unit = +let[@inline] push_action self (a : Handler_action.t) : unit = Vec.push self.combine (CT_act a) -let push_action_l self (l : _ list) : unit = List.iter (push_action self) l +let[@inline] push_action_l self (l : _ list) : unit = + List.iter (push_action self) l let merge_classes self t u e : unit = if t != u && not (same_class t u) then ( @@ -544,7 +545,7 @@ and task_pending_ self (n : e_node) : unit = ) | Some s0 -> (* update the signature by using [find] on each sub-e_node *) - let s = update_sig s0 in + let s = (update_sig [@inlined]) s0 in (match find_signature self s with | None -> (* add to the signature table [sig(n) --> n] *) diff --git a/src/cc/Sidekick_cc.ml b/src/cc/Sidekick_cc.ml index 49cb02fe..f5357948 100644 --- a/src/cc/Sidekick_cc.ml +++ b/src/cc/Sidekick_cc.ml @@ -1,4 +1,5 @@ -module View = View +open Sidekick_core +module View = CC_view module E_node = E_node module Expl = Expl module Signature = Signature diff --git a/src/cc/Sidekick_cc.mli b/src/cc/Sidekick_cc.mli index 9d2e149e..feed0665 100644 --- a/src/cc/Sidekick_cc.mli +++ b/src/cc/Sidekick_cc.mli @@ -4,7 +4,7 @@ module type DYN_MONOID_PLUGIN = Sigs_plugin.DYN_MONOID_PLUGIN module type MONOID_PLUGIN_ARG = Sigs_plugin.MONOID_PLUGIN_ARG module type MONOID_PLUGIN_BUILDER = Sigs_plugin.MONOID_PLUGIN_BUILDER -module View = View +module View = Sidekick_core.CC_view module E_node = E_node module Expl = Expl module Signature = Signature diff --git a/src/cc/signature.ml b/src/cc/signature.ml index fa1adf7c..8678ba04 100644 --- a/src/cc/signature.ml +++ b/src/cc/signature.ml @@ -19,14 +19,7 @@ let equal (s1 : t) s2 : bool = E_node.equal a1 a2 && E_node.equal b1 b2 && E_node.equal c1 c2 | Eq (a1, b1), Eq (a2, b2) -> E_node.equal a1 a2 && E_node.equal b1 b2 | Opaque u1, Opaque u2 -> E_node.equal u1 u2 - | Bool _, _ - | App_fun _, _ - | App_ho _, _ - | If _, _ - | Eq _, _ - | Opaque _, _ - | Not _, _ -> - false + | (Bool _ | App_fun _ | App_ho _ | If _ | Eq _ | Opaque _ | Not _), _ -> false let hash (s : t) : int = let module H = CCHash in @@ -40,7 +33,7 @@ let hash (s : t) : int = H.combine4 60 (E_node.hash a) (E_node.hash b) (E_node.hash c) | Not u -> H.combine2 70 (E_node.hash u) -let pp out = function +let[@inline never] pp out = function | Bool b -> Fmt.bool out b | App_fun (f, []) -> Const.pp out f | App_fun (f, l) -> diff --git a/src/cc/sigs.ml b/src/cc/sigs.ml deleted file mode 100644 index fd0fbed3..00000000 --- a/src/cc/sigs.ml +++ /dev/null @@ -1,4 +0,0 @@ -(** Main types for congruence closure *) - -open Sidekick_core -module View = View diff --git a/src/cc/view.ml b/src/cc/view.ml deleted file mode 100644 index e69de29b..00000000 diff --git a/src/cc/view.mli b/src/cc/view.mli deleted file mode 100644 index e69de29b..00000000 diff --git a/src/core/CC_view.ml b/src/core/CC_view.ml index e319f5ef..91050870 100644 --- a/src/core/CC_view.ml +++ b/src/core/CC_view.ml @@ -8,7 +8,7 @@ type ('f, 't, 'ts) t = | Opaque of 't (* do not enter *) -let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = +let[@inline] map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = match v with | Bool b -> Bool b | App_fun (f, args) -> App_fun (f_f f, f_ts args) @@ -18,7 +18,7 @@ let map_view ~f_f ~f_t ~f_ts (v : _ t) : _ t = | Eq (a, b) -> Eq (f_t a, f_t b) | Opaque t -> Opaque (f_t t) -let iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = +let[@inline] iter_view ~f_f ~f_t ~f_ts (v : _ t) : unit = match v with | Bool _ -> () | App_fun (f, args) -> From 6f42c060f4763a9b8aa752e71a32951fc985e753 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 22:32:51 -0400 Subject: [PATCH 105/174] perf(util): more inlining --- src/util/Hash.ml | 19 ++++++++++--------- src/util/Log.ml | 4 ++-- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/util/Hash.ml b/src/util/Hash.ml index 82a40add..d4c534f8 100644 --- a/src/util/Hash.ml +++ b/src/util/Hash.ml @@ -15,8 +15,8 @@ let hash_int_ n = (h := Int64.(mul !h fnv_prime)); h := Int64.(logxor !h (of_int ((n lsr (k * 8)) land 0xff))) done; + (* truncate back to int and remove sign *) Int64.to_int !h land max_int -(* truncate back to int and remove sign *) let combine2 a b = let h = ref fnv_offset_basis in @@ -60,20 +60,21 @@ let combine4 a b c d = done; Int64.to_int !h land max_int -let pair f g (x, y) = combine2 (f x) (g y) +let[@inline] pair f g (x, y) = combine2 (f x) (g y) let opt f = function | None -> 42 | Some x -> combine2 43 (f x) -let int = hash_int_ +let[@inline] int x = hash_int_ x +let h_true_ = hash_int_ 1 +let h_false_ = hash_int_ 0 -let bool b = - hash_int_ - (if b then - 1 - else - 2) +let[@inline] bool b = + if b then + h_true_ + else + h_false_ let list f l = List.fold_left (combine f) 0x42 l let array f = Array.fold_left (combine f) 0x43 diff --git a/src/util/Log.ml b/src/util/Log.ml index 9e826e15..9aa129fb 100644 --- a/src/util/Log.ml +++ b/src/util/Log.ml @@ -1,6 +1,6 @@ (** {1 Logging functions, real version} *) -let enabled = true (* NOTE: change here for 0-overhead *) +let enabled = true (* NOTE: change here for 0-overhead? *) let debug_level_ = ref 0 let set_debug l = debug_level_ := l @@ -9,7 +9,7 @@ let debug_fmt_ = ref Format.err_formatter let set_debug_out f = debug_fmt_ := f (* does the printing, inconditionally *) -let debug_real_ l k = +let[@inline never] debug_real_ l k = k (fun fmt -> Format.fprintf !debug_fmt_ "@[<2>@{[%d|%.3f]@}@ " l (Sys.time ()); Format.kfprintf (fun fmt -> Format.fprintf fmt "@]@.") !debug_fmt_ fmt) From 541d0c25458cf5ed5c0c671a4e9fd50096d271b7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 22:33:21 -0400 Subject: [PATCH 106/174] cleanup --- src/sat/base_types_.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/sat/base_types_.ml b/src/sat/base_types_.ml index 7e6843dd..e298c545 100644 --- a/src/sat/base_types_.ml +++ b/src/sat/base_types_.ml @@ -1,5 +1,4 @@ open Sidekick_core -open Sigs (* a boolean variable (positive int) *) module Var0 : sig From 6fca21bd3351c02939f29d68c03bb96ceeae8c0d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 22:35:34 -0400 Subject: [PATCH 107/174] symlink in makefile --- Makefile | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/Makefile b/Makefile index 9840b1d9..b6197567 100644 --- a/Makefile +++ b/Makefile @@ -22,6 +22,7 @@ build-dev: clean: @dune clean + @rm sidekick || true test: @dune runtest $(OPTS) --force --no-buffer @@ -32,31 +33,34 @@ DATE=$(shell date +%FT%H:%M) snapshots: @mkdir -p snapshots -$(TESTTOOL)-quick: snapshots +sidekick: + @ln -f -s _build/default/src/main/main.exe ./sidekick + +$(TESTTOOL)-quick: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/quick-$(DATE).csv --task sidekick-smt-quick -$(TESTTOOL)-quick-proofs: snapshots +$(TESTTOOL)-quick-proofs: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/quick-$(DATE).csv --task sidekick-smt-quick-proofs --proof-dir out-proofs-$(DATE)/ -$(TESTTOOL)-local: snapshots +$(TESTTOOL)-local: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/quick-$(DATE).csv --task sidekick-smt-local -$(TESTTOOL)-smt-QF_UF: snapshots +$(TESTTOOL)-smt-QF_UF: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_UF-$(DATE).csv --task sidekick-smt-nodir tests/QF_UF -$(TESTTOOL)-smt-QF_DT: snapshots +$(TESTTOOL)-smt-QF_DT: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_DT-$(DATE).csv --task sidekick-smt-nodir tests/QF_DT -$(TESTTOOL)-smt-QF_LRA: snapshots +$(TESTTOOL)-smt-QF_LRA: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_LRA-$(DATE).csv --task sidekick-smt-nodir tests/QF_LRA -$(TESTTOOL)-smt-QF_UFLRA: snapshots +$(TESTTOOL)-smt-QF_UFLRA: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_UFLRA-$(DATE).csv --task sidekick-smt-nodir tests/QF_UFLRA -$(TESTTOOL)-smt-QF_LIA: snapshots +$(TESTTOOL)-smt-QF_LIA: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_LRA-$(DATE).csv --task sidekick-smt-nodir tests/QF_LIA -$(TESTTOOL)-smt-QF_UFLIA: snapshots +$(TESTTOOL)-smt-QF_UFLIA: sidekick snapshots $(TESTTOOL) run $(TESTOPTS) \ --csv snapshots/smt-QF_LRA-$(DATE).csv --task sidekick-smt-nodir tests/QF_UFLIA From 2ab93aee0470a56ccc50759fe6432561c779047f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 23:21:02 -0400 Subject: [PATCH 108/174] feat(main): fix initial time; better display (smtlib-friendly) --- src/smtlib/Process.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 44a6ac2b..d30a6790 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -114,9 +114,9 @@ end *) let reset_line = "\x1b[2K\r" +let start = Sys.time () let mk_progress (_s : Solver.t) : _ -> unit = - let start = Sys.time () in let n = ref 0 in let syms = "|\\-/" in fun _s -> @@ -146,7 +146,7 @@ let with_file_out (file : string) (f : out_channel -> 'a) : 'a = (* call the solver to check-sat *) let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) ?time ?memory ?(progress = false) ~assumptions s : Solver.res = - let t1 = Sys.time () in + let t1 = Sys.time () -. start in let on_progress = if progress then Some (mk_progress s) @@ -189,7 +189,8 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) ); *) let t3 = Sys.time () -. t2 in - Format.printf "Sat (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 + Fmt.printf "sat@."; + Fmt.printf "; (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 | Solver.Unsat { unsat_step_id; unsat_core = _ } -> if check then () @@ -221,9 +222,11 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) | _ -> ()); let t3 = Sys.time () -. t2 in - Format.printf "Unsat (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 + Fmt.printf "unsat@."; + Fmt.printf "; (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 | Solver.Unknown reas -> - Format.printf "Unknown (:reason %a)@." Solver.Unknown.pp reas + Fmt.printf "unknown@."; + Fmt.printf "; @[:reason %a@]@." Solver.Unknown.pp reas | exception exn -> Printf.printf "%s%!" reset_line; raise exn); From 08a4ed892dbe8c23950c1bbd5a580239739f9968 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 23:21:22 -0400 Subject: [PATCH 109/174] feat(stat): improve printing --- src/util/Stat.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/util/Stat.ml b/src/util/Stat.ml index f024a9f0..e24db9b2 100644 --- a/src/util/Stat.ml +++ b/src/util/Stat.ml @@ -39,10 +39,10 @@ let[@inline] set c x : unit = c.count <- x let pp_counters out l = let pp_w out = function - | C_int { name; count } -> Fmt.fprintf out "@[:%s %d@]" name count - | C_float { name; count } -> Fmt.fprintf out "@[:%s %.4f@]" name count + | C_int { name; count } -> Fmt.fprintf out "(@[%s %d@])" name count + | C_float { name; count } -> Fmt.fprintf out "(@[%s %.4f@])" name count in - Fmt.fprintf out "(@[stats@ %a@])" Fmt.(iter ~sep:(return "@ ") pp_w) l + Fmt.fprintf out "(@[<1>stats@ %a@])" Fmt.(iter ~sep:(return "@ ") pp_w) l let pp out (self : t) = pp_counters out @@ all self let global = create () From e9dae47d0b4ef243241f1727362762bf3a561eff Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 23:21:40 -0400 Subject: [PATCH 110/174] fixup: modify benchpress for new output --- tests/benchpress.sexp | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/tests/benchpress.sexp b/tests/benchpress.sexp index 304aefcb..22a52076 100644 --- a/tests/benchpress.sexp +++ b/tests/benchpress.sexp @@ -2,9 +2,9 @@ (prover (name sidekick-dev) (cmd "$cur_dir/../sidekick --no-check --time $timeout $file") - (unsat "Unsat") - (sat "Sat") - (unknown "Timeout|Unknown") + (unsat "^unsat") + (sat "^sat") + (unknown "^(timeout|unknown)") (version "git:.")) (proof_checker From 94ba945bf36e269e0de20b94e1010b659e519ed0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 14 Aug 2022 23:21:49 -0400 Subject: [PATCH 111/174] feat(cc.plugin): plugins have state, passed at init --- src/cc/CC.ml | 3 ++ src/cc/CC.mli | 1 + src/cc/plugin.ml | 11 +++-- src/cc/sigs_plugin.ml | 9 +++- src/th-bool-static/Sidekick_th_bool_static.ml | 49 ++++++++++++++++--- src/th-cstor/Sidekick_th_cstor.ml | 20 ++++++-- src/th-data/Sidekick_th_data.ml | 25 ++++++++-- src/th-lra/sidekick_th_lra.ml | 14 ++++-- 8 files changed, 106 insertions(+), 26 deletions(-) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index 417e2253..ea467050 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -49,6 +49,7 @@ type combine_task = type t = { view_as_cc: view_as_cc; tst: Term.store; + stat: Stat.t; proof: Proof_trace.t; tbl: e_node T_tbl.t; (* internalization [term -> e_node] *) signatures_tbl: e_node Sig_tbl.t; @@ -108,6 +109,7 @@ let n_bool self b = let[@inline] term_store self = self.tst let[@inline] proof self = self.proof +let[@inline] stat self = self.stat let allocate_bitfield self ~descr : bitfield = Log.debugf 5 (fun k -> k "(@[cc.allocate-bit-field@ :descr %s@])" descr); @@ -851,6 +853,7 @@ let create_ ?(stat = Stat.global) ?(size = `Big) (tst : Term.store) view_as_cc; tst; proof; + stat; tbl = T_tbl.create size; signatures_tbl = Sig_tbl.create size; bitgen; diff --git a/src/cc/CC.mli b/src/cc/CC.mli index 4041f697..e64de856 100644 --- a/src/cc/CC.mli +++ b/src/cc/CC.mli @@ -45,6 +45,7 @@ type t val term_store : t -> Term.store val proof : t -> Proof_trace.t +val stat : t -> Stat.t val find : t -> e_node -> repr (** Current representative *) diff --git a/src/cc/plugin.ml b/src/cc/plugin.ml index 8c25c203..32cc5547 100644 --- a/src/cc/plugin.ml +++ b/src/cc/plugin.ml @@ -33,6 +33,9 @@ module Make (M : MONOID_PLUGIN_ARG) : module CC = CC open A + (* plugin's state *) + let plugin_st = M.create cc + (* repr -> value for the class *) let values : M.t Cls_tbl.t = Cls_tbl.create ?size () @@ -62,7 +65,7 @@ module Make (M : MONOID_PLUGIN_ARG) : let on_new_term cc n (t : Term.t) : CC.Handler_action.t list = (*Log.debugf 50 (fun k->k "(@[monoid[%s].on-new-term.try@ %a@])" M.name N.pp n);*) let acts = ref [] in - let maybe_m, l = M.of_term cc n t in + let maybe_m, l = M.of_term cc plugin_st n t in (match maybe_m with | Some v -> Log.debugf 20 (fun k -> @@ -84,7 +87,7 @@ module Make (M : MONOID_PLUGIN_ARG) : Error.errorf "node %a has bitfield but no value" E_node.pp n_u in - match M.merge cc n_u m_u n_u m_u' (Expl.mk_list []) with + match M.merge cc plugin_st n_u m_u n_u m_u' (Expl.mk_list []) with | Error (CC.Handler_action.Conflict expl) -> Error.errorf "when merging@ @[for node %a@],@ values %a and %a:@ conflict %a" @@ -118,7 +121,7 @@ module Make (M : MONOID_PLUGIN_ARG) : "(@[monoid[%s].on_pre_merge@ (@[:n1 %a@ :val1 %a@])@ (@[:n2 \ %a@ :val2 %a@])@])" M.name E_node.pp n1 M.pp v1 E_node.pp n2 M.pp v2); - (match M.merge cc n1 v1 n2 v2 e_n1_n2 with + (match M.merge cc plugin_st n1 v1 n2 v2 e_n1_n2 with | Ok (v', merge_acts) -> acts := merge_acts; Cls_tbl.remove values n2; @@ -140,8 +143,8 @@ module Make (M : MONOID_PLUGIN_ARG) : in Fmt.fprintf out "(@[%a@])" (Fmt.iter pp_e) iter_all - (* setup *) let () = + (* hook into the CC's events *) Event.on (CC.on_new_term cc) ~f:(fun (_, r, t) -> on_new_term cc r t); Event.on (CC.on_pre_merge2 cc) ~f:(fun (_, ra, rb, expl) -> on_pre_merge cc ra rb expl); diff --git a/src/cc/sigs_plugin.ml b/src/cc/sigs_plugin.ml index a1f0fe18..d77a84f1 100644 --- a/src/cc/sigs_plugin.ml +++ b/src/cc/sigs_plugin.ml @@ -15,12 +15,18 @@ module type MONOID_PLUGIN_ARG = sig include Sidekick_sigs.PRINT with type t := t + type state + + val create : CC.t -> state + (** Initialize state from the congruence closure *) + val name : string (** name of the monoid structure (short) *) (* FIXME: for subs, return list of e_nodes, and assume of_term already returned data for them. *) - val of_term : CC.t -> E_node.t -> Term.t -> t option * (E_node.t * t) list + val of_term : + CC.t -> state -> E_node.t -> Term.t -> t option * (E_node.t * t) list (** [of_term n t], where [t] is the Term.t annotating node [n], must return [maybe_m, l], where: @@ -34,6 +40,7 @@ module type MONOID_PLUGIN_ARG = sig val merge : CC.t -> + state -> E_node.t -> t -> E_node.t -> diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 7c3b074f..13772a56 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -10,9 +10,21 @@ module type ARG = Intf.ARG module Make (A : ARG) : sig val theory : SMT.theory end = struct - type state = { tst: T.store; gensym: Gensym.t } + type state = { + tst: T.store; + gensym: Gensym.t; + n_simplify: int Stat.counter; + n_clauses: int Stat.counter; + } + + let create ~stat tst : state = + { + tst; + gensym = Gensym.create tst; + n_simplify = Stat.mk_int stat "th.bool.simplified"; + n_clauses = Stat.mk_int stat "th.bool.cnf-clauses"; + } - let create tst : state = { tst; gensym = Gensym.create tst } let[@inline] not_ tst t = A.mk_bool tst (B_not t) let[@inline] eq tst a b = A.mk_bool tst (B_eq (a, b)) @@ -42,7 +54,11 @@ end = struct ~res:[ Lit.atom (A.mk_bool tst (B_eq (a, b))) ] in - let[@inline] ret u = Some (u, Iter.of_list !steps) in + let[@inline] ret u = + Stat.incr self.n_simplify; + Some (u, Iter.of_list !steps) + in + (* proof is [t <=> u] *) let ret_bequiv t1 u = (add_step_ @@ mk_step_ @@ fun () -> Proof_rules.lemma_bool_equiv t1 u); @@ -123,7 +139,7 @@ end = struct let[@inline] mk_step_ r = Proof_trace.add_step PA.proof r in (* handle boolean equality *) - let equiv_ _si ~is_xor ~t t_a t_b : unit = + let equiv_ (self : state) _si ~is_xor ~t t_a t_b : unit = let a = PA.mk_lit t_a in let b = PA.mk_lit t_b in let a = @@ -137,23 +153,30 @@ end = struct (* proxy => a<=> b, ¬proxy => a xor b *) + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg lit; Lit.neg a; b ] (if is_xor then mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e+" [ t ] else mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-e" [ t; t_a ]); + + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg lit; Lit.neg b; a ] (if is_xor then mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e-" [ t ] else mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-e" [ t; t_b ]); + + Stat.incr self.n_clauses; PA.add_clause [ lit; a; b ] (if is_xor then mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-i" [ t; t_a ] else mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i+" [ t ]); + + Stat.incr self.n_clauses; PA.add_clause [ lit; Lit.neg a; Lit.neg b ] (if is_xor then @@ -174,10 +197,13 @@ end = struct List.iter (fun u -> let t_u = Lit.term u in + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg lit; u ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-e" [ t; t_u ])) subs; + + Stat.incr self.n_clauses; PA.add_clause (lit :: List.map Lit.neg subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) @@ -189,10 +215,13 @@ end = struct List.iter (fun u -> let t_u = Lit.term u in + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg u; lit ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-i" [ t; t_u ])) subs; + + Stat.incr self.n_clauses; PA.add_clause (Lit.neg lit :: subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) | B_imply (a, b) -> @@ -208,29 +237,35 @@ end = struct List.iter (fun u -> let t_u = Lit.term u in + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg u; lit ] (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-i" [ t; t_u ])) subs; + + Stat.incr self.n_clauses; PA.add_clause (Lit.neg lit :: subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-e" [ t ]) | B_ite (a, b, c) -> let lit_a = PA.mk_lit a in + Stat.incr self.n_clauses; PA.add_clause [ Lit.neg lit_a; PA.mk_lit (eq self.tst t b) ] (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); + + Stat.incr self.n_clauses; PA.add_clause [ lit_a; PA.mk_lit (eq self.tst t c) ] (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) | B_eq _ | B_neq _ -> () - | B_equiv (a, b) -> equiv_ si ~t ~is_xor:false a b - | B_xor (a, b) -> equiv_ si ~t ~is_xor:true a b + | B_equiv (a, b) -> equiv_ self si ~t ~is_xor:false a b + | B_xor (a, b) -> equiv_ self si ~t ~is_xor:true a b | B_atom _ -> ()); () let create_and_setup si = Log.debug 2 "(th-bool.setup)"; - let st = create (SI.tst si) in + let st = create ~stat:(SI.stats si) (SI.tst si) in SI.add_simplifier si (simplify st); SI.on_preprocess si (cnf st); st diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index c309ceee..52fa1d4d 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -23,18 +23,26 @@ end = struct let name = name + type state = { n_merges: int Stat.counter; n_conflict: int Stat.counter } + + let create cc : state = + { + n_merges = Stat.mk_int (CC.stat cc) "th.cstor.merges"; + n_conflict = Stat.mk_int (CC.stat cc) "th.cstor.conflicts"; + } + let pp out (v : t) = Fmt.fprintf out "(@[cstor %a@ :term %a@])" Const.pp v.cstor T.pp_debug v.t (* attach data to constructor terms *) - let of_term cc n (t : T.t) : _ option * _ = + let of_term cc _ n (t : T.t) : _ option * _ = match A.view_as_cstor t with | T_cstor (cstor, args) -> let args = CCArray.map (CC.add_term cc) args in Some { n; t; cstor; args }, [] | _ -> None, [] - let merge _cc n1 v1 n2 v2 e_n1_n2 : _ result = + let merge _cc state n1 v1 n2 v2 e_n1_n2 : _ result = Log.debugf 5 (fun k -> k "(@[%s.merge@ @[:c1 %a (t %a)@]@ @[:c2 %a (t %a)@]@])" name E_node.pp n1 T.pp_debug v1.t E_node.pp n2 T.pp_debug v2.t); @@ -50,14 +58,18 @@ end = struct assert (CCArray.length v1.args = CCArray.length v2.args); let acts = CCArray.map2 - (fun u1 u2 -> CC.Handler_action.Act_merge (u1, u2, expl)) + (fun u1 u2 -> + Stat.incr state.n_merges; + CC.Handler_action.Act_merge (u1, u2, expl)) v1.args v2.args |> Array.to_list in Ok (v1, acts) - ) else + ) else ( (* different function: disjointness *) + Stat.incr state.n_conflict; Error (CC.Handler_action.Conflict expl) + ) end module ST = Sidekick_cc.Plugin.Make (Monoid) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 3bf30e6c..cce845c9 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -150,6 +150,14 @@ end = struct module Monoid_cstor = struct let name = "th-data.cstor" + type state = { n_merges: int Stat.counter; n_conflict: int Stat.counter } + + let create cc : state = + { + n_merges = Stat.mk_int (CC.stat cc) "th.data.cstor-merges"; + n_conflict = Stat.mk_int (CC.stat cc) "th.data.cstor-conflicts"; + } + (* associate to each class a unique constructor term in the class (if any) *) type t = { c_n: E_node.t; c_cstor: A.Cstor.t; c_args: E_node.t list } @@ -158,14 +166,14 @@ end = struct A.Cstor.pp v.c_cstor E_node.pp v.c_n (Util.pp_list E_node.pp) v.c_args (* attach data to constructor terms *) - let of_term cc n (t : Term.t) : _ option * _ list = + let of_term cc _ n (t : Term.t) : _ option * _ list = match A.view_as_data t with | T_cstor (cstor, args) -> let args = List.map (CC.add_term cc) args in Some { c_n = n; c_cstor = cstor; c_args = args }, [] | _ -> None, [] - let merge cc n1 c1 n2 c2 e_n1_n2 : _ result = + let merge cc state n1 c1 n2 c2 e_n1_n2 : _ result = Log.debugf 5 (fun k -> k "(@[%s.merge@ (@[:c1 %a@ %a@])@ (@[:c2 %a@ %a@])@])" name E_node.pp n1 pp c1 E_node.pp n2 pp c2); @@ -194,8 +202,10 @@ end = struct let acts = ref [] in CCList.iteri2 (fun i u1 u2 -> + Stat.incr state.n_merges; acts := CC.Handler_action.Act_merge (u1, u2, expl_merge i) :: !acts) c1.c_args c2.c_args; + Ok (c1, !acts) ) else ( (* different function: disjointness *) @@ -205,6 +215,7 @@ end = struct @@ fun () -> Proof_rules.lemma_cstor_distinct t1 t2 in + Stat.incr state.n_conflict; Error (CC.Handler_action.Conflict expl) ) end @@ -214,6 +225,10 @@ end = struct module Monoid_parents = struct let name = "th-data.parents" + type state = unit + + let create _ = () + type select = { sel_n: E_node.t; sel_cstor: A.Cstor.t; @@ -243,7 +258,7 @@ end = struct v.parent_is_a (* attach data to constructor terms *) - let of_term cc n (t : Term.t) : _ option * _ list = + let of_term cc () n (t : Term.t) : _ option * _ list = match A.view_as_data t with | T_select (c, i, u) -> let u = CC.add_term cc u in @@ -266,7 +281,7 @@ end = struct None, [ u, m_sel ] | T_cstor _ | T_other _ -> None, [] - let merge _cc n1 v1 n2 v2 _e : _ result = + let merge _cc () n1 v1 n2 v2 _e : _ result = Log.debugf 5 (fun k -> k "(@[%s.merge@ @[:c1 %a@ :v %a@]@ @[:c2 %a@ :v %a@]@])" name E_node.pp n1 pp v1 E_node.pp n2 pp v2); @@ -795,7 +810,7 @@ end = struct case_split_done = Term.Tbl.create 16; cards = Card.create (); stat_acycl_conflict = - Stat.mk_int (SI.stats solver) "data.acycl.conflict"; + Stat.mk_int (SI.stats solver) "th.data.acycl.conflict"; } in Log.debugf 1 (fun k -> k "(setup :%s)" name); diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index 5d60f300..c178eb48 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -78,6 +78,10 @@ module Make (A : ARG) = (* : S with module A = A *) struct module Monoid_exprs = struct let name = "lra.const" + type state = unit + + let create _ = () + type single = { le: LE.t; n: E_node.t } type t = single list @@ -89,7 +93,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct | [ x ] -> pp_single out x | _ -> Fmt.fprintf out "(@[exprs@ %a@])" (Util.pp_list pp_single) self - let of_term _cc n t = + let of_term _cc () n t = match A.view_as_lra t with | LRA_const _ | LRA_op _ | LRA_mult _ -> let le = as_linexp t in @@ -100,7 +104,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* merge lists. If two linear expressions equal up to a constant are merged, conflict. *) - let merge _cc n1 l1 n2 l2 expl_12 : _ result = + let merge _cc () n1 l1 n2 l2 expl_12 : _ result = try let i = Iter.(product (of_list l1) (of_list l2)) in i (fun (s1, s2) -> @@ -138,7 +142,8 @@ module Make (A : ARG) = (* : S with module A = A *) struct mutable last_res: SimpSolver.result option; } - let create ?(stat = Stat.create ()) (si : SI.t) : state = + let create (si : SI.t) : state = + let stat = SI.stats si in let proof = SI.proof si in let tst = SI.tst si in { @@ -692,8 +697,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct let create_and_setup si = Log.debug 2 "(th-lra.setup)"; - let stat = SI.stats si in - let st = create ~stat si in + let st = create si in SMT.Registry.set (SI.registry si) k_state st; SI.add_simplifier si (simplify st); SI.on_preprocess si (preproc_lra st); From d5b7c2b0ee927e060d4754da6e493d207f3a2bf8 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:27:09 -0400 Subject: [PATCH 112/174] feat(printer): always put (), do not box applications --- src/core/t_printer.ml | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/core/t_printer.ml b/src/core/t_printer.ml index 7dc82b61..b5fdea62 100644 --- a/src/core/t_printer.ml +++ b/src/core/t_printer.ml @@ -30,7 +30,7 @@ let default_hooks = ref default_ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = let open Term in let rec loop k ~depth names out e = - let pp' = loop' k ~depth:(depth + 1) names in + let pp' = loop k ~depth:(depth + 1) names in let hook_fired = List.exists (fun h -> h ~recurse:pp' out e) hooks in if not hook_fired then ( @@ -48,7 +48,7 @@ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = | (E_app _ | E_lam _) when depth > max_depth -> Fmt.fprintf out "@<1>…" | E_app _ -> let f, args = unfold_app e in - Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args + Fmt.fprintf out "(%a@ %a)" pp' f (Util.pp_list pp') args | E_lam ("", _ty, bod) -> Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) @@ -73,12 +73,6 @@ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = (loop (k + 1) ~depth:(depth + 1) (n :: names)) bod ) - and loop' k ~depth names out e = - match Term.view e with - | E_type _ | E_var _ | E_bound_var _ | E_const _ -> - loop k ~depth names out e (* atomic expr *) - | E_app _ | E_lam _ | E_pi _ -> - Fmt.fprintf out "(%a)" (loop k ~depth names) e in Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e From e233c846ec2abd2a08306306bba1b8ee40ba7657 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:27:32 -0400 Subject: [PATCH 113/174] refactor: cleanup config a bit --- src/base/Config.ml | 4 +--- src/base/Config.mli | 8 +++----- 2 files changed, 4 insertions(+), 8 deletions(-) diff --git a/src/base/Config.ml b/src/base/Config.ml index f82120c5..2c1918ca 100644 --- a/src/base/Config.ml +++ b/src/base/Config.ml @@ -1,6 +1,4 @@ -(** {1 Configuration} *) - -type 'a sequence = ('a -> unit) -> unit +(** Configuration *) module Key = Het.Key diff --git a/src/base/Config.mli b/src/base/Config.mli index 2c7f51c3..43d2a30a 100644 --- a/src/base/Config.mli +++ b/src/base/Config.mli @@ -1,7 +1,5 @@ (** Configuration *) -type 'a sequence = ('a -> unit) -> unit - module Key : sig type 'a t @@ -26,9 +24,9 @@ val find_exn : 'a Key.t -> t -> 'a type pair = Pair : 'a Key.t * 'a -> pair val iter : (pair -> unit) -> t -> unit -val to_iter : t -> pair sequence -val of_iter : pair sequence -> t -val add_iter : t -> pair sequence -> t +val to_iter : t -> pair Iter.t +val of_iter : pair Iter.t -> t +val add_iter : t -> pair Iter.t -> t val add_list : t -> pair list -> t val of_list : pair list -> t val to_list : t -> pair list From 6c14690fbaaed02ae5754cf0ca26a2c7e0de8010 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:27:46 -0400 Subject: [PATCH 114/174] cleanup code --- src/base/Form.ml | 216 ----------------------------------------------- 1 file changed, 216 deletions(-) diff --git a/src/base/Form.ml b/src/base/Form.ml index 9a4971a2..0c72c2b1 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -47,22 +47,6 @@ let view (t : T.t) : T.t view = (try view_id_ uc_id args with Not_a_th_term -> B_atom t) | _ -> B_atom t -(* TODO - let and_l st l = - match flatten_id id_and true l with - | [] -> T.true_ st - | l when List.exists T.is_false l -> T.false_ st - | [ x ] -> x - | args -> T.app_fun st Funs.and_ (CCArray.of_list args) - - let or_l st l = - match flatten_id id_or false l with - | [] -> T.false_ st - | l when List.exists T.is_true l -> T.true_ st - | [ x ] -> x - | args -> T.app_fun st Funs.or_ (CCArray.of_list args) -*) - let c_and tst : Term.t = let bool = Term.bool tst in Uconst.uconst_of_id' tst id_and [ bool; bool ] bool @@ -151,203 +135,3 @@ let mk_of_view tst = function | B_not _ | B_and _ | B_or _ | B_imply _ -> Error.errorf "non boolean value in boolean connective" *) - -(* - -module T = Base_types.Term -module Ty = Base_types.Ty -module Fun = Base_types.Fun -module Value = Base_types.Value -open Sidekick_th_bool_static - -exception Not_a_th_term - -let id_and = ID.make "and" -let id_or = ID.make "or" -let id_imply = ID.make "=>" - -let view_id fid args = - if ID.equal fid id_and then - B_and (CCArray.to_iter args) - else if ID.equal fid id_or then - B_or (CCArray.to_iter args) - else if ID.equal fid id_imply && CCArray.length args >= 2 then ( - (* conclusion is stored last *) - let len = CCArray.length args in - B_imply - (Iter.of_array args |> Iter.take (len - 1), CCArray.get args (len - 1)) - ) else - raise_notrace Not_a_th_term - -let view_as_bool (t : T.t) : (T.t, _) bool_view = - match T.view t with - | Bool b -> B_bool b - | Not u -> B_not u - | Eq (a, b) when Ty.is_bool (T.ty a) -> B_equiv (a, b) - | Ite (a, b, c) -> B_ite (a, b, c) - | App_fun ({ fun_id; _ }, args) -> - (try view_id fun_id args with Not_a_th_term -> B_atom t) - | _ -> B_atom t - -module Funs = struct - let get_ty _ _ = Ty.bool () - - let abs ~self _a = - match T.view self with - | Not u -> u, false - | _ -> self, true - - (* no congruence closure for boolean terms *) - let relevant _id _ _ = false - - let eval id args = - let open Value in - match view_id id args with - | B_bool b -> Value.bool b - | B_not (V_bool b) -> Value.bool (not b) - | B_and a when Iter.for_all Value.is_true a -> Value.true_ - | B_and a when Iter.exists Value.is_false a -> Value.false_ - | B_or a when Iter.exists Value.is_true a -> Value.true_ - | B_or a when Iter.for_all Value.is_false a -> Value.false_ - | B_imply (_, V_bool true) -> Value.true_ - | B_imply (a, _) when Iter.exists Value.is_false a -> Value.true_ - | B_imply (a, b) when Iter.for_all Value.is_true a && Value.is_false b -> - Value.false_ - | B_ite (a, b, c) -> - if Value.is_true a then - b - else if Value.is_false a then - c - else - Error.errorf "non boolean value %a in ite" Value.pp a - | B_equiv (a, b) | B_eq (a, b) -> Value.bool (Value.equal a b) - | B_xor (a, b) | B_neq (a, b) -> Value.bool (not (Value.equal a b)) - | B_atom v -> v - | B_opaque_bool t -> Error.errorf "cannot evaluate opaque bool %a" pp t - | B_not _ | B_and _ | B_or _ | B_imply _ -> - Error.errorf "non boolean value in boolean connective" - - let mk_fun ?(do_cc = false) id : Fun.t = - { - fun_id = id; - fun_view = - Fun_def { pp = None; abs; ty = get_ty; relevant; do_cc; eval = eval id }; - } - - let and_ = mk_fun id_and - let or_ = mk_fun id_or - let imply = mk_fun id_imply - let ite = T.ite -end - -let as_id id (t : T.t) : T.t array option = - match T.view t with - | App_fun ({ fun_id; _ }, args) when ID.equal id fun_id -> Some args - | _ -> None - -(* flatten terms of the given ID *) -let flatten_id op sign (l : T.t list) : T.t list = - CCList.flat_map - (fun t -> - match as_id op t with - | Some args -> CCArray.to_list args - | None when (sign && T.is_true t) || ((not sign) && T.is_false t) -> - [] (* idempotent *) - | None -> [ t ]) - l - -let and_l st l = - match flatten_id id_and true l with - | [] -> T.true_ st - | l when List.exists T.is_false l -> T.false_ st - | [ x ] -> x - | args -> T.app_fun st Funs.and_ (CCArray.of_list args) - -let or_l st l = - match flatten_id id_or false l with - | [] -> T.false_ st - | l when List.exists T.is_true l -> T.true_ st - | [ x ] -> x - | args -> T.app_fun st Funs.or_ (CCArray.of_list args) - -let and_ st a b = and_l st [ a; b ] -let or_ st a b = or_l st [ a; b ] -let and_a st a = and_l st (CCArray.to_list a) -let or_a st a = or_l st (CCArray.to_list a) -let eq = T.eq -let not_ = T.not_ - -let ite st a b c = - match T.view a with - | T.Bool ba -> - if ba then - b - else - c - | _ -> T.ite st a b c - -let equiv st a b = - if T.equal a b then - T.true_ st - else if T.is_true a then - b - else if T.is_true b then - a - else if T.is_false a then - not_ st b - else if T.is_false b then - not_ st a - else - T.eq st a b - -let neq st a b = not_ st @@ eq st a b - -let imply_a st xs y = - if Array.length xs = 0 then - y - else - T.app_fun st Funs.imply (CCArray.append xs [| y |]) - -let imply_l st xs y = - match xs with - | [] -> y - | _ -> imply_a st (CCArray.of_list xs) y - -let imply st a b = imply_a st [| a |] b -let xor st a b = not_ st (equiv st a b) - -let distinct_l tst l = - match l with - | [] | [ _ ] -> T.true_ tst - | l -> - (* turn into [and_{i List.map (fun (a, b) -> neq tst a b) in - and_l tst cs - -let mk_bool st = function - | B_bool b -> T.bool st b - | B_atom t -> t - | B_and l -> and_a st l - | B_or l -> or_a st l - | B_imply (a, b) -> imply_a st a b - | B_ite (a, b, c) -> ite st a b c - | B_equiv (a, b) -> equiv st a b - | B_xor (a, b) -> not_ st (equiv st a b) - | B_eq (a, b) -> T.eq st a b - | B_neq (a, b) -> not_ st (T.eq st a b) - | B_not t -> not_ st t - | B_opaque_bool t -> t - -module Gensym = struct - type t = { tst: T.store; mutable fresh: int } - - let create tst : t = { tst; fresh = 0 } - - let fresh_term (self : t) ~pre (ty : Ty.t) : T.t = - let name = Printf.sprintf "_tseitin_%s%d" pre self.fresh in - self.fresh <- 1 + self.fresh; - let id = ID.make name in - T.const self.tst @@ Fun.mk_undef_const id ty -end - -*) From 99dc9743a3291d664a70e4b78a7252d0ffb5b627 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:29:12 -0400 Subject: [PATCH 115/174] doc --- src/cc/expl.mli | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/cc/expl.mli b/src/cc/expl.mli index 24618076..efa26063 100644 --- a/src/cc/expl.mli +++ b/src/cc/expl.mli @@ -28,20 +28,20 @@ val mk_congruence : E_node.t -> E_node.t -> t val mk_theory : Term.t -> Term.t -> (Term.t * Term.t * t list) list -> Proof_term.step_id -> t (** [mk_theory t u expl_sets pr] builds a theory explanation for - why [|- t=u]. It depends on sub-explanations [expl_sets] which - are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are - explanations that justify [t_i = u_i] in the current congruence closure. + why [|- t=u]. It depends on sub-explanations [expl_sets] which + are tuples [ (t_i, u_i, expls_i) ] where [expls_i] are + explanations that justify [t_i = u_i] in the current congruence closure. - The proof [pr] is the theory lemma, of the form - [ (t_i = u_i)_i |- t=u ]. - It is resolved against each [expls_i |- t_i=u_i] obtained from - [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] - where [Gamma] is a subset of the literals asserted into the congruence - closure. + The proof [pr] is the theory lemma, of the form + [ (t_i = u_i)_i |- t=u ]. + It is resolved against each [expls_i |- t_i=u_i] obtained from + [expl_sets], on pivot [t_i=u_i], to obtain a proof of [Gamma |- t=u] + where [Gamma] is a subset of the literals asserted into the congruence + closure. - For example for the lemma [a=b] deduced by injectivity - from [Some a=Some b] in the theory of datatypes, - the arguments would be - [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] - where [pr] is the injectivity lemma [Some a=Some b |- a=b]. - *) + For example for the lemma [a=b] deduced by injectivity + from [Some a=Some b] in the theory of datatypes, + the arguments would be + [a, b, [Some a, Some b, mk_merge_t (Some a)(Some b)], pr] + where [pr] is the injectivity lemma [Some a=Some b |- a=b]. +*) From 947f790f9f7e41b69e93a261f77fe1ad0e75c9fa Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:29:29 -0400 Subject: [PATCH 116/174] debug in sat --- src/sat/solver.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index 007b2c34..d4f23864 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -1240,15 +1240,15 @@ let acts_raise self (l : Lit.t list) (p : Proof_step.id) : 'a = let check_consequence_lits_false_ self l p : unit = let store = self.store in Log.debugf 50 (fun k -> - k "(@[sat.check-consequence-lits: %a@ :for %a@])" + k "(@[sat.check-consequence-lits:@ :consequence (@[%a@])@ :for %a@])" (Util.pp_list (Atom.debug store)) l (Atom.debug store) p); match List.find (fun a -> Atom.is_true store a) l with | a -> invalid_argf "slice.acts_propagate:@ Consequence should contain only false literals,@ \ - but @[%a@] is true" - (Atom.debug store) (Atom.neg a) + but @[%a@] is true@ when propagating %a" + (Atom.debug store) p (Atom.debug store) a | exception Not_found -> () let acts_propagate (self : t) f (expl : reason) = From 310d2183c47cf1d20aea2fb938b8888b75ba96cb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:29:45 -0400 Subject: [PATCH 117/174] add Lit.Tbl,Lit.Set,Lit.Map --- src/core/lit.ml | 16 ++++++++++++++-- src/core/lit.mli | 2 ++ 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/core/lit.ml b/src/core/lit.ml index 9ba770b6..a9479a62 100644 --- a/src/core/lit.ml +++ b/src/core/lit.ml @@ -28,12 +28,24 @@ let hash a = let pp out l = if l.lit_sign then - T.pp_debug out l.lit_term + T_printer.pp out l.lit_term else - Format.fprintf out "(@[@<1>¬@ %a@])" T.pp_debug l.lit_term + Format.fprintf out "(@[@<1>¬@ %a@])" T_printer.pp l.lit_term let norm_sign l = if l.lit_sign then l, true else neg l, false + +module As_key = struct + type nonrec t = t + + let equal = equal + let hash = hash + let compare = compare +end + +module Map = CCMap.Make (As_key) +module Set = CCSet.Make (As_key) +module Tbl = CCHashtbl.Make (As_key) diff --git a/src/core/lit.mli b/src/core/lit.mli index bf012a59..6b3b42c1 100644 --- a/src/core/lit.mli +++ b/src/core/lit.mli @@ -42,3 +42,5 @@ val norm_sign : t -> t * bool (** [norm_sign (+t)] is [+t, true], and [norm_sign (-t)] is [+t, false]. In both cases the term is positive, and the boolean reflects the initial sign. *) + +include Sidekick_sigs.WITH_SET_MAP_TBL with type t := t From 5b87ff3e465653a9b16ae26f3c74ee416c0ff665 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:29:58 -0400 Subject: [PATCH 118/174] feat(theory): add name accessor --- src/smt/theory.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/smt/theory.ml b/src/smt/theory.ml index 7039ecb6..72410afe 100644 --- a/src/smt/theory.ml +++ b/src/smt/theory.ml @@ -31,6 +31,11 @@ type 'a p = (module S with type t = 'a) (** A theory that can be used for this particular solver, with state of type ['a]. *) +(** Name of the theory *) +let name (th : t) = + let (module T) = th in + T.name + let make (type st) ~name ~create_and_setup ?(push_level = fun _ -> ()) ?(pop_levels = fun _ _ -> ()) () : t = let module Th = struct From 57941a952a89ac7768b9be45f9bb8b7cf1e7edd6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:30:17 -0400 Subject: [PATCH 119/174] add th-bool-dyn for dynamic boolean clausification --- src/base/Sidekick_base.ml | 7 +- src/base/dune | 2 +- src/base/th_bool.ml | 19 +- src/main/main.ml | 38 +- src/smtlib/Process.ml | 14 +- src/smtlib/Process.mli | 4 +- src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 434 +++++++++++++----- src/th-bool-dyn/dune.bak | 6 - src/th-bool-static/Sidekick_th_bool_static.ml | 2 +- 9 files changed, 399 insertions(+), 127 deletions(-) delete mode 100644 src/th-bool-dyn/dune.bak diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index d78f7213..e13f4026 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -29,14 +29,19 @@ module Select = Data_ty.Select module Statement = Statement module Solver = Solver module Uconst = Uconst +module Config = Config module Th_data = Th_data module Th_bool = Th_bool (* FIXME module Th_lra = Th_lra *) -let th_bool : Solver.theory = Th_bool.theory +let k_th_bool_config = Th_bool.k_config +let th_bool = Th_bool.theory +let th_bool_dyn : Solver.theory = Th_bool.theory_dyn +let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory + (* FIXME let th_lra : Solver.theory = Th_lra.theory *) diff --git a/src/base/dune b/src/base/dune index af6aa5f3..1e1c0c7c 100644 --- a/src/base/dune +++ b/src/base/dune @@ -4,5 +4,5 @@ (synopsis "Base term definitions for the standalone SMT solver and library") (libraries containers iter sidekick.core sidekick.util sidekick.smt-solver sidekick.cc sidekick.quip sidekick.th-lra sidekick.th-bool-static - sidekick.th-data sidekick.zarith zarith) + sidekick.th-bool-dyn sidekick.th-data sidekick.zarith zarith) (flags :standard -w +32 -open Sidekick_util)) diff --git a/src/base/th_bool.ml b/src/base/th_bool.ml index 3f2086a8..1a6663f7 100644 --- a/src/base/th_bool.ml +++ b/src/base/th_bool.ml @@ -1,8 +1,25 @@ (** Reducing boolean formulas to clauses *) -let theory : Solver.theory = +let k_config : [ `Dyn | `Static ] Config.Key.t = Config.Key.create () + +let theory_static : Solver.theory = Sidekick_th_bool_static.theory (module struct let view_as_bool = Form.view let mk_bool = Form.mk_of_view end : Sidekick_th_bool_static.ARG) + +let theory_dyn : Solver.theory = + Sidekick_th_bool_dyn.theory + (module struct + let view_as_bool = Form.view + let mk_bool = Form.mk_of_view + end : Sidekick_th_bool_static.ARG) + +let theory (conf : Config.t) : Solver.theory = + match Config.find k_config conf with + | Some `Dyn -> theory_dyn + | Some `Static -> theory_static + | None -> + (* default *) + theory_static diff --git a/src/main/main.ml b/src/main/main.ml index ca6f432d..9795fc2a 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -7,6 +7,7 @@ Copyright 2014 Simon Cruanes module E = CCResult module Fmt = CCFormat module Term = Sidekick_base.Term +module Config = Sidekick_base.Config module Solver = Sidekick_smtlib.Solver module Process = Sidekick_smtlib.Process module Proof = Sidekick_smtlib.Proof_trace @@ -23,7 +24,7 @@ let p_proof = ref false let p_model = ref false let check = ref false let time_limit = ref 300. -let size_limit = ref 1_000_000_000. +let mem_limit = ref 1_000_000_000. let restarts = ref true let gc = ref true let p_stat = ref false @@ -62,6 +63,7 @@ let int_arg r arg = let input_file s = file := s let usage = "Usage : main [options] " let version = "%%version%%" +let config = ref Config.empty let argspec = Arg.align @@ -90,12 +92,23 @@ let argspec = "-o", Arg.Set_string proof_file, " file into which to output a proof"; "--model", Arg.Set p_model, " print model"; "--no-model", Arg.Clear p_model, " do not print model"; + ( "--bool", + Arg.Symbol + ( [ "dyn"; "static" ], + function + | "dyn" -> + config := Config.add Sidekick_base.k_th_bool_config `Dyn !config + | "static" -> + config := + Config.add Sidekick_base.k_th_bool_config `Static !config + | _s -> failwith "unknown" ), + " configure bool theory" ); "--gc-stat", Arg.Set p_gc_stat, " outputs statistics about the GC"; "-p", Arg.Set p_progress, " print progress bar"; "--no-p", Arg.Clear p_progress, " no progress bar"; - ( "--size", - Arg.String (int_arg size_limit), - " [kMGT] sets the size limit for the sat solver" ); + ( "--memory", + Arg.String (int_arg mem_limit), + " [kMGT] sets the memory limit for the sat solver" ); ( "--time", Arg.String (int_arg time_limit), " [smhd] sets the time limit for the sat solver" ); @@ -118,10 +131,10 @@ let check_limits () = let s = float heap_size *. float Sys.word_size /. 8. in if t > !time_limit then raise Out_of_time - else if s > !size_limit then + else if s > !mem_limit then raise Out_of_space -let main_smt () : _ result = +let main_smt ~config () : _ result = let tst = Term.Store.create ~size:4_096 () in let enable_proof_ = !check || !p_proof || !proof_file <> "" in @@ -159,9 +172,14 @@ let main_smt () : _ result = let proof = Proof.dummy in let solver = + (* TODO: probes, to load only required theories *) let theories = - (* TODO: probes, to load only required theories *) - [ Process.th_bool; Process.th_data (* FIXME Process.th_lra *) ] + let th_bool = Process.th_bool config in + Log.debugf 1 (fun k -> + k "(@[main.th-bool.pick@ %S@])" + (Sidekick_smt_solver.Theory.name th_bool)); + Sidekick_smt_solver.Theory. + [ th_bool; Process.th_data (* FIXME Process.th_lra *) ] in Process.Solver.create_default ~proof ~theories tst in @@ -187,7 +205,7 @@ let main_smt () : _ result = E.fold_l (fun () -> Process.process_stmt ~gc:!gc ~restarts:!restarts ~pp_cnf:!p_cnf - ~time:!time_limit ~memory:!size_limit ~pp_model:!p_model ?proof_file + ~time:!time_limit ~memory:!mem_limit ~pp_model:!p_model ?proof_file ~check:!check ~progress:!p_progress solver) () input with Exit -> E.return () @@ -250,7 +268,7 @@ let main () = if is_cnf then main_cnf () else - main_smt () + main_smt ~config:!config () in Gc.delete_alarm al; res diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index d30a6790..b0820a9e 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -163,8 +163,14 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) let memory = Option.value ~default:4e9 memory in (* default: 4 GB *) let stop _ _ = - Sys.time () -. t1 > time - || (Gc.quick_stat ()).Gc.major_words *. 8. > memory + if Sys.time () -. t1 > time then ( + Log.debugf 0 (fun k -> k "timeout"); + true + ) else if (Gc.quick_stat ()).Gc.major_words *. 8. > memory then ( + Log.debugf 0 (fun k -> k "%S" "exceeded memory limit"); + true + ) else + false in Some stop in @@ -335,7 +341,9 @@ module Th_bool = Sidekick_base.Th_bool module Th_lra = Sidekick_base.Th_lra *) -let th_bool : Solver.theory = Th_bool.theory +let th_bool = Th_bool.theory +let th_bool_dyn : Solver.theory = Th_bool.theory_dyn +let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory (* FIXME let th_lra : Solver.theory = Th_lra.theory diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index b731a92a..25e83add 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -3,7 +3,9 @@ open Sidekick_base module Solver = Sidekick_base.Solver -val th_bool : Solver.theory +val th_bool_dyn : Solver.theory +val th_bool_static : Solver.theory +val th_bool : Config.t -> Solver.theory val th_data : Solver.theory (* FIXME val th_lra : Solver.theory diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 27680ae3..6f4ddd97 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -1,126 +1,354 @@ -(** {1 Theory of Booleans} *) +open Sidekick_core +module Intf = Intf +open Intf +module SI = SMT.Solver_internal +module Proof_rules = Proof_rules +module T = Term -(** {2 Signatures for booleans} *) -module View = struct - type 'a t = - | B_not of 'a - | B_and of 'a array - | B_or of 'a array - | B_imply of 'a array * '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 +module type ARG = Intf.ARG (** Theory with dynamic reduction to clauses *) -module Make_dyn_tseitin (A : ARG) = (* : S with module A = A *) -struct +module Make (A : ARG) : sig + val theory : SMT.theory +end = 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 state = { + tst: T.store; + expanded: unit Lit.Tbl.t; (* set of literals already expanded *) + n_simplify: int Stat.counter; + n_expanded: int Stat.counter; + n_clauses: int Stat.counter; + n_propagate: int Stat.counter; + } - type t = { expanded: unit T_tbl.t (* set of literals already expanded *) } + let create ~stat tst : state = + { + tst; + expanded = Lit.Tbl.create 256; + n_simplify = Stat.mk_int stat "th.bool.simplified"; + n_expanded = Stat.mk_int stat "th.bool.expanded"; + n_clauses = Stat.mk_int stat "th.bool.clauses"; + n_propagate = Stat.mk_int stat "th.bool.propagations"; + } - 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 + let[@inline] not_ tst t = A.mk_bool tst (B_not t) + let[@inline] eq tst a b = A.mk_bool tst (B_eq (a, b)) + let pp_c_ = Fmt.Dump.list Lit.pp + + let is_true t = + match T.as_bool_val t with + | Some true -> true + | _ -> false + + let is_false t = + match T.as_bool_val t with + | Some false -> true + | _ -> false + + (* TODO: share this with th-bool-static by way of a library for + boolean simplification? (also handle one-point rule and the likes) *) + let simplify (self : state) (simp : Simplify.t) (t : T.t) : + (T.t * Proof_step.id Iter.t) option = + let tst = self.tst in + + let proof = Simplify.proof simp in + let steps = ref [] in + let add_step_ s = steps := s :: !steps in + let mk_step_ r = Proof_trace.add_step proof r in + + let add_step_eq a b ~using ~c0 : unit = + add_step_ @@ mk_step_ + @@ fun () -> + Proof_core.lemma_rw_clause c0 ~using + ~res:[ Lit.atom (A.mk_bool tst (B_eq (a, b))) ] 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] *) - CCArray.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 = CCArray.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] *) - CCArray.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 = CCArray.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 = CCArray.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] *) - CCArray.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 = + let[@inline] ret u = + Stat.incr self.n_simplify; + Some (u, Iter.of_list !steps) + in + + (* proof is [t <=> u] *) + let ret_bequiv t1 u = + (add_step_ @@ mk_step_ @@ fun () -> Proof_rules.lemma_bool_equiv t1 u); + ret u + in + + match A.view_as_bool t with + | B_bool _ -> None + | B_not u when is_true u -> ret_bequiv t (T.false_ tst) + | B_not u when is_false u -> ret_bequiv t (T.true_ tst) + | B_not _ -> None + | B_atom _ -> None + | B_and (a, b) -> + if is_false a || is_false b then + ret (T.false_ tst) + else if is_true a && is_true b then + ret (T.true_ tst) + else + None + | B_or (a, b) -> + if is_true a || is_true b then + ret (T.true_ tst) + else if is_false a && is_false b then + ret (T.false_ tst) + else + None + | B_imply (a, b) -> + if is_false a || is_true b then + ret (T.true_ tst) + else if is_true a && is_false b then + ret (T.false_ tst) + else + None + | B_ite (a, b, c) -> + (* directly simplify [a] so that maybe we never will simplify one + of the branches *) + let a, prf_a = Simplify.normalize_t simp a in + Option.iter add_step_ prf_a; + (match A.view_as_bool a with + | B_bool true -> + add_step_eq t b ~using:(Option.to_list prf_a) + ~c0:(mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); + ret b + | B_bool false -> + add_step_eq t c ~using:(Option.to_list prf_a) + ~c0:(mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t); + ret c + | _ -> None) + | B_equiv (a, b) when is_true a -> ret_bequiv t b + | B_equiv (a, b) when is_false a -> ret_bequiv t (not_ tst b) + | B_equiv (a, b) when is_true b -> ret_bequiv t a + | B_equiv (a, b) when is_false b -> ret_bequiv t (not_ tst a) + | B_xor (a, b) when is_false a -> ret_bequiv t b + | B_xor (a, b) when is_true a -> ret_bequiv t (not_ tst b) + | B_xor (a, b) when is_false b -> ret_bequiv t a + | B_xor (a, b) when is_true b -> ret_bequiv t (not_ tst a) + | B_equiv _ | B_xor _ -> None + | B_eq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) + | B_neq (a, b) when T.equal a b -> ret_bequiv t (T.true_ tst) + | B_eq _ | B_neq _ -> None + + let[@inline] expanded self lit = Lit.Tbl.mem self.expanded lit + + let set_expanded self lit : unit = + if not (expanded self lit) then ( + Stat.incr self.n_expanded; + Lit.Tbl.add self.expanded lit () + ) + + (* preprocess. *) + let preprocess_ (self : state) (_si : SI.t) (module PA : SI.PREPROCESS_ACTS) + (t : T.t) : unit = + Log.debugf 50 (fun k -> k "(@[th-bool.dny.preprocess@ %a@])" T.pp_debug t); + let[@inline] mk_step_ r = Proof_trace.add_step PA.proof r in + + (match A.view_as_bool t with + | B_ite (a, b, c) -> + let lit_a = PA.mk_lit a in + Stat.incr self.n_clauses; + PA.add_clause + [ Lit.neg lit_a; PA.mk_lit (eq self.tst t b) ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); + + Stat.incr self.n_clauses; + PA.add_clause + [ lit_a; PA.mk_lit (eq self.tst t c) ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) + | _ -> ()); + () + + let tseitin ~final (self : state) solver (acts : SI.theory_actions) + (lit : Lit.t) (t : term) (v : term bool_view) : unit = + Log.debugf 50 (fun k -> k "(@[th-bool-dyn.tseitin@ %a@])" Lit.pp lit); + + let add_axiom c pr : unit = + Log.debugf 50 (fun k -> + k "(@[th-bool-dyn.add-axiom@ %a@ :expanding %a@])" pp_c_ c Lit.pp lit); + Stat.incr self.n_clauses; + set_expanded self lit; + SI.add_clause_permanent solver acts c pr + in + + let[@inline] mk_step_ r = Proof_trace.add_step (SI.proof solver) r in + + (* handle boolean equality *) + let equiv_ ~is_xor a b : unit = + (* [a xor b] is [(¬a) = b] *) + let a = + if is_xor then + Lit.neg a + else + a + in + + (* [lit => a<=> b], + [¬lit => a xor b] *) + add_axiom + [ Lit.neg lit; Lit.neg a; b ] + (if is_xor then + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e+" [ t ] + else + mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "eq-e" [ t; Lit.term a ]); + + add_axiom + [ Lit.neg lit; Lit.neg b; a ] + (if is_xor then + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "xor-e-" [ t ] + else + mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "eq-e" [ t; Lit.term b ]); + + add_axiom [ lit; a; b ] + (if is_xor then + mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "xor-i" [ t; Lit.term a ] + else + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i+" [ t ]); + + add_axiom + [ lit; Lit.neg a; Lit.neg b ] + (if is_xor then + mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "xor-i" [ t; Lit.term b ] + else + mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i-" [ t ]) + in + + match v with + | B_not _ -> () + | B_atom _ -> () (* CC will manage *) + | B_bool true -> () + | B_bool false -> + SI.add_clause_permanent solver acts + [ Lit.neg lit ] + (mk_step_ @@ fun () -> Proof_core.lemma_true (Lit.term lit)) + | _ when expanded self lit -> () (* already done *) + | B_and (a, b) -> + let subs = List.map Lit.atom [ a; b ] in + + if Lit.sign lit then + (* propagate [(and …t_i) => t_i] *) + List.iter + (fun sub -> + Stat.incr self.n_propagate; + SI.propagate_l solver acts sub [ lit ] + ( mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "and-e" [ t; Lit.term sub ] )) + subs + else if final then ( + (* axiom [¬(and …t_i)=> \/_i (¬ t_i)], only in final-check *) + let c = Lit.neg lit :: List.map Lit.neg subs in + add_axiom c + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) + ) + | B_or (a, b) -> + let subs = List.map Lit.atom [ a; b ] in + + if not @@ Lit.sign lit then + (* propagate [¬sub_i \/ lit] *) + List.iter + (fun sub -> + Stat.incr self.n_propagate; + SI.propagate_l solver acts (Lit.neg sub) [ lit ] + ( mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "or-i" [ t; Lit.term sub ] )) + subs + else if final then ( + (* axiom [lit => \/_i subs_i] *) + let c = Lit.neg lit :: subs in + add_axiom c (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) + ) + | B_imply (a, b) -> + let a = Lit.atom a in + let b = Lit.atom b in + if Lit.sign lit && final then ( + (* axiom [lit => a => b] *) + let c = [ Lit.neg lit; Lit.neg a; b ] in + add_axiom c + (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-e" [ t ]) + ) else if not @@ Lit.sign lit then ( + (* propagate [¬ lit => ¬b] and [¬lit => a] *) + Stat.incr self.n_propagate; + SI.propagate_l solver acts a [ lit ] + ( mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "imp-i" [ t; Lit.term a ] ); + + Stat.incr self.n_propagate; + SI.propagate_l solver acts (Lit.neg b) [ lit ] + ( mk_step_ @@ fun () -> + Proof_rules.lemma_bool_c "imp-i" [ t; Lit.term b ] ) + ) + | B_ite (a, b, c) -> + assert (T.is_bool b); + if final then ( + (* boolean ite: + just add [a => (ite a b c <=> b)] + and [¬a => (ite a b c <=> c)] *) + let lit_a = Lit.atom a in + add_axiom + [ Lit.neg lit_a; Lit.make_eq self.tst t b ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); + add_axiom + [ Lit.neg lit; lit_a; Lit.make_eq self.tst t c ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) + ) + | B_equiv (a, b) -> + let a = Lit.atom a in + let b = Lit.atom b in + equiv_ ~is_xor:false a b + | B_eq (a, b) when T.is_bool a -> + let a = Lit.atom a in + let b = Lit.atom b in + equiv_ ~is_xor:false a b + | B_xor (a, b) -> + let a = Lit.atom a in + let b = Lit.atom b in + equiv_ ~is_xor:true a b + | B_neq (a, b) when T.is_bool a -> + let a = Lit.atom a in + let b = Lit.atom b in + equiv_ ~is_xor:true a b + | B_eq _ | B_neq _ -> () + + let check_ ~final self solver acts 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) + | v -> tseitin ~final self solver acts lit t v) - let partial_check (self : t) acts (lits : Lit.t Iter.t) = - check_ ~final:false self acts lits + let partial_check (self : state) solver acts (lits : Lit.t Iter.t) = + check_ ~final:false self solver acts lits - let final_check (self : t) acts (lits : Lit.t Iter.t) = - check_ ~final:true self acts lits + let final_check (self : state) solver acts (lits : Lit.t Iter.t) = + check_ ~final:true self solver acts lits - let create_and_setup (solver : SI.t) : t = - let self = { expanded = T_tbl.create 24 } in + let create_and_setup (solver : SI.t) : state = + let tst = SI.tst solver in + let stat = SI.stats solver in + let self = + { + tst; + expanded = Lit.Tbl.create 24; + n_expanded = Stat.mk_int stat "th.bool.dyn.expanded"; + n_clauses = Stat.mk_int stat "th.bool.dyn.clauses"; + n_propagate = Stat.mk_int stat "th.bool.dyn.propagate"; + n_simplify = Stat.mk_int stat "th.bool.dyn.simplify"; + } + in + SI.on_preprocess solver (preprocess_ self); 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 () + let theory = SMT.Solver.mk_theory ~name:"th-bool.dyn" ~create_and_setup () end + +let theory (module A : ARG) : SMT.theory = + let module M = Make (A) in + M.theory diff --git a/src/th-bool-dyn/dune.bak b/src/th-bool-dyn/dune.bak deleted file mode 100644 index b0fc4dd6..00000000 --- a/src/th-bool-dyn/dune.bak +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name Sidekick_th_bool_dyn) - (public_name sidekick.th-bool-dyn) - (libraries containers sidekick.core sidekick.util) - (flags :standard -open Sidekick_util)) - diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 13772a56..fa0bf125 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -270,7 +270,7 @@ end = struct SI.on_preprocess si (cnf st); st - let theory = SMT.Solver.mk_theory ~name:"th-bool" ~create_and_setup () + let theory = SMT.Solver.mk_theory ~name:"th-bool.static" ~create_and_setup () end let theory (module A : ARG) : SMT.theory = From e4acb2cfcad0a7c8769585a31912ab3f86eb38af Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:35:13 -0400 Subject: [PATCH 120/174] fix(th-bool-dyn): add clauses in partial check; register simplifier --- src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 40 ++++++++++++------------- 1 file changed, 19 insertions(+), 21 deletions(-) diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 6f4ddd97..7da0f993 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -161,7 +161,7 @@ end = struct | _ -> ()); () - let tseitin ~final (self : state) solver (acts : SI.theory_actions) + let tseitin ~final:_ (self : state) solver (acts : SI.theory_actions) (lit : Lit.t) (t : term) (v : term bool_view) : unit = Log.debugf 50 (fun k -> k "(@[th-bool-dyn.tseitin@ %a@])" Lit.pp lit); @@ -240,7 +240,7 @@ end = struct ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-e" [ t; Lit.term sub ] )) subs - else if final then ( + else ( (* axiom [¬(and …t_i)=> \/_i (¬ t_i)], only in final-check *) let c = Lit.neg lit :: List.map Lit.neg subs in add_axiom c @@ -258,7 +258,7 @@ end = struct ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-i" [ t; Lit.term sub ] )) subs - else if final then ( + else ( (* axiom [lit => \/_i subs_i] *) let c = Lit.neg lit :: subs in add_axiom c (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) @@ -266,37 +266,35 @@ end = struct | B_imply (a, b) -> let a = Lit.atom a in let b = Lit.atom b in - if Lit.sign lit && final then ( + if Lit.sign lit then ( (* axiom [lit => a => b] *) let c = [ Lit.neg lit; Lit.neg a; b ] in add_axiom c (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-e" [ t ]) ) else if not @@ Lit.sign lit then ( (* propagate [¬ lit => ¬b] and [¬lit => a] *) - Stat.incr self.n_propagate; - SI.propagate_l solver acts a [ lit ] + add_axiom + [ a; Lit.neg lit ] ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-i" [ t; Lit.term a ] ); - Stat.incr self.n_propagate; - SI.propagate_l solver acts (Lit.neg b) [ lit ] + add_axiom + [ Lit.neg b; Lit.neg lit ] ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "imp-i" [ t; Lit.term b ] ) ) | B_ite (a, b, c) -> assert (T.is_bool b); - if final then ( - (* boolean ite: - just add [a => (ite a b c <=> b)] - and [¬a => (ite a b c <=> c)] *) - let lit_a = Lit.atom a in - add_axiom - [ Lit.neg lit_a; Lit.make_eq self.tst t b ] - (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); - add_axiom - [ Lit.neg lit; lit_a; Lit.make_eq self.tst t c ] - (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) - ) + (* boolean ite: + just add [a => (ite a b c <=> b)] + and [¬a => (ite a b c <=> c)] *) + let lit_a = Lit.atom a in + add_axiom + [ Lit.neg lit_a; Lit.make_eq self.tst t b ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); + add_axiom + [ Lit.neg lit; lit_a; Lit.make_eq self.tst t c ] + (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) | B_equiv (a, b) -> let a = Lit.atom a in let b = Lit.atom b in @@ -337,10 +335,10 @@ end = struct expanded = Lit.Tbl.create 24; n_expanded = Stat.mk_int stat "th.bool.dyn.expanded"; n_clauses = Stat.mk_int stat "th.bool.dyn.clauses"; - n_propagate = Stat.mk_int stat "th.bool.dyn.propagate"; n_simplify = Stat.mk_int stat "th.bool.dyn.simplify"; } in + SI.add_simplifier solver (simplify self); SI.on_preprocess solver (preprocess_ self); SI.on_final_check solver (final_check self); SI.on_partial_check solver (partial_check self); From b61ec3545141c99f288d32ac7801c071acd0f125 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:37:56 -0400 Subject: [PATCH 121/174] fix(th-bool-dyn): do not propagate, just add clauses depending on polarity --- src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 7da0f993..86c7d46d 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -21,7 +21,6 @@ end = struct n_simplify: int Stat.counter; n_expanded: int Stat.counter; n_clauses: int Stat.counter; - n_propagate: int Stat.counter; } let create ~stat tst : state = @@ -31,7 +30,6 @@ end = struct n_simplify = Stat.mk_int stat "th.bool.simplified"; n_expanded = Stat.mk_int stat "th.bool.expanded"; n_clauses = Stat.mk_int stat "th.bool.clauses"; - n_propagate = Stat.mk_int stat "th.bool.propagations"; } let[@inline] not_ tst t = A.mk_bool tst (B_not t) @@ -232,11 +230,11 @@ end = struct let subs = List.map Lit.atom [ a; b ] in if Lit.sign lit then - (* propagate [(and …t_i) => t_i] *) + (* assert [(and …t_i) => t_i] *) List.iter (fun sub -> - Stat.incr self.n_propagate; - SI.propagate_l solver acts sub [ lit ] + add_axiom + [ Lit.neg lit; sub ] ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-e" [ t; Lit.term sub ] )) subs @@ -253,8 +251,8 @@ end = struct (* propagate [¬sub_i \/ lit] *) List.iter (fun sub -> - Stat.incr self.n_propagate; - SI.propagate_l solver acts (Lit.neg sub) [ lit ] + add_axiom + [ Lit.neg lit; Lit.neg sub ] ( mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-i" [ t; Lit.term sub ] )) subs From b23a031519d21da3efac7f73217a82a188e0e20a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:45:16 -0400 Subject: [PATCH 122/174] fix: time measurements were wrong --- src/smtlib/Process.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index b0820a9e..f7f23471 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -146,7 +146,7 @@ let with_file_out (file : string) (f : out_channel -> 'a) : 'a = (* call the solver to check-sat *) let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) ?time ?memory ?(progress = false) ~assumptions s : Solver.res = - let t1 = Sys.time () -. start in + let t1 = Sys.time () in let on_progress = if progress then Some (mk_progress s) @@ -194,9 +194,9 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) CCOpt.iter (fun h -> check_smt_model (Solver.solver s) h m) hyps; ); *) - let t3 = Sys.time () -. t2 in + let t3 = Sys.time () in Fmt.printf "sat@."; - Fmt.printf "; (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 + Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unsat { unsat_step_id; unsat_core = _ } -> if check then () @@ -227,9 +227,9 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) flush oc) | _ -> ()); - let t3 = Sys.time () -. t2 in + let t3 = Sys.time () in Fmt.printf "unsat@."; - Fmt.printf "; (%.3f/%.3f/%.3f)@." t1 (t2 -. t1) t3 + Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unknown reas -> Fmt.printf "unknown@."; Fmt.printf "; @[:reason %a@]@." Solver.Unknown.pp reas From a446af49be66752ad048c4edfddcf55c41f1dda1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:58:00 -0400 Subject: [PATCH 123/174] doc --- src/simplify/sidekick_simplify.mli | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/simplify/sidekick_simplify.mli b/src/simplify/sidekick_simplify.mli index 1c3abf1a..43ee9e54 100644 --- a/src/simplify/sidekick_simplify.mli +++ b/src/simplify/sidekick_simplify.mli @@ -18,13 +18,13 @@ val proof : t -> Proof_trace.t type hook = t -> Term.t -> (Term.t * Proof_step.id Iter.t) option (** Given a Term.t, try to simplify it. Return [None] if it didn't change. - A simple example could be a hook that takes a Term.t [t], - and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, - returns [Some (const (x+y))], and [None] otherwise. + A simple example could be a hook that takes a Term.t [t], + and if [t] is [app "+" (const x) (const y)] where [x] and [y] are number, + returns [Some (const (x+y))], and [None] otherwise. - The simplifier will take care of simplifying the resulting Term.t further, - caching (so that work is not duplicated in subterms), etc. - *) + The simplifier will take care of simplifying the resulting Term.t further, + caching (so that work is not duplicated in subterms), etc. +*) val add_hook : t -> hook -> unit From b7eb6749a1c3fe67b030244c2ae2b3089f4b654c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 21:58:38 -0400 Subject: [PATCH 124/174] add missing files from th-bool-dyn --- src/th-bool-dyn/Sidekick_th_bool_dyn.mli | 15 ++++++++++++ src/th-bool-dyn/dune | 6 +++++ src/th-bool-dyn/intf.ml | 29 ++++++++++++++++++++++++ src/th-bool-dyn/proof_rules.ml | 19 ++++++++++++++++ src/th-bool-dyn/proof_rules.mli | 20 ++++++++++++++++ 5 files changed, 89 insertions(+) create mode 100644 src/th-bool-dyn/Sidekick_th_bool_dyn.mli create mode 100644 src/th-bool-dyn/dune create mode 100644 src/th-bool-dyn/intf.ml create mode 100644 src/th-bool-dyn/proof_rules.ml create mode 100644 src/th-bool-dyn/proof_rules.mli diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.mli b/src/th-bool-dyn/Sidekick_th_bool_dyn.mli new file mode 100644 index 00000000..d2b03160 --- /dev/null +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.mli @@ -0,0 +1,15 @@ +(** Theory of boolean formulas. + + This handles formulas containing "and", "or", "=>", "if-then-else", etc. + + The difference with {!Sidekick_th_bool_static} is that here, clausification + of a formula [F] is done only when [F] is on the trail. +*) + +module Intf = Intf +module Proof_rules = Proof_rules +open Intf + +module type ARG = Intf.ARG + +val theory : (module ARG) -> SMT.Theory.t diff --git a/src/th-bool-dyn/dune b/src/th-bool-dyn/dune new file mode 100644 index 00000000..a6a7af8c --- /dev/null +++ b/src/th-bool-dyn/dune @@ -0,0 +1,6 @@ +(library + (name Sidekick_th_bool_dyn) + (public_name sidekick.th-bool-dyn) + (libraries containers sidekick.core sidekick.smt-solver sidekick.util + sidekick.simplify) + (flags :standard -open Sidekick_util)) diff --git a/src/th-bool-dyn/intf.ml b/src/th-bool-dyn/intf.ml new file mode 100644 index 00000000..1e36c444 --- /dev/null +++ b/src/th-bool-dyn/intf.ml @@ -0,0 +1,29 @@ +open Sidekick_core +module SMT = Sidekick_smt_solver +module Simplify = Sidekick_simplify + +type term = Term.t +type ty = Term.t + +(** Boolean-oriented view of terms *) +type 'a bool_view = 'a Bool_view.t = + | B_bool of bool + | B_not of 'a + | B_and of 'a * 'a + | B_or of 'a * 'a + | B_imply of 'a * 'a + | B_equiv of 'a * 'a + | B_xor of 'a * 'a + | B_eq of 'a * 'a + | B_neq of 'a * 'a + | B_ite of 'a * 'a * 'a + | B_atom of 'a + +(** Argument to the theory *) +module type ARG = sig + val view_as_bool : term -> term bool_view + (** Project the term into the boolean view. *) + + val mk_bool : Term.store -> term bool_view -> term + (** Make a term from the given boolean view. *) +end diff --git a/src/th-bool-dyn/proof_rules.ml b/src/th-bool-dyn/proof_rules.ml new file mode 100644 index 00000000..82288385 --- /dev/null +++ b/src/th-bool-dyn/proof_rules.ml @@ -0,0 +1,19 @@ +open Sidekick_core + +type term = Term.t +type lit = Lit.t + +let lemma_bool_tauto lits : Proof_term.t = + Proof_term.apply_rule "bool.tauto" ~lits + +let lemma_bool_c name terms : Proof_term.t = + Proof_term.apply_rule ("bool.c." ^ name) ~terms + +let lemma_bool_equiv t u : Proof_term.t = + Proof_term.apply_rule "bool.equiv" ~terms:[ t; u ] + +let lemma_ite_true ~ite : Proof_term.t = + Proof_term.apply_rule "bool.ite.true" ~terms:[ ite ] + +let lemma_ite_false ~ite : Proof_term.t = + Proof_term.apply_rule "bool.ite.false" ~terms:[ ite ] diff --git a/src/th-bool-dyn/proof_rules.mli b/src/th-bool-dyn/proof_rules.mli new file mode 100644 index 00000000..0379b4c5 --- /dev/null +++ b/src/th-bool-dyn/proof_rules.mli @@ -0,0 +1,20 @@ +open Sidekick_core + +type term = Term.t +type lit = Lit.t + +val lemma_bool_tauto : lit list -> Proof_term.t +(** Boolean tautology lemma (clause) *) + +val lemma_bool_c : string -> term list -> Proof_term.t +(** Basic boolean logic lemma for a clause [|- c]. + [proof_bool_c b name cs] is the Proof_term.t designated by [name]. *) + +val lemma_bool_equiv : term -> term -> Proof_term.t +(** Boolean tautology lemma (equivalence) *) + +val lemma_ite_true : ite:term -> Proof_term.t +(** lemma [a ==> ite a b c = b] *) + +val lemma_ite_false : ite:term -> Proof_term.t +(** lemma [¬a ==> ite a b c = c] *) From 6a4947a25c3307614c5c5ce9df4cd26039ad9d9a Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 23:21:07 -0400 Subject: [PATCH 125/174] feat(term): printer --- src/core-logic/term.ml | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 5147cf08..d477e588 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -53,7 +53,7 @@ let unfold_app (e : term) : term * term list = (* debug printer *) let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = let rec loop k ~depth names out e = - let pp' = loop' k ~depth:(depth + 1) names in + let pp' = loop k ~depth:(depth + 1) names in (match e.view with | E_type 0 -> Fmt.string out "Type" | E_type i -> Fmt.fprintf out "Type(%d)" i @@ -69,7 +69,7 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = Fmt.fprintf out "@<1>…/%d" e.id | E_app _ -> let f, args = unfold_app e in - Fmt.fprintf out "%a@ %a" pp' f (Util.pp_list pp') args + Fmt.fprintf out "(%a@ %a)" pp' f (Util.pp_list pp') args | E_lam ("", _ty, bod) -> Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) @@ -94,12 +94,6 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = (loop (k + 1) ~depth:(depth + 1) (n :: names)) bod); if pp_ids then Fmt.fprintf out "/%d" e.id - and loop' k ~depth names out e = - match e.view with - | E_type _ | E_var _ | E_bound_var _ | E_const _ -> - loop k ~depth names out e (* atomic expr *) - | E_app _ | E_lam _ | E_pi _ -> - Fmt.fprintf out "(%a)" (loop k ~depth names) e in Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e From 663f291bd5979edd069b34dce011f41fa83a09c3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 23:25:44 -0400 Subject: [PATCH 126/174] port fix for bug introduced in 1946a5e7 --- src/smt/solver_internal.ml | 67 ++++++++++++++++++++++---------------- 1 file changed, 39 insertions(+), 28 deletions(-) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index bf5adae7..08d51ad3 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -79,6 +79,9 @@ let simplify_t self (t : Term.t) : _ option = Simplify.normalize self.simp t let simp_t self (t : Term.t) : Term.t * _ = Simplify.normalize_t self.simp t let add_simplifier (self : t) f : unit = Simplify.add_hook self.simp f +let[@inline] has_delayed_actions self = + not (Queue.is_empty self.delayed_actions) + let on_th_combination self f = self.on_th_combination <- f :: self.on_th_combination @@ -490,37 +493,45 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) List.iter (fun f -> f self acts lits) self.on_final_check; check_cc_with_acts_ self acts; - (match check_th_combination_ self acts lits with - | Ok m -> self.last_model <- Some m - | Error { lits; semantic } -> - (* bad model, we add a clause to remove it *) - Log.debugf 5 (fun k -> - k "(@[solver.th-comb.conflict@ :lits (@[%a@])@ :same-val (@[%a@])@])" - (Util.pp_list Lit.pp) lits - (Util.pp_list @@ Fmt.Dump.(triple bool Term.pp_debug Term.pp_debug)) - semantic); + let new_work = has_delayed_actions self in - let c1 = List.rev_map Lit.neg lits in - let c2 = - semantic - |> List.rev_map (fun (sign, t, u) -> - let eqn = Term.eq self.tst t u in - let lit = Lit.atom ~sign:(not sign) eqn in - (* make sure to consider the new lit *) - add_lit self acts lit; - lit) - in + (* do actual theory combination if nothing changed by pure "final check" *) + if not new_work then ( + match check_th_combination_ self acts lits with + | Ok m -> self.last_model <- Some m + | Error { lits; semantic } -> + (* bad model, we add a clause to remove it *) + Log.debugf 5 (fun k -> + k + "(@[solver.th-comb.conflict@ :lits (@[%a@])@ :same-val \ + (@[%a@])@])" + (Util.pp_list Lit.pp) lits + (Util.pp_list + @@ Fmt.Dump.(triple bool Term.pp_debug Term.pp_debug)) + semantic); - let c = List.rev_append c1 c2 in - let pr = - Proof_trace.add_step self.proof @@ fun () -> Proof_core.lemma_cc c - in + let c1 = List.rev_map Lit.neg lits in + let c2 = + semantic + |> List.rev_map (fun (sign, t, u) -> + let eqn = Term.eq self.tst t u in + let lit = Lit.atom ~sign:(not sign) eqn in + (* make sure to consider the new lit *) + add_lit self acts lit; + lit) + in - Log.debugf 20 (fun k -> - k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" - (Util.pp_list Lit.pp) c); - (* will add a delayed action *) - add_clause_temp self acts c pr); + let c = List.rev_append c1 c2 in + let pr = + Proof_trace.add_step self.proof @@ fun () -> Proof_core.lemma_cc c + in + + Log.debugf 20 (fun k -> + k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" + (Util.pp_list Lit.pp) c); + (* will add a delayed action *) + add_clause_temp self acts c pr + ); Perform_delayed_th.top self acts ) else ( From 27ccd367b23979348ad59b4b2c6dcd24dc52213f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 16 Aug 2022 23:34:08 -0400 Subject: [PATCH 127/174] fix output so benchpress can parse it --- src/smtlib/Process.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index f7f23471..6fd22930 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -195,7 +195,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) ); *) let t3 = Sys.time () in - Fmt.printf "sat@."; + Fmt.printf "@.sat@."; Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unsat { unsat_step_id; unsat_core = _ } -> if check then @@ -228,7 +228,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) | _ -> ()); let t3 = Sys.time () in - Fmt.printf "unsat@."; + Fmt.printf "@.unsat@."; Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unknown reas -> Fmt.printf "unknown@."; From 1b0d47a01dd24b670be9d8f8ef38d3bed2b7867e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Aug 2022 20:56:17 -0400 Subject: [PATCH 128/174] feat(profile): add basic counters --- src/tef/Sidekick_tef.real.ml | 15 +++++++++++++++ src/util/Profile.ml | 10 ++++++++++ src/util/Profile.mli | 2 ++ 3 files changed, 27 insertions(+) diff --git a/src/tef/Sidekick_tef.real.ml b/src/tef/Sidekick_tef.real.ml index 0285da98..60b4193a 100644 --- a/src/tef/Sidekick_tef.real.ml +++ b/src/tef/Sidekick_tef.real.ml @@ -59,6 +59,21 @@ module Make () : P.BACKEND = struct pid tid ts name; () + let emit_count_event ~name ~ts (cs : _ list) : unit = + let pid = Unix.getpid () in + let tid = Thread.id (Thread.self ()) in + emit_sep_ (); + Printf.fprintf oc + {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":"%s","ph":"C","args":{|json} + pid tid ts name; + List.iteri + (fun i (n, value) -> + if i > 0 then Printf.fprintf oc ","; + Printf.fprintf oc {json|"%s":%d|json} n value) + cs; + Printf.fprintf oc {json|}}|json}; + () + let teardown () = teardown_ oc end diff --git a/src/util/Profile.ml b/src/util/Profile.ml index 7c55409f..6124726d 100644 --- a/src/util/Profile.ml +++ b/src/util/Profile.ml @@ -5,6 +5,7 @@ module type BACKEND = sig name:string -> start:float -> end_:float -> unit -> unit val emit_instant_event : name:string -> ts:float -> unit -> unit + val emit_count_event : name:string -> ts:float -> (string * int) list -> unit val teardown : unit -> unit end @@ -36,6 +37,15 @@ let[@inline] instant name = let now = B.get_ts () in B.emit_instant_event ~name ~ts:now () +let[@inline] count name cs = + if cs <> [] then ( + match !out_ with + | None -> () + | Some (module B) -> + let now = B.get_ts () in + B.emit_count_event ~name ~ts:now cs + ) + (* slow path *) let[@inline never] exit_full_ (module B : BACKEND) name start = let now = B.get_ts () in diff --git a/src/util/Profile.mli b/src/util/Profile.mli index e1e0e054..11603d9d 100644 --- a/src/util/Profile.mli +++ b/src/util/Profile.mli @@ -14,6 +14,7 @@ val exit : probe -> unit val with_ : string -> (unit -> 'a) -> 'a val with1 : string -> ('a -> 'b) -> 'a -> 'b val with2 : string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c +val count : string -> (string * int) list -> unit module type BACKEND = sig val get_ts : unit -> float @@ -22,6 +23,7 @@ module type BACKEND = sig name:string -> start:float -> end_:float -> unit -> unit val emit_instant_event : name:string -> ts:float -> unit -> unit + val emit_count_event : name:string -> ts:float -> (string * int) list -> unit val teardown : unit -> unit end From 0c658e3ee47f858a4a645a616e871a95e923bf92 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Aug 2022 22:01:41 -0400 Subject: [PATCH 129/174] feat(term): add replace --- src/core-logic/term.ml | 52 ++++++++++++++++++++++++----------------- src/core-logic/term.mli | 11 +++++++++ 2 files changed, 42 insertions(+), 21 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index d477e588..dee2d459 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -478,13 +478,14 @@ module Make_ = struct let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l + type cache = t T_int_tbl.t + + let create_cache : int -> cache = T_int_tbl.create + (* general substitution, compatible with DB indices. We use this also to abstract on a free variable, because it subsumes it and it's better to minimize the number of DB indices manipulations *) - let subst_ ~make ~recursive e0 (subst : subst) : t = - (* cache for types and some terms *) - let cache_ = T_int_tbl.create 16 in - + let replace_ ?(cache = create_cache 8) ~make ~recursive e0 ~f : t = let rec loop k e = if is_type e then e @@ -492,27 +493,15 @@ module Make_ = struct (* no free variables, cannot change *) e else ( - try T_int_tbl.find cache_ (e, k) + try T_int_tbl.find cache (e, k) with Not_found -> let r = loop_uncached_ k e in - T_int_tbl.add cache_ (e, k) r; + T_int_tbl.add cache (e, k) r; r ) and loop_uncached_ k (e : t) : t = - match view e with - | E_var v -> - (* first, subst in type *) - let v = { v with v_ty = loop k v.v_ty } in - (match Var_.Map.find v subst.m with - | u -> - let u = db_shift_ ~make u k in - if recursive then - loop 0 u - else - u - | exception Not_found -> make (E_var v)) - | E_const _ -> e - | _ -> + match f ~recurse:(loop k) e with + | None -> map_shallow_ e ~make ~f:(fun inb u -> loop (if inb then @@ -520,12 +509,26 @@ module Make_ = struct else k) u) + | Some u -> + let u = db_shift_ ~make u k in + if recursive then + loop 0 u + else + u in + loop 0 e0 + let subst_ ~make ~recursive e0 (subst : subst) : t = if Var_.Map.is_empty subst.m then e0 else - loop 0 e0 + replace_ ~make ~recursive e0 ~f:(fun ~recurse e -> + match view e with + | E_var v -> + (* first, subst in type *) + let v = { v with v_ty = recurse v.v_ty } in + Var_.Map.find_opt v subst.m + | _ -> None) module DB = struct let subst_db0 store e ~by : t = db_0_replace_ ~make:(make_ store) e ~by @@ -603,6 +606,13 @@ let map_shallow store ~f e : t = map_shallow_ ~make:(make_ store) ~f e (* re-export some internal things *) module Internal_ = struct + type nonrec cache = cache + + let create_cache = create_cache + + let replace_ ?cache store ~recursive t ~f = + replace_ ?cache ~make:(make_ store) ~recursive t ~f + let subst_ store ~recursive t subst = subst_ ~make:(make_ store) ~recursive t subst end diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index cf277f73..c6adfc0a 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -159,7 +159,18 @@ end (**/**) module Internal_ : sig + type cache + + val create_cache : int -> cache val subst_ : store -> recursive:bool -> t -> subst -> t + + val replace_ : + ?cache:cache -> + store -> + recursive:bool -> + t -> + f:(recurse:(t -> t) -> t -> t option) -> + t end (**/**) From 2bd555d11b8086287d78db68741ab70fdf6a2688 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Aug 2022 22:02:36 -0400 Subject: [PATCH 130/174] feat(profile): proper string handling --- src/tef/Sidekick_tef.real.ml | 54 +++++++++++++++++++++++++++--------- src/util/Profile.ml | 8 ++++-- src/util/Profile.mli | 6 ++-- 3 files changed, 50 insertions(+), 18 deletions(-) diff --git a/src/tef/Sidekick_tef.real.ml b/src/tef/Sidekick_tef.real.ml index 60b4193a..163c4bce 100644 --- a/src/tef/Sidekick_tef.real.ml +++ b/src/tef/Sidekick_tef.real.ml @@ -39,6 +39,28 @@ module Make () : P.BACKEND = struct else output_string oc ",\n" + let char = output_char + let raw_string = output_string + let int oc i = Printf.fprintf oc "%d" i + + let str_val oc (s : string) = + char oc '"'; + let encode_char c = + match c with + | '"' -> raw_string oc {|\"|} + | '\\' -> raw_string oc {|\\|} + | '\n' -> raw_string oc {|\n|} + | '\b' -> raw_string oc {|\b|} + | '\r' -> raw_string oc {|\r|} + | '\t' -> raw_string oc {|\t|} + | _ when Char.code c <= 0x1f -> + raw_string oc {|\u00|}; + Printf.fprintf oc "%02x" (Char.code c) + | c -> char oc c + in + String.iter encode_char s; + char oc '"' + let emit_duration_event ~name ~start ~end_ () : unit = let dur = end_ -. start in let ts = start in @@ -46,17 +68,29 @@ module Make () : P.BACKEND = struct let tid = Thread.id (Thread.self ()) in emit_sep_ (); Printf.fprintf oc - {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":"%s","ph":"X"}|json} - pid tid dur ts name; + {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"}|json} + pid tid dur ts str_val name; () - let emit_instant_event ~name ~ts () : unit = + (* emit args, if not empty. [ppv] is used to print values. *) + let emit_args_o_ ppv oc args : unit = + if args <> [] then ( + Printf.fprintf oc {json|,"args": {|json}; + List.iteri + (fun i (n, value) -> + if i > 0 then Printf.fprintf oc ","; + Printf.fprintf oc {json|"%s":%a|json} n ppv value) + args; + char oc '}' + ) + + let emit_instant_event ~name ~ts ~args () : unit = let pid = Unix.getpid () in let tid = Thread.id (Thread.self ()) in emit_sep_ (); Printf.fprintf oc - {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":"%s","ph":"I"}|json} - pid tid ts name; + {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"I"%a}|json} + pid tid ts str_val name (emit_args_o_ str_val) args; () let emit_count_event ~name ~ts (cs : _ list) : unit = @@ -64,14 +98,8 @@ module Make () : P.BACKEND = struct let tid = Thread.id (Thread.self ()) in emit_sep_ (); Printf.fprintf oc - {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":"%s","ph":"C","args":{|json} - pid tid ts name; - List.iteri - (fun i (n, value) -> - if i > 0 then Printf.fprintf oc ","; - Printf.fprintf oc {json|"%s":%d|json} n value) - cs; - Printf.fprintf oc {json|}}|json}; + {json|{"pid": %d,"cat":"","tid": %d,"ts": %.2f,"name":%a,"ph":"C"%a}|json} + pid tid ts str_val name (emit_args_o_ int) cs; () let teardown () = teardown_ oc diff --git a/src/util/Profile.ml b/src/util/Profile.ml index 6124726d..5da6abf9 100644 --- a/src/util/Profile.ml +++ b/src/util/Profile.ml @@ -4,7 +4,9 @@ module type BACKEND = sig val emit_duration_event : name:string -> start:float -> end_:float -> unit -> unit - val emit_instant_event : name:string -> ts:float -> unit -> unit + val emit_instant_event : + name:string -> ts:float -> args:(string * string) list -> unit -> unit + val emit_count_event : name:string -> ts:float -> (string * int) list -> unit val teardown : unit -> unit end @@ -30,12 +32,12 @@ let[@inline] begin_ name : probe = | None -> No_probe | Some b -> begin_with_ b name -let[@inline] instant name = +let[@inline] instant ?(args = []) name = match !out_ with | None -> () | Some (module B) -> let now = B.get_ts () in - B.emit_instant_event ~name ~ts:now () + B.emit_instant_event ~name ~ts:now ~args () let[@inline] count name cs = if cs <> [] then ( diff --git a/src/util/Profile.mli b/src/util/Profile.mli index 11603d9d..b563ea6f 100644 --- a/src/util/Profile.mli +++ b/src/util/Profile.mli @@ -8,7 +8,7 @@ type probe val null_probe : probe val enabled : unit -> bool -val instant : string -> unit +val instant : ?args:(string * string) list -> string -> unit val begin_ : string -> probe val exit : probe -> unit val with_ : string -> (unit -> 'a) -> 'a @@ -22,7 +22,9 @@ module type BACKEND = sig val emit_duration_event : name:string -> start:float -> end_:float -> unit -> unit - val emit_instant_event : name:string -> ts:float -> unit -> unit + val emit_instant_event : + name:string -> ts:float -> args:(string * string) list -> unit -> unit + val emit_count_event : name:string -> ts:float -> (string * int) list -> unit val teardown : unit -> unit end From a21389063aa328685e625a2a111c47ab19acb731 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Aug 2022 22:02:52 -0400 Subject: [PATCH 131/174] feat(log): if Profile is enabled, forward messages to it --- src/util/Log.ml | 17 +++++++++++++++-- src/util/dune | 2 +- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/src/util/Log.ml b/src/util/Log.ml index 9aa129fb..0a116641 100644 --- a/src/util/Log.ml +++ b/src/util/Log.ml @@ -7,12 +7,25 @@ let set_debug l = debug_level_ := l let get_debug () = !debug_level_ let debug_fmt_ = ref Format.err_formatter let set_debug_out f = debug_fmt_ := f +let buf_ = Buffer.create 128 +let buf_fmt_ = Format.formatter_of_buffer buf_ +let start_ = Unix.gettimeofday () (* does the printing, inconditionally *) let[@inline never] debug_real_ l k = k (fun fmt -> - Format.fprintf !debug_fmt_ "@[<2>@{[%d|%.3f]@}@ " l (Sys.time ()); - Format.kfprintf (fun fmt -> Format.fprintf fmt "@]@.") !debug_fmt_ fmt) + let now = Unix.gettimeofday () -. start_ in + Buffer.clear buf_; + let once_done _fmt = + Format.fprintf _fmt "@]@?"; + let msg = Buffer.contents buf_ in + (* forward to profiling *) + if Profile.enabled () then Profile.instant msg; + Format.fprintf !debug_fmt_ "@[<2>@{[%d|%.3f]@}@ %s@]@." l now msg + in + + Format.fprintf buf_fmt_ "@[<2>"; + Format.kfprintf once_done buf_fmt_ fmt) let[@inline] debugf l k = if enabled && l <= !debug_level_ then debug_real_ l k let[@inline] debug l msg = debugf l (fun k -> k "%s" msg) diff --git a/src/util/dune b/src/util/dune index c1ccf9b6..44b960dc 100644 --- a/src/util/dune +++ b/src/util/dune @@ -2,4 +2,4 @@ (name sidekick_util) (public_name sidekick.util) (flags :standard -warn-error -a+8) - (libraries containers iter sidekick.sigs bigarray)) + (libraries containers iter sidekick.sigs bigarray unix)) From 1c30fb1f95b6016edc824340a3411a2386c78526 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 18 Aug 2022 22:03:15 -0400 Subject: [PATCH 132/174] feat(sat): add counters for decision level/trail depth --- src/sat/solver.ml | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index d4f23864..5b399074 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -418,6 +418,11 @@ let clause_bump_activity self (c : clause) : unit = self.clause_incr <- self.clause_incr *. 1e-20 ) +let emit_counters_ (self : t) = + if Profile.enabled () then + Profile.count "sat" + [ "decisions", decision_level self; "trail", AVec.size self.trail ] + (* Simplification of clauses. When adding new clauses, it is desirable to 'simplify' them, i.e @@ -644,8 +649,10 @@ let cancel_until (self : t) lvl = let (module P) = self.plugin in P.pop_levels n; Delayed_actions.clear_on_backtrack self.delayed_actions; + (* TODO: for scoped clause pools, backtrack them *) - self.next_decisions <- [] + self.next_decisions <- []; + emit_counters_ self ); () @@ -1616,7 +1623,10 @@ let pick_branch_lit ~full self : bool = true ) in - pick_lit () + + let res = pick_lit () in + emit_counters_ self; + res (* do some amount of search, until the number of conflicts or clause learnt reaches the given parameters *) @@ -1697,13 +1707,15 @@ let solve_ ~on_progress (self : t) : unit = in while true do on_progress (); + emit_counters_ self; try self.max_clauses_learnt := int_of_float !max_learnt; search self ~on_progress ~max_conflicts:(int_of_float !max_conflicts) with | Restart -> max_conflicts := !max_conflicts *. restart_inc; - max_learnt := !max_learnt *. learntsize_inc + max_learnt := !max_learnt *. learntsize_inc; + emit_counters_ self | E_sat -> assert ( self.elt_head = AVec.size self.trail @@ -1975,6 +1987,8 @@ let solve ?(on_progress = fun _ -> ()) ?(assumptions = []) (self : t) : res = with_local_assumptions_ self assumptions @@ fun () -> try solve_ ~on_progress self; + + Log.debug 3 "(sat.return Sat)"; Sat (mk_sat self) with E_unsat us -> Unsat (mk_unsat self us) From c643e547f66ad8199be5e21ccdca2872290cf963 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 19 Aug 2022 00:08:57 -0400 Subject: [PATCH 133/174] wip: refactor(th-data): remove some model building, cleanup code --- src/th-data/Sidekick_th_data.ml | 110 +++++++++++++------------------- src/th-data/types.ml | 52 --------------- 2 files changed, 45 insertions(+), 117 deletions(-) delete mode 100644 src/th-data/types.ml diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index cce845c9..fbdcab10 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -4,6 +4,7 @@ open Sidekick_core open Sidekick_cc include Th_intf module SI = SMT.Solver_internal +module Model_builder = SMT.Model_builder let name = "th-data" @@ -301,12 +302,10 @@ end = struct parents: ST_parents.t; (* repr -> parents for the class *) cards: Card.t; (* remember finiteness *) to_decide: unit N_tbl.t; (* set of terms to decide. *) - to_decide_for_complete_model: unit N_tbl.t; - (* infinite types but we need a cstor in model*) case_split_done: unit Term.Tbl.t; (* set of terms for which case split is done *) single_cstor_preproc_done: unit Term.Tbl.t; (* preprocessed terms *) - stat_acycl_conflict: int Stat.counter; + n_acycl_conflict: int Stat.counter; (* TODO: bitfield for types with less than 62 cstors, to quickly detect conflict? *) } @@ -322,6 +321,11 @@ end = struct N_tbl.pop_levels self.to_decide n; () + let is_data_ty (t : Term.t) : bool = + match A.as_datatype t with + | Ty_data _ -> true + | _ -> false + let preprocess (self : t) _si (acts : SI.preprocess_actions) (t : Term.t) : unit = let ty = Term.ty t in @@ -369,7 +373,8 @@ end = struct | _ -> ()) | _ -> () - (* remember terms of a datatype *) + (* find if we need to split [t] based on its type (if it's + a finite datatype) *) let on_new_term_look_at_ty (self : t) n (t : Term.t) : unit = let ty = Term.ty t in match A.as_datatype ty with @@ -377,23 +382,22 @@ end = struct Log.debugf 20 (fun k -> k "(@[%s.on-new-term.has-data-ty@ %a@ :ty %a@])" name Term.pp_debug t Term.pp_debug ty); - if Card.is_finite self.cards ty && not (N_tbl.mem self.to_decide n) then ( - (* must decide this term *) + if + Card.is_finite self.cards ty + && (not (N_tbl.mem self.to_decide n)) + && not (Term.Tbl.mem self.case_split_done t) + then ( + (* must decide this term in all extensions of the current trail *) Log.debugf 20 (fun k -> k "(@[%s.on-new-term.must-decide-finite-ty@ %a@])" name Term.pp_debug t); N_tbl.add self.to_decide n () - ) else if - (not (N_tbl.mem self.to_decide n)) - && not (N_tbl.mem self.to_decide_for_complete_model n) - then - (* must pick a constructor for this term in order to build a model *) - N_tbl.add self.to_decide_for_complete_model n () + ) | _ -> () let on_new_term (self : t) ((cc, n, t) : _ * E_node.t * Term.t) : _ list = + (* might have to decide [t] based on its type *) on_new_term_look_at_ty self n t; - (* might have to decide [t] *) match A.view_as_data t with | T_is_a (c_t, u) -> let n_u = CC.add_term cc u in @@ -569,14 +573,12 @@ end = struct let pp_path = Fmt.Dump.(list @@ pair E_node.pp pp_node) let pp_graph out (g : graph) : unit = - let pp_entry out (n, node) = - Fmt.fprintf out "@[<1>@[graph_node[%a]@]@ := %a@]" E_node.pp n pp_node - node - in + let pp_entry out (_n, node) = Fmt.fprintf out "@[<1>%a@]" pp_node node in if N_tbl.length g = 0 then Fmt.string out "(graph ø)" else - Fmt.fprintf out "(@[graph@ %a@])" (Fmt.iter pp_entry) (N_tbl.to_iter g) + Fmt.fprintf out "(@[graph@ %a@])" (Fmt.iter pp_entry) + (N_tbl.to_iter g) let mk_graph (self : t) cc : graph = let g : graph = N_tbl.create ~size:32 () in @@ -637,7 +639,7 @@ end = struct in Expl.mk_theory (E_node.term n) (E_node.term cstor_n) subs pr in - Stat.incr self.stat_acycl_conflict; + Stat.incr self.n_acycl_conflict; Log.debugf 5 (fun k -> k "(@[%s.acyclicity.raise_confl@ %a@ @[:path %a@]@])" name Expl.pp expl pp_path path); @@ -691,7 +693,9 @@ end = struct let t = E_node.term n in (* [t] might have been expanded already, in case of duplicates in [l] *) if not @@ Term.Tbl.mem self.case_split_done t then ( + Log.debugf 50 (fun k -> k "(@[th.data.split-on@ %a@])" Term.pp t); Term.Tbl.add self.case_split_done t (); + let c = cstors_of_ty (Term.ty t) |> List.map (fun c -> @@ -731,6 +735,7 @@ end = struct && not (Term.Tbl.mem self.case_split_done (E_node.term n))) |> Iter.to_rev_list in + (match remaining_to_decide with | [] -> Log.debugf 10 (fun k -> @@ -743,59 +748,35 @@ end = struct l); Profile.instant "data.case-split"; List.iter (decide_class_ self solver acts) l); - - if remaining_to_decide = [] then ( - let next_decision = - N_tbl.to_iter self.to_decide_for_complete_model - |> Iter.map (fun (n, _) -> SI.cc_find solver n) - |> Iter.filter (fun n -> - (not (Term.Tbl.mem self.case_split_done (E_node.term n))) - && not (ST_cstors.mem self.cstors n)) - |> Iter.head - in - match next_decision with - | None -> () (* all decided *) - | Some n -> - let t = E_node.term n in - - Profile.instant "data.decide"; - - (* use a constructor that will not lead to an infinite loop *) - let base_cstor = - match Card.base_cstor self.cards (Term.ty t) with - | None -> - Error.errorf "th-data:@ %a should have base cstor" E_node.pp n - | Some c -> c - in - let cstor_app = - let args = - A.Cstor.ty_args base_cstor - |> List.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) - in - A.mk_cstor self.tst base_cstor args - in - let t_eq_cstor = A.mk_eq self.tst t cstor_app in - Log.debugf 20 (fun k -> - k "(@[th-data.final-check.model.decide-cstor@ %a@])" Term.pp_debug - t_eq_cstor); - let lit = SI.mk_lit solver t_eq_cstor in - SI.push_decision solver acts lit - ); () - let on_model_gen (self : t) ~recurse (si : SI.t) (n : E_node.t) : - Term.t option = + let on_model_gen (self : t) (si : SI.t) (model : Model_builder.t) (t : Term.t) + : _ option = (* TODO: option to complete model or not (by picking sth at leaves)? *) let cc = SI.cc si in - let repr = CC.find cc n in + let repr = CC.find_t cc t in match ST_cstors.get self.cstors repr with - | None -> None | Some c -> Log.debugf 5 (fun k -> k "(@[th-data.mk-model.find-cstor@ %a@])" Monoid_cstor.pp c); - let args = List.map (recurse si) c.c_args in + let args = List.map E_node.term c.c_args in let t = A.mk_cstor self.tst c.c_cstor args in - Some t + Some (t, args) + | None when is_data_ty (Term.ty t) -> + (* datatype, use the base constructor for it *) + (match Card.base_cstor self.cards (Term.ty t) with + | None -> None + | Some c -> + (* invent new args *) + let args = + A.Cstor.ty_args c + |> List.map (fun ty -> Model_builder.gensym model ~pre:"c_arg" ~ty) + in + let c = A.mk_cstor self.tst c args in + Some (c, args)) + | None -> + (* FIXME: here, if [t] is a datatype, pick default cstor, and add that to the CC? *) + None let create_and_setup (solver : SI.t) : t = let self = @@ -805,11 +786,10 @@ end = struct cstors = ST_cstors.create_and_setup ~size:32 (SI.cc solver); parents = ST_parents.create_and_setup ~size:32 (SI.cc solver); to_decide = N_tbl.create ~size:16 (); - to_decide_for_complete_model = N_tbl.create ~size:16 (); single_cstor_preproc_done = Term.Tbl.create 8; case_split_done = Term.Tbl.create 16; cards = Card.create (); - stat_acycl_conflict = + n_acycl_conflict = Stat.mk_int (SI.stats solver) "th.data.acycl.conflict"; } in diff --git a/src/th-data/types.ml b/src/th-data/types.ml deleted file mode 100644 index 59bf1448..00000000 --- a/src/th-data/types.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* - -and datatype = { - data_cstors: data_cstor ID.Map.t lazy_t; -} - -(* TODO: in cstor, add: - - for each selector, a special "magic" term for undefined, in - case the selector is ill-applied (Collapse 2) *) - -(* a constructor *) -and data_cstor = { - cstor_ty: ty; - cstor_args: ty array; (* argument types *) - cstor_proj: cst array lazy_t; (* projectors *) - cstor_test: cst lazy_t; (* tester *) - cstor_cst: cst; (* the cstor itself *) - cstor_card: ty_card; (* cardinality of the constructor('s args) *) -} - -val make_cstor : ID.t -> Ty.t -> data_cstor lazy_t -> t -val make_proj : ID.t -> Ty.t -> data_cstor lazy_t -> int -> t -val make_tester : ID.t -> Ty.t -> data_cstor lazy_t -> t -val make_defined : ID.t -> Ty.t -> term lazy_t -> cst_defined_info -> t -val make_undef : ID.t -> Ty.t -> t - -let make_cstor id ty cstor = - let _, ret = Ty.unfold ty in - assert (Ty.is_data ret); - make id (Cst_cstor cstor) -let make_proj id ty cstor i = - make id (Cst_proj (ty, cstor, i)) -let make_tester id ty cstor = - make id (Cst_test (ty, cstor)) - -val cstor_test : data_cstor -> term -> t -val cstor_proj : data_cstor -> int -> term -> t -val case : term -> term ID.Map.t -> t - -let case u m = Case (u,m) -let if_ a b c = - assert (Ty.equal b.term_ty c.term_ty); - If (a,b,c) - -let cstor_test cstor t = - app_cst (Lazy.force cstor.cstor_test) (CCArray.singleton t) - -let cstor_proj cstor i t = - let p = CCArray.get (Lazy.force cstor.cstor_proj) i in - app_cst p (CCArray.singleton t) - - *) From 177cd70faca6b12fc851464fc9156c93b06516ef Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 19 Aug 2022 21:31:04 -0400 Subject: [PATCH 134/174] feat(e_node): remove useless assertion --- src/cc/e_node.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/cc/e_node.ml b/src/cc/e_node.ml index 2eb3fb01..b8979cf8 100644 --- a/src/cc/e_node.ml +++ b/src/cc/e_node.ml @@ -28,17 +28,15 @@ let make (t : Term.t) : t = let[@inline] is_root (n : e_node) : bool = n.n_root == n (* traverse the equivalence class of [n] *) -let iter_class_ (n : e_node) : e_node Iter.t = +let iter_class_ (n_start : e_node) : e_node Iter.t = fun yield -> let rec aux u = yield u; - if u.n_next != n then aux u.n_next + if u.n_next != n_start then aux u.n_next in - aux n + aux n_start -let[@inline] iter_class n = - assert (is_root n); - iter_class_ n +let[@inline] iter_class n = iter_class_ n let[@inline] iter_parents (n : e_node) : e_node Iter.t = assert (is_root n); From 5fa5fb5bd7fb5679cd6b812b96908ef2afd69e0e Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 19 Aug 2022 21:31:27 -0400 Subject: [PATCH 135/174] fix(th-data): need to propagate from `is-a` eagerly the final check is too late: we need the info from `is_a c t` to be fully propagated in the CC before we can run the acyclicity check. --- src/th-data/Sidekick_th_data.ml | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index fbdcab10..4ba4f54f 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -715,14 +715,17 @@ end = struct SI.add_clause_permanent solver acts [ Lit.neg l1; Lit.neg l2 ] pr) ) + let on_partial_check self solver acts trail = + Profile.with_ "data.partial-check" @@ fun () -> + check_is_a self solver acts trail; + () + (* on final check, check acyclicity, then make sure we have done case split on all terms that need it. *) - let on_final_check (self : t) (solver : SI.t) (acts : SI.theory_actions) trail - = + let on_final_check (self : t) (solver : SI.t) (acts : SI.theory_actions) + _trail = Profile.with_ "data.final-check" @@ fun () -> - check_is_a self solver acts trail; - (* acyclicity check first *) Acyclicity_.check self solver acts; @@ -798,6 +801,7 @@ end = struct SI.on_cc_new_term solver (on_new_term self); (* note: this needs to happen before we modify the plugin data *) SI.on_cc_pre_merge solver (on_pre_merge self); + SI.on_partial_check solver (on_partial_check self); SI.on_final_check solver (on_final_check self); SI.on_model solver ~ask:(on_model_gen self); self From 4d97f1a5257a538dd1ce716bc8d23a07b95616c9 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 19 Aug 2022 21:32:55 -0400 Subject: [PATCH 136/174] fix build --- src/th-data/Sidekick_th_data.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 4ba4f54f..00b583d4 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -4,7 +4,6 @@ open Sidekick_core open Sidekick_cc include Th_intf module SI = SMT.Solver_internal -module Model_builder = SMT.Model_builder let name = "th-data" From 3e39232696352e9e42d2dc9889cb5c70bc7280e6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 19 Aug 2022 21:33:49 -0400 Subject: [PATCH 137/174] fix build temporarily --- src/th-data/Sidekick_th_data.ml | 57 +++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 20 deletions(-) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 00b583d4..333f270d 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -750,35 +750,52 @@ end = struct l); Profile.instant "data.case-split"; List.iter (decide_class_ self solver acts) l); + + if remaining_to_decide = [] then ( + let next_decision = None in + match next_decision with + | None -> () (* all decided *) + | Some n -> + let t = E_node.term n in + + Profile.instant "data.decide"; + + (* use a constructor that will not lead to an infinite loop *) + let base_cstor = + match Card.base_cstor self.cards (Term.ty t) with + | None -> + Error.errorf "th-data:@ %a should have base cstor" E_node.pp n + | Some c -> c + in + let cstor_app = + let args = + A.Cstor.ty_args base_cstor + |> List.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) + in + A.mk_cstor self.tst base_cstor args + in + let t_eq_cstor = A.mk_eq self.tst t cstor_app in + Log.debugf 20 (fun k -> + k "(@[th-data.final-check.model.decide-cstor@ %a@])" Term.pp_debug + t_eq_cstor); + let lit = SI.mk_lit solver t_eq_cstor in + SI.push_decision solver acts lit + ); () - let on_model_gen (self : t) (si : SI.t) (model : Model_builder.t) (t : Term.t) - : _ option = + let on_model_gen (self : t) ~recurse (si : SI.t) (n : E_node.t) : + Term.t option = (* TODO: option to complete model or not (by picking sth at leaves)? *) let cc = SI.cc si in - let repr = CC.find_t cc t in + let repr = CC.find cc n in match ST_cstors.get self.cstors repr with + | None -> None | Some c -> Log.debugf 5 (fun k -> k "(@[th-data.mk-model.find-cstor@ %a@])" Monoid_cstor.pp c); - let args = List.map E_node.term c.c_args in + let args = List.map (recurse si) c.c_args in let t = A.mk_cstor self.tst c.c_cstor args in - Some (t, args) - | None when is_data_ty (Term.ty t) -> - (* datatype, use the base constructor for it *) - (match Card.base_cstor self.cards (Term.ty t) with - | None -> None - | Some c -> - (* invent new args *) - let args = - A.Cstor.ty_args c - |> List.map (fun ty -> Model_builder.gensym model ~pre:"c_arg" ~ty) - in - let c = A.mk_cstor self.tst c args in - Some (c, args)) - | None -> - (* FIXME: here, if [t] is a datatype, pick default cstor, and add that to the CC? *) - None + Some t let create_and_setup (solver : SI.t) : t = let self = From 28ce38002f5eab2b75895bc694aaf4534622602c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 20 Aug 2022 00:21:28 -0400 Subject: [PATCH 138/174] feat(profile): add ?args to spans --- src/tef/Sidekick_tef.real.ml | 22 +++++++++++----------- src/util/Profile.ml | 33 +++++++++++++++++++-------------- src/util/Profile.mli | 18 +++++++++++++----- 3 files changed, 43 insertions(+), 30 deletions(-) diff --git a/src/tef/Sidekick_tef.real.ml b/src/tef/Sidekick_tef.real.ml index 163c4bce..e025ca10 100644 --- a/src/tef/Sidekick_tef.real.ml +++ b/src/tef/Sidekick_tef.real.ml @@ -61,17 +61,6 @@ module Make () : P.BACKEND = struct String.iter encode_char s; char oc '"' - let emit_duration_event ~name ~start ~end_ () : unit = - let dur = end_ -. start in - let ts = start in - let pid = Unix.getpid () in - let tid = Thread.id (Thread.self ()) in - emit_sep_ (); - Printf.fprintf oc - {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"}|json} - pid tid dur ts str_val name; - () - (* emit args, if not empty. [ppv] is used to print values. *) let emit_args_o_ ppv oc args : unit = if args <> [] then ( @@ -84,6 +73,17 @@ module Make () : P.BACKEND = struct char oc '}' ) + let emit_duration_event ~name ~start ~end_ ~args () : unit = + let dur = end_ -. start in + let ts = start in + let pid = Unix.getpid () in + let tid = Thread.id (Thread.self ()) in + emit_sep_ (); + Printf.fprintf oc + {json|{"pid": %d,"cat":"","tid": %d,"dur": %.2f,"ts": %.2f,"name":%a,"ph":"X"%a}|json} + pid tid dur ts str_val name (emit_args_o_ str_val) args; + () + let emit_instant_event ~name ~ts ~args () : unit = let pid = Unix.getpid () in let tid = Thread.id (Thread.self ()) in diff --git a/src/util/Profile.ml b/src/util/Profile.ml index 5da6abf9..cc43cc8c 100644 --- a/src/util/Profile.ml +++ b/src/util/Profile.ml @@ -2,7 +2,12 @@ module type BACKEND = sig val get_ts : unit -> float val emit_duration_event : - name:string -> start:float -> end_:float -> unit -> unit + name:string -> + start:float -> + end_:float -> + args:(string * string) list -> + unit -> + unit val emit_instant_event : name:string -> ts:float -> args:(string * string) list -> unit -> unit @@ -49,47 +54,47 @@ let[@inline] count name cs = ) (* slow path *) -let[@inline never] exit_full_ (module B : BACKEND) name start = +let[@inline never] exit_full_ (module B : BACKEND) ~args name start = let now = B.get_ts () in - B.emit_duration_event ~name ~start ~end_:now () + B.emit_duration_event ~name ~start ~end_:now ~args () -let[@inline] exit_with_ b pb = +let[@inline] exit_with_ ~args b pb = match pb with | No_probe -> () - | Probe { name; start } -> exit_full_ b name start + | Probe { name; start } -> exit_full_ ~args b name start -let[@inline] exit pb = +let[@inline] exit ?(args = []) pb = match pb, !out_ with - | Probe { name; start }, Some b -> exit_full_ b name start + | Probe { name; start }, Some b -> exit_full_ ~args b name start | _ -> () -let[@inline] with_ name f = +let[@inline] with_ ?(args = []) name f = match !out_ with | None -> f () | Some b -> let pb = begin_with_ b name in (try let x = f () in - exit_with_ b pb; + exit_with_ ~args b pb; x with e -> - exit_with_ b pb; + exit_with_ ~args b pb; raise e) -let[@inline] with1 name f x = +let[@inline] with1 ?(args = []) name f x = match !out_ with | None -> f x | Some b -> let pb = begin_with_ b name in (try let res = f x in - exit_with_ b pb; + exit_with_ ~args b pb; res with e -> - exit_with_ b pb; + exit_with_ ~args b pb; raise e) -let[@inline] with2 name f x y = with_ name (fun () -> f x y) +let[@inline] with2 ?args name f x y = with_ ?args name (fun () -> f x y) module Control = struct let setup b = diff --git a/src/util/Profile.mli b/src/util/Profile.mli index b563ea6f..b44a9cc8 100644 --- a/src/util/Profile.mli +++ b/src/util/Profile.mli @@ -10,17 +10,25 @@ val null_probe : probe val enabled : unit -> bool val instant : ?args:(string * string) list -> string -> unit val begin_ : string -> probe -val exit : probe -> unit -val with_ : string -> (unit -> 'a) -> 'a -val with1 : string -> ('a -> 'b) -> 'a -> 'b -val with2 : string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c +val exit : ?args:(string * string) list -> probe -> unit +val with_ : ?args:(string * string) list -> string -> (unit -> 'a) -> 'a +val with1 : ?args:(string * string) list -> string -> ('a -> 'b) -> 'a -> 'b + +val with2 : + ?args:(string * string) list -> string -> ('a -> 'b -> 'c) -> 'a -> 'b -> 'c + val count : string -> (string * int) list -> unit module type BACKEND = sig val get_ts : unit -> float val emit_duration_event : - name:string -> start:float -> end_:float -> unit -> unit + name:string -> + start:float -> + end_:float -> + args:(string * string) list -> + unit -> + unit val emit_instant_event : name:string -> ts:float -> args:(string * string) list -> unit -> unit From e0faf6ba72aa936ff7e5f068d5b13d5966b4f035 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 20 Aug 2022 00:21:45 -0400 Subject: [PATCH 139/174] feat: some spans in main/process --- src/main/main.ml | 8 +++++++- src/smtlib/Process.ml | 1 + 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/main/main.ml b/src/main/main.ml index 9795fc2a..769ec595 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -198,7 +198,13 @@ let main_smt ~config () : _ result = if !check then (* might have to check conflicts *) Solver.add_theory solver Process.Check_cc.theory; - Sidekick_smtlib.parse tst !file >>= fun input -> + + let parse_res = + let@ () = Profile.with_ "parse" ~args:[ "file", !file ] in + Sidekick_smtlib.parse tst !file + in + + parse_res >>= fun input -> (* process statements *) let res = try diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 6fd22930..8083fe3f 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -245,6 +245,7 @@ let known_logics = let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model ?(check = false) ?time ?memory ?progress (solver : Solver.t) (stmt : Statement.t) : unit or_error = + let@ () = Profile.with_ "smtlib.process-stmt" in Log.debugf 5 (fun k -> k "(@[smtlib.process-statement@ %a@])" Statement.pp stmt); let decl_sort c n : unit = From ca1abd81345439b6ba9333f920a025c731ccb497 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 20 Aug 2022 22:07:21 -0400 Subject: [PATCH 140/174] fix(smt): perform CC check after theory actions --- src/smt/solver_internal.ml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 08d51ad3..be2b369d 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -489,7 +489,10 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) if not final then CC.assert_lits cc lits; (* transmit to theories. *) check_cc_with_acts_ self acts; + if final then ( + Perform_delayed_th.top self acts; + List.iter (fun f -> f self acts lits) self.on_final_check; check_cc_with_acts_ self acts; @@ -536,6 +539,8 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) Perform_delayed_th.top self acts ) else ( List.iter (fun f -> f self acts lits) self.on_partial_check; + (* re-check CC after theory actions, which might have merged classes *) + check_cc_with_acts_ self acts; Perform_delayed_th.top self acts ); () From 08606f4be0b67fe112b4a7cdba7018062978586f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 13:40:53 -0400 Subject: [PATCH 141/174] refactor: use proper type in sat.store --- src/sat/store.mli | 54 +++++++++++++++++++++++------------------------ 1 file changed, 27 insertions(+), 27 deletions(-) diff --git a/src/sat/store.mli b/src/sat/store.mli index f31d8399..d4628187 100644 --- a/src/sat/store.mli +++ b/src/sat/store.mli @@ -21,7 +21,7 @@ val iter_vars : t -> (var -> unit) -> unit module Var : sig type t = var - val equal : t -> t -> same_sign + val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val to_int : t -> int @@ -34,9 +34,9 @@ module Var : sig val set_weight : store -> var -> float -> unit val mark : store -> var -> unit val unmark : store -> var -> unit - val marked : store -> var -> same_sign - val set_default_pol : store -> var -> same_sign -> unit - val default_pol : store -> var -> same_sign + val marked : store -> var -> bool + val set_default_pol : store -> var -> bool -> unit + val default_pol : store -> var -> bool val heap_idx : store -> var -> int val set_heap_idx : store -> var -> int -> unit end @@ -44,13 +44,13 @@ end module Atom : sig type t = atom - val equal : t -> t -> same_sign + val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val to_int : t -> int val of_int_unsafe : int -> t val neg : t -> t - val sign : t -> same_sign + val sign : t -> bool val of_var : var -> t val var : t -> var val pa : var -> t @@ -62,15 +62,15 @@ module Atom : sig val lit : store -> atom -> Lit.t val mark : store -> atom -> unit val unmark : store -> atom -> unit - val marked : store -> atom -> same_sign + val marked : store -> atom -> bool val watched : store -> atom -> CVec.t - val is_true : store -> atom -> same_sign - val set_is_true : store -> atom -> same_sign -> unit - val is_false : store -> t -> same_sign - val has_value : store -> atom -> same_sign + val is_true : store -> atom -> bool + val set_is_true : store -> atom -> bool -> unit + val is_false : store -> t -> bool + val has_value : store -> atom -> bool val reason : store -> t -> var_reason option val level : store -> t -> int - val marked_both : store -> atom -> same_sign + val marked_both : store -> atom -> bool val proof_lvl0 : store -> ATbl.key -> int32 option val set_proof_lvl0 : store -> ATbl.key -> int32 -> unit val pp : store -> Format.formatter -> atom -> unit @@ -86,7 +86,7 @@ end module Clause : sig type t = clause - val equal : t -> t -> same_sign + val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int val to_int : t -> int @@ -95,23 +95,23 @@ module Clause : sig module Tbl : Hashtbl.S with type key = t module CVec = Base_types_.CVec - val make_a : store -> removable:same_sign -> atom array -> int32 -> t - val make_l : store -> removable:same_sign -> atom list -> int32 -> t + val make_a : store -> removable:bool -> atom array -> int32 -> t + val make_l : store -> removable:bool -> atom list -> int32 -> t val n_atoms : store -> t -> int - val marked : store -> t -> same_sign - val set_marked : store -> t -> same_sign -> unit - val attached : store -> t -> same_sign - val set_attached : store -> t -> same_sign -> unit - val removable : store -> t -> same_sign - val dead : store -> t -> same_sign - val set_dead : store -> t -> same_sign -> unit + val marked : store -> t -> bool + val set_marked : store -> t -> bool -> unit + val attached : store -> t -> bool + val set_attached : store -> t -> bool -> unit + val removable : store -> t -> bool + val dead : store -> t -> bool + val set_dead : store -> t -> bool -> unit val dealloc : store -> t -> unit val proof_step : store -> t -> int32 val activity : store -> t -> float val set_activity : store -> t -> float -> unit val iter : store -> f:(atom -> unit) -> t -> unit val fold : store -> f:('a -> atom -> 'a) -> 'a -> t -> 'a - val for_all : store -> f:(atom -> same_sign) -> t -> same_sign + val for_all : store -> f:(atom -> bool) -> t -> bool val atoms_a : store -> t -> atom array val lits_l : store -> t -> Lit.t list val lits_a : store -> t -> Lit.t array @@ -121,9 +121,9 @@ module Clause : sig val debug : store -> Format.formatter -> t -> unit end -val alloc_var_uncached_ : ?default_pol:same_sign -> t -> Lit.t -> var -val alloc_var : t -> ?default_pol:same_sign -> Lit.t -> var * same_sign +val alloc_var_uncached_ : ?default_pol:bool -> t -> Lit.t -> var +val alloc_var : t -> ?default_pol:bool -> Lit.t -> var * bool val clear_var : t -> var -> unit -val atom_of_var_ : var -> same_sign -> atom -val alloc_atom : t -> ?default_pol:same_sign -> Lit.t -> atom +val atom_of_var_ : var -> bool -> atom +val alloc_atom : t -> ?default_pol:bool -> Lit.t -> atom val find_atom : t -> Lit.t -> atom option From 65f8a61913d8769281023c66121f781925c6d67b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 13:52:33 -0400 Subject: [PATCH 142/174] feat(pure-sat): correct timing printing --- src/main/pure_sat_solver.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/main/pure_sat_solver.ml b/src/main/pure_sat_solver.ml index a0f96058..4eff561b 100644 --- a/src/main/pure_sat_solver.ml +++ b/src/main/pure_sat_solver.ml @@ -231,6 +231,8 @@ end !ok *) +let start = Sys.time () + let solve ?(check = false) ?in_memory_proof (solver : SAT.t) : (unit, string) result = let res = Profile.with_ "solve" (fun () -> SAT.solve solver) in @@ -239,18 +241,18 @@ let solve ?(check = false) ?in_memory_proof (solver : SAT.t) : flush stdout; (match res with | SAT.Sat _ -> - let t3 = Sys.time () -. t2 in - Format.printf "Sat (%.3f/%.3f)@." t2 t3 + let t3 = Sys.time () in + Format.printf "Sat (%.3f/%.3f)@." (t2 -. start) (t3 -. t2) | SAT.Unsat _ -> if check then ( match in_memory_proof with | None -> Error.errorf "Cannot validate proof, no in-memory proof provided" - | Some proof -> + | Some _proof -> let ok = true (* FIXME check_proof proof *) in if not ok then Error.errorf "Proof validation failed" ); - let t3 = Sys.time () -. t2 in - Format.printf "Unsat (%.3f/%.3f)@." t2 t3); + let t3 = Sys.time () in + Format.printf "Unsat (%.3f/%.3f)@." (t2 -. start) (t3 -. t2)); Ok () From 7dac9781bf3a46decc063c0dadc125ef56ba84cc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 13:52:52 -0400 Subject: [PATCH 143/174] feat(sat): phase saving. remember polarity of decisions --- src/sat/solver.ml | 12 +++++++++--- src/sat/store.ml | 15 ++++++++++++++- src/sat/store.mli | 2 ++ 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index 5b399074..c751536e 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -1600,11 +1600,14 @@ let pick_branch_lit ~full self : bool = | [] -> (match H.remove_min self.order with | v -> - pick_with_given_atom - (if Var.default_pol self.store v then + let pol = Var.last_pol self.store v in + let atom = + if pol then Atom.pa v else - Atom.na v) + Atom.na v + in + pick_with_given_atom atom | exception Not_found -> false) (* pick a decision, trying [atom] first if it's not assigned yet. *) and pick_with_given_atom (atom : atom) : bool = @@ -1615,9 +1618,12 @@ let pick_branch_lit ~full self : bool = || Atom.is_true self.store (Atom.na v)); pick_lit () ) else ( + (* [atom] is not assigned, we can decide it *) new_decision_level self; let current_level = decision_level self in enqueue_bool self atom ~level:current_level Decision; + (* remember polarity *) + Var.set_last_pol self.store v (Atom.sign atom); Stat.incr self.n_decisions; Event.emit self.on_decision (Atom.lit self.store atom); true diff --git a/src/sat/store.ml b/src/sat/store.ml index a91447e2..e7d42b4a 100644 --- a/src/sat/store.ml +++ b/src/sat/store.ml @@ -23,6 +23,7 @@ type t = { v_reason: var_reason option Vec.t; (* reason for assignment *) v_seen: Bitvec.t; (* generic temporary marker *) v_default_polarity: Bitvec.t; (* default polarity in decisions *) + v_last_polarity: Bitvec.t; (* last polarity when deciding this *) mutable v_count: int; (* atoms *) a_is_true: Bitvec.t; @@ -55,6 +56,7 @@ let create ?(size = `Big) ~stat () : t = v_reason = Vec.create (); v_seen = Bitvec.create (); v_default_polarity = Bitvec.create (); + v_last_polarity = Bitvec.create (); v_count = 0; a_is_true = Bitvec.create (); a_form = Vec.create (); @@ -95,8 +97,16 @@ module Var = struct let[@inline] unmark self v = Bitvec.set self.v_seen (v : var :> int) false let[@inline] marked self v = Bitvec.get self.v_seen (v : var :> int) + let[@inline] set_last_pol self v b = + Bitvec.set self.v_last_polarity (v : var :> int) b + + let[@inline] last_pol self v = + Bitvec.get self.v_last_polarity (v : var :> int) + let[@inline] set_default_pol self v b = - Bitvec.set self.v_default_polarity (v : var :> int) b + Bitvec.set self.v_default_polarity (v : var :> int) b; + (* also update last polarity *) + set_last_pol self v b let[@inline] default_pol self v = Bitvec.get self.v_default_polarity (v : var :> int) @@ -340,6 +350,7 @@ let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var = v_reason; v_seen; v_default_polarity; + v_last_polarity; stat_n_atoms; a_is_true; a_seen; @@ -365,6 +376,8 @@ let alloc_var_uncached_ ?default_pol:(pol = true) self (form : Lit.t) : var = Bitvec.ensure_size v_seen v_idx; Bitvec.ensure_size v_default_polarity v_idx; Bitvec.set v_default_polarity v_idx pol; + Bitvec.ensure_size v_last_polarity v_idx; + Bitvec.set v_last_polarity v_idx pol; assert (Vec.size a_form = 2 * (v : var :> int)); Bitvec.ensure_size a_is_true (2 * (v : var :> int)); diff --git a/src/sat/store.mli b/src/sat/store.mli index d4628187..73be49e3 100644 --- a/src/sat/store.mli +++ b/src/sat/store.mli @@ -37,6 +37,8 @@ module Var : sig val marked : store -> var -> bool val set_default_pol : store -> var -> bool -> unit val default_pol : store -> var -> bool + val set_last_pol : store -> var -> bool -> unit + val last_pol : store -> var -> bool val heap_idx : store -> var -> int val set_heap_idx : store -> var -> int -> unit end From 007fbad243139d4482464a0c64bd72043482e503 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 13:53:36 -0400 Subject: [PATCH 144/174] fix some stats --- src/smt/solver.ml | 28 +++++++++++++++++----------- 1 file changed, 17 insertions(+), 11 deletions(-) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index cb08c429..11bb4031 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -65,8 +65,9 @@ type t = { mutable last_res: res option; stat: Stat.t; proof: P.t; - count_clause: int Stat.counter; - count_solve: int Stat.counter; (* config: Config.t *) + n_clause_input: int Stat.counter; + n_clause_internal: int Stat.counter; + n_solve: int Stat.counter; (* config: Config.t *) } (** {2 Main} *) @@ -101,8 +102,9 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = last_res = None; solver = Sat_solver.create ~proof ?size ~stat (SI.to_sat_plugin si); stat; - count_clause = Stat.mk_int stat "smt.solver.add-clause"; - count_solve = Stat.mk_int stat "smt.solver.solve"; + n_clause_input = Stat.mk_int stat "smt.solver.add-clause.input"; + n_clause_internal = Stat.mk_int stat "smt.solver.add-clause.internal"; + n_solve = Stat.mk_int stat "smt.solver.solve"; } in add_theory_l self theories; @@ -137,8 +139,12 @@ let mk_lit_t (self : t) ?sign (t : term) : lit = let pp_stats out (self : t) : unit = Stat.pp out (stats self) (* add [c], without preprocessing its literals *) -let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit = - Stat.incr self.count_clause; +let add_clause_nopreproc_ ~internal (self : t) (c : lit array) (proof : step_id) + : unit = + if internal then + Stat.incr self.n_clause_internal + else + Stat.incr self.n_clause_input; reset_last_res_ self; Log.debugf 50 (fun k -> k "(@[solver.add-clause@ %a@])" (Util.pp_array Lit.pp) c); @@ -146,14 +152,14 @@ let add_clause_nopreproc_ (self : t) (c : lit array) (proof : step_id) : unit = Sat_solver.add_clause_a self.solver (c :> lit array) proof; Profile.exit pb -let add_clause_nopreproc_l_ self c p = - add_clause_nopreproc_ self (CCArray.of_list c) p +let add_clause_nopreproc_l_ ~internal self c p = + add_clause_nopreproc_ ~internal self (CCArray.of_list c) p module Perform_delayed_ = Solver_internal.Perform_delayed (struct type nonrec t = t let add_clause _si solver ~keep:_ c pr : unit = - add_clause_nopreproc_l_ solver c pr + add_clause_nopreproc_l_ ~internal:true solver c pr let add_lit _si solver ?default_pol lit : unit = Sat_solver.add_lit solver.solver ?default_pol lit @@ -161,7 +167,7 @@ end) let add_clause (self : t) (c : lit array) (proof : step_id) : unit = let c, proof = preprocess_clause_ self c proof in - add_clause_nopreproc_ self c proof; + add_clause_nopreproc_ ~internal:false self c proof; Perform_delayed_.top self.si self; (* finish preproc *) () @@ -192,7 +198,7 @@ let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) let res = match - Stat.incr self.count_solve; + Stat.incr self.n_solve; Sat_solver.solve ~on_progress ~assumptions (solver self) with | Sat_solver.Sat _ when not (SI.is_complete self.si) -> From e34f5a5c3c62c25515258f71cb43e7023295d0c6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 13:53:48 -0400 Subject: [PATCH 145/174] cleanup --- src/smt/solver.ml | 3 ++- src/smt/solver_internal.ml | 12 ------------ 2 files changed, 2 insertions(+), 13 deletions(-) diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 11bb4031..e4ab156e 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -212,7 +212,8 @@ let solve ?(on_exit = []) ?(check = true) ?(on_progress = fun _ -> ()) Log.debugf 5 (fun k -> let ppc out n = - Fmt.fprintf out "{@[class@ %a@]}" (Util.pp_iter E_node.pp) + 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) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index be2b369d..2ee24361 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -312,18 +312,6 @@ let cc_resolve_expl self e : lit list * _ = let r = CC.explain_expl (cc self) e in r.lits, r.pr self.proof -(* - let cc_merge self _acts n1 n2 e = CC.merge (cc self) n1 n2 e - - let cc_merge_t self acts t1 t2 e = - let cc_acts = mk_cc_acts_ self.proof acts in - cc_merge self cc_acts (cc_add_term self t1) (cc_add_term self t2) e - - let cc_raise_conflict_expl self acts e = - let cc_acts = mk_cc_acts_ self.proof acts in - CC.raise_conflict_from_expl (cc self) cc_acts e - *) - (** {2 Interface with the SAT solver} *) let rec push_lvl_ = function From 30cf71522c826259ba340f48ae2935d2f414facb Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 22:01:07 -0400 Subject: [PATCH 146/174] small refactor of CC --- src/cc/CC.ml | 41 ++++++++++++++++++++--------------------- 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index ea467050..24184958 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -261,8 +261,9 @@ let find_common_ancestor self (a : e_node) (b : e_node) : e_node = | FL_some r1, FL_some r2 -> find2 r1.next r2.next | FL_some r, FL_none -> find1 r.next | FL_none, FL_some r -> find1 r.next - | FL_none, FL_none -> assert false - (* no common ancestor *) + | FL_none, FL_none -> + (* no common ancestor *) + assert false ) in @@ -395,27 +396,28 @@ and explain_expls self (es : explanation list) : Expl_state.t = and explain_equal_rec_ (cc : t) (st : Expl_state.t) (a : e_node) (b : e_node) : unit = - Log.debugf 5 (fun k -> - k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); - assert (E_node.equal (find_ a) (find_ b)); - let ancestor = find_common_ancestor cc a b in - explain_along_path cc st a ancestor; - explain_along_path cc st b ancestor + if a != b then ( + Log.debugf 5 (fun k -> + k "(@[cc.explain_loop.at@ %a@ =?= %a@])" E_node.pp a E_node.pp b); + assert (E_node.equal (find_ a) (find_ b)); + let ancestor = find_common_ancestor cc a b in + explain_along_path cc st a ancestor; + explain_along_path cc st b ancestor + ) -(* explain why [a = parent_a], where [a -> ... -> target] in the +(* explain why [a = target], where [a -> ... -> target] in the proof forest *) and explain_along_path self (st : Expl_state.t) (a : e_node) (target : e_node) : unit = let rec aux n = - if n == target then - () - else ( + if n != target then ( match n.n_expl with | FL_none -> assert false - | FL_some { next = next_n; expl } -> + | FL_some { next = next_a; expl } -> + (* prove [a = next_n] *) explain_decompose_expl self st expl; - (* now prove [next_n = target] *) - aux next_n + (* now prove [next_a = target] *) + aux next_a ) in aux a @@ -887,12 +889,9 @@ let[@inline] find_t self t : repr = find_ n let pop_acts_ self = - let rec loop acc = - match Vec.pop self.res_acts with - | None -> acc - | Some x -> loop (x :: acc) - in - loop [] + let l = Vec.to_list self.res_acts in + Vec.clear self.res_acts; + l let check self : Result_action.or_conflict = Log.debug 5 "(cc.check)"; From 1eb26e50913b7012c3d0fb21a8367567b85f25e2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 22:34:15 -0400 Subject: [PATCH 147/174] refactor(cc): cleanup a bit, smaller closures for backtracking --- src/cc/CC.ml | 27 +++++++++++++-------------- src/cc/e_node.ml | 7 ++++++- src/cc/e_node.mli | 4 ++++ src/cc/signature.ml | 2 ++ 4 files changed, 25 insertions(+), 15 deletions(-) diff --git a/src/cc/CC.ml b/src/cc/CC.ml index 24184958..0f8cfe5b 100644 --- a/src/cc/CC.ml +++ b/src/cc/CC.ml @@ -182,9 +182,11 @@ let add_signature self (s : signature) (n : e_node) : unit = on_backtrack self (fun () -> Sig_tbl.remove self.signatures_tbl s); Sig_tbl.add self.signatures_tbl s n -let[@inline] push_pending self t : unit = - Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp t); - Vec.push self.pending t +let push_pending self (n : E_node.t) : unit = + if Option.is_some n.n_sig0 then ( + Log.debugf 50 (fun k -> k "(@[cc.push-pending@ %a@])" E_node.pp n); + Vec.push self.pending n + ) let[@inline] push_action self (a : Handler_action.t) : unit = Vec.push self.combine (CT_act a) @@ -449,7 +451,7 @@ and add_new_term_ self (t : Term.t) : e_node = Event.emit_iter self.on_new_term (self, n, t) ~f:(push_action_l self); n -(* compute the initial signature of the given e_node *) +(* compute the initial signature of the given e_node [n] *) and compute_sig0 (self : t) (n : e_node) : Signature.t option = (* add sub-term to [cc], and register [n] to its parents. Note that we return the exact sub-term, to get proper @@ -530,7 +532,7 @@ and task_pending_ self (n : e_node) : unit = | None -> () (* no-op *) | Some (Eq (a, b)) -> (* if [a=b] is now true, merge [(a=b)] and [true] *) - if same_class a b then ( + if a != b && same_class a b then ( let expl = Expl.mk_merge a b in Log.debugf 5 (fun k -> k "(@[cc.pending.eq@ %a@ :r1 %a@ :r2 %a@])" E_node.pp n E_node.pp a @@ -549,7 +551,7 @@ and task_pending_ self (n : e_node) : unit = ) | Some s0 -> (* update the signature by using [find] on each sub-e_node *) - let s = (update_sig [@inlined]) s0 in + let s = update_sig s0 in (match find_signature self s with | None -> (* add to the signature table [sig(n) --> n] *) @@ -657,13 +659,10 @@ and task_merge_ self a b e_ab : unit = assert (u.n_root == r_from); u.n_root <- r_into); (* capture current state *) - let r_into_old_next = r_into.n_next in - let r_from_old_next = r_from.n_next in let r_into_old_parents = r_into.n_parents in let r_into_old_bits = r_into.n_bits in (* swap [into.next] and [from.next], merging the classes *) - r_into.n_next <- r_from_old_next; - r_from.n_next <- r_into_old_next; + E_node.swap_next r_into r_from; r_into.n_parents <- Bag.append r_into.n_parents r_from.n_parents; r_into.n_size <- r_into.n_size + r_from.n_size; r_into.n_bits <- Bits.merge r_into.n_bits r_from.n_bits; @@ -673,8 +672,8 @@ and task_merge_ self a b e_ab : unit = k "(@[cc.undo_merge@ :from %a@ :into %a@])" E_node.pp r_from E_node.pp r_into); r_into.n_bits <- r_into_old_bits; - r_into.n_next <- r_into_old_next; - r_from.n_next <- r_from_old_next; + (* un-merge the classes *) + E_node.swap_next r_into r_from; r_into.n_parents <- r_into_old_parents; (* NOTE: this must come after the restoration of [next] pointers, otherwise we'd iterate on too big a class *) @@ -686,9 +685,9 @@ and task_merge_ self a b e_ab : unit = and [b], not their roots. *) reroot_expl self a; assert (a.n_expl = FL_none); - (* on backtracking, link may be inverted, but we delete the one - that bridges between [a] and [b] *) on_backtrack self (fun () -> + (* on backtracking, link may be inverted, but we delete the one + that bridges between [a] and [b] *) match a.n_expl, b.n_expl with | FL_some e, _ when E_node.equal e.next b -> a.n_expl <- FL_none | _, FL_some e when E_node.equal e.next a -> b.n_expl <- FL_none diff --git a/src/cc/e_node.ml b/src/cc/e_node.ml index b8979cf8..f50db6d0 100644 --- a/src/cc/e_node.ml +++ b/src/cc/e_node.ml @@ -5,7 +5,7 @@ type t = e_node let[@inline] equal (n1 : t) n2 = n1 == n2 let[@inline] hash n = Term.hash n.n_term let[@inline] term n = n.n_term -let[@inline] pp out n = Term.pp_debug out n.n_term +let[@inline] pp out n = Term.pp out n.n_term let[@inline] as_lit n = n.n_as_lit let make (t : Term.t) : t = @@ -42,6 +42,11 @@ let[@inline] iter_parents (n : e_node) : e_node Iter.t = assert (is_root n); Bag.to_iter n.n_parents +let[@inline] swap_next n1 n2 : unit = + let tmp = n1.n_next in + n1.n_next <- n2.n_next; + n2.n_next <- tmp + module Internal_ = struct let iter_class_ = iter_class_ let make = make diff --git a/src/cc/e_node.mli b/src/cc/e_node.mli index 6486c74d..524ab43a 100644 --- a/src/cc/e_node.mli +++ b/src/cc/e_node.mli @@ -55,6 +55,10 @@ val iter_parents : t -> t Iter.t val as_lit : t -> Lit.t option +val swap_next : t -> t -> unit +(** Swap the next pointer of each node. If their classes were disjoint, + they are now unioned. *) + module Internal_ : sig val iter_class_ : t -> t Iter.t val make : Term.t -> t diff --git a/src/cc/signature.ml b/src/cc/signature.ml index 8678ba04..da74564c 100644 --- a/src/cc/signature.ml +++ b/src/cc/signature.ml @@ -8,6 +8,8 @@ type t = signature let equal (s1 : t) s2 : bool = let open CC_view in + s1 == s2 + || match s1, s2 with | Bool b1, Bool b2 -> b1 = b2 | App_fun (f1, []), App_fun (f2, []) -> Const.equal f1 f2 From 9c57dad3f1b1ea1098d25bdcdfe17119f875af92 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 21 Aug 2022 22:56:38 -0400 Subject: [PATCH 148/174] perf: small changes in Event --- src/util/Event.ml | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/util/Event.ml b/src/util/Event.ml index e1561b3b..cad1fe52 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -6,17 +6,24 @@ let nop_handler_ _ = assert false module Emitter = struct type nonrec ('a, 'b) t = ('a, 'b) t - let emit (self : (_, unit) t) x = Vec.iter self.h ~f:(fun h -> h x) + let emit (self : (_, unit) t) x = + if not (Vec.is_empty self.h) then + (Vec.iter [@inlined]) self.h ~f:(fun h -> h x) let emit_collect (self : _ t) x : _ list = - let l = ref [] in - Vec.iter self.h ~f:(fun h -> l := h x :: !l); - !l + if Vec.is_empty self.h then + [] + else ( + let l = ref [] in + Vec.iter self.h ~f:(fun h -> l := h x :: !l); + !l + ) let emit_iter self x ~f = - Vec.iter self.h ~f:(fun h -> - let y = h x in - f y) + if not (Vec.is_empty self.h) then + Vec.iter self.h ~f:(fun h -> + let y = h x in + f y) let create () : _ t = { h = Vec.make 3 nop_handler_ } end From 0ff197d56c872e96c7b1797dfea37dc31a5ff4e2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:01:02 -0400 Subject: [PATCH 149/174] perf(core): have `eq` and `not_` be simplying - `a=b` and `b=a` are now the same - `not (not u)` and `u` are now the same --- src/core-logic/t_builtins.ml | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml index 7dcb1b66..d8b61f0c 100644 --- a/src/core-logic/t_builtins.ml +++ b/src/core-logic/t_builtins.ml @@ -68,9 +68,28 @@ let c_not store = let ty = arrow store b b in const store @@ Const.make C_not ops ~ty -let eq store a b = app_l store (c_eq store) [ ty a; a; b ] +let eq store a b = + if equal a b then + true_ store + else ( + let a, b = + if compare a b <= 0 then + a, b + else + b, a + in + app_l store (c_eq store) [ ty a; a; b ] + ) + let ite store a b c = app_l store (c_ite store) [ ty b; a; b; c ] -let not store a = app store (c_not store) a + +let not store a = + (* turn [not (not u)] into [u] *) + match view a with + | E_app ({ view = E_const { c_view = C_not; _ }; _ }, u) -> u + | E_const { c_view = C_true; _ } -> false_ store + | E_const { c_view = C_false; _ } -> true_ store + | _ -> app store (c_not store) a let is_bool t = match view t with From dff65c5d263f945bec6184a33d4de4c3d4b2ffe0 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:04:58 -0400 Subject: [PATCH 150/174] refactor: Term.abs takes store again, so `abs false` can be `false,true` --- examples/sudoku/sudoku_solve.ml | 2 +- src/core-logic/t_builtins.ml | 5 ++-- src/core-logic/t_builtins.mli | 10 +++---- src/core/lit.ml | 12 ++++++-- src/core/lit.mli | 4 +-- src/main/pure_sat_solver.ml | 2 +- src/smt/solver.ml | 6 ++-- src/smt/solver_internal.ml | 12 ++++---- src/smtlib/Process.ml | 2 +- src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 28 +++++++++---------- src/th-bool-static/Sidekick_th_bool_static.ml | 2 +- src/th-data/Sidekick_th_data.ml | 2 +- src/th-lra/sidekick_th_lra.ml | 8 +++--- 13 files changed, 51 insertions(+), 44 deletions(-) diff --git a/examples/sudoku/sudoku_solve.ml b/examples/sudoku/sudoku_solve.ml index 68850ed9..8e177a31 100644 --- a/examples/sudoku/sudoku_solve.ml +++ b/examples/sudoku/sudoku_solve.ml @@ -174,7 +174,7 @@ end = struct @@ Const.make (Cell_is { x; y; value }) ops ~ty:(Term.bool tst) let mk_cell_lit ?sign tst x y value : Lit.t = - Lit.atom ?sign @@ mk_cell tst x y value + Lit.atom ?sign tst @@ mk_cell tst x y value module Theory : sig type t diff --git a/src/core-logic/t_builtins.ml b/src/core-logic/t_builtins.ml index d8b61f0c..fe80d7eb 100644 --- a/src/core-logic/t_builtins.ml +++ b/src/core-logic/t_builtins.ml @@ -101,11 +101,12 @@ let is_eq t = | E_const { c_view = C_eq; _ } -> true | _ -> false -let rec abs t = +let rec abs tst t = match view t with | E_app ({ view = E_const { c_view = C_not; _ }; _ }, u) -> - let sign, v = abs u in + let sign, v = abs tst u in Stdlib.not sign, v + | E_const { c_view = C_false; _ } -> false, true_ tst | _ -> true, t let as_bool_val t = diff --git a/src/core-logic/t_builtins.mli b/src/core-logic/t_builtins.mli index 5ffd27b3..521fcfe1 100644 --- a/src/core-logic/t_builtins.mli +++ b/src/core-logic/t_builtins.mli @@ -24,12 +24,12 @@ val ite : store -> t -> t -> t -> t val is_eq : t -> bool val is_bool : t -> bool -val abs : t -> bool * t +val abs : store -> t -> bool * t (** [abs t] returns an "absolute value" for the term, along with the - sign of [t]. + sign of [t]. - The idea is that we want to turn [not a] into [(false, a)], - or [(a != b)] into [(false, a=b)]. For terms without a negation this - should return [(true, t)]. *) + The idea is that we want to turn [not a] into [(false, a)], + or [(a != b)] into [(false, a=b)]. For terms without a negation this + should return [(true, t)]. *) val as_bool_val : t -> bool option diff --git a/src/core/lit.ml b/src/core/lit.ml index a9479a62..5f6d5fc7 100644 --- a/src/core/lit.ml +++ b/src/core/lit.ml @@ -11,17 +11,23 @@ let[@inline] term (l : t) : term = l.lit_term let[@inline] signed_term l = term l, sign l let[@inline] make_ ~sign t : t = { lit_sign = sign; lit_term = t } -let atom ?(sign = true) (t : term) : t = - let sign', t = T_builtins.abs t in +let atom ?(sign = true) tst (t : term) : t = + let sign', t = T_builtins.abs tst t in let sign = sign = sign' in make_ ~sign t let make_eq ?sign store t u : t = let p = T_builtins.eq store t u in - atom ?sign p + atom ?sign store p let equal a b = a.lit_sign = b.lit_sign && T.equal a.lit_term b.lit_term +let compare a b = + if a.lit_sign = b.lit_sign then + T.compare a.lit_term b.lit_term + else + CCOrd.bool a.lit_sign b.lit_sign + let hash a = let sign = a.lit_sign in CCHash.combine3 2 (CCHash.bool sign) (T.hash a.lit_term) diff --git a/src/core/lit.mli b/src/core/lit.mli index 6b3b42c1..c6f1bada 100644 --- a/src/core/lit.mli +++ b/src/core/lit.mli @@ -14,7 +14,7 @@ type term = Term.t type t (** A literal *) -include Sidekick_sigs.EQ_HASH_PRINT with type t := t +include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t val term : t -> term (** Get the (positive) term *) @@ -31,7 +31,7 @@ val abs : t -> t val signed_term : t -> term * bool (** Return the atom and the sign *) -val atom : ?sign:bool -> term -> t +val atom : ?sign:bool -> Term.store -> term -> t (** [atom store t] makes a literal out of a term, possibly normalizing its sign in the process. @param sign if provided, and [sign=false], negate the resulting lit. *) diff --git a/src/main/pure_sat_solver.ml b/src/main/pure_sat_solver.ml index 4eff561b..7e183a25 100644 --- a/src/main/pure_sat_solver.ml +++ b/src/main/pure_sat_solver.ml @@ -181,7 +181,7 @@ end = struct let make tst i : Lit.t = let t = Term.const tst @@ Const.make (I (abs i)) ops ~ty:(Term.bool tst) in - Lit.atom ~sign:(i > 0) t + Lit.atom ~sign:(i > 0) tst t end module SAT = Sidekick_sat diff --git a/src/smt/solver.ml b/src/smt/solver.ml index e4ab156e..d2157216 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -112,7 +112,7 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = (let tst = Solver_internal.tst self.si in let t_true = Term.true_ tst in Sat_solver.add_clause self.solver - [ Lit.atom t_true ] + [ Lit.atom tst t_true ] (P.add_step self.proof @@ fun () -> Rule_.lemma_true t_true)); self @@ -130,7 +130,7 @@ let preprocess_clause_ (self : t) (c : lit array) (pr : step_id) : Solver_internal.preprocess_clause_array self.si c pr let mk_lit_t (self : t) ?sign (t : term) : lit = - let lit = Lit.atom ?sign t in + let lit = Lit.atom ?sign (tst self) t in let lit, _ = Solver_internal.simplify_and_preproc_lit self.si lit in lit @@ -175,7 +175,7 @@ let add_clause (self : t) (c : lit array) (proof : step_id) : unit = let add_clause_l self c p = add_clause self (CCArray.of_list c) p let assert_terms self c = - let c = CCList.map Lit.atom c in + let c = CCList.map (Lit.atom (tst self)) c in let pr_c = P.add_step self.proof @@ fun () -> Proof_sat.sat_input_clause c in add_clause_l self c pr_c diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 2ee24361..c9b5b8c3 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -127,7 +127,7 @@ let delayed_add_clause (self : t) ~keep (c : Lit.t list) (pr : step_id) : unit = let preprocess_term_ (self : t) (t0 : term) : unit = let module A = struct let proof = self.proof - let mk_lit ?sign t : Lit.t = Lit.atom ?sign t + let mk_lit ?sign t : Lit.t = Lit.atom ?sign self.tst t let add_lit ?default_pol lit : unit = delayed_add_lit self ?default_pol lit let add_clause c pr : unit = delayed_add_clause self ~keep:true c pr end in @@ -151,7 +151,7 @@ let preprocess_term_ (self : t) (t0 : term) : unit = t); (* make a literal *) - let lit = Lit.atom t in + let lit = Lit.atom self.tst t in (* ensure that SAT solver has a boolean atom for [u] *) delayed_add_lit self lit; @@ -179,7 +179,7 @@ let simplify_and_preproc_lit (self : t) (lit : Lit.t) : Lit.t * step_id option = u, Some pr_t_u in preprocess_term_ self u; - Lit.atom ~sign u, pr + Lit.atom ~sign self.tst u, pr let push_decision (self : t) (acts : theory_actions) (lit : lit) : unit = let (module A) = acts in @@ -275,13 +275,13 @@ let[@inline] add_clause_permanent self _acts c (proof : step_id) : unit = let c, proof = preprocess_clause self c proof in delayed_add_clause self ~keep:true c proof -let[@inline] mk_lit _ ?sign t : lit = Lit.atom ?sign t +let[@inline] mk_lit self ?sign t : lit = Lit.atom ?sign self.tst t let[@inline] add_lit self _acts ?default_pol lit = delayed_add_lit self ?default_pol lit let add_lit_t self _acts ?sign t = - let lit = Lit.atom ?sign t in + let lit = Lit.atom ?sign self.tst t in let lit, _ = simplify_and_preproc_lit self lit in delayed_add_lit self lit @@ -506,7 +506,7 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) semantic |> List.rev_map (fun (sign, t, u) -> let eqn = Term.eq self.tst t u in - let lit = Lit.atom ~sign:(not sign) eqn in + let lit = Lit.atom ~sign:(not sign) self.tst eqn in (* make sure to consider the new lit *) add_lit self acts lit; lit) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 8083fe3f..fd072a0d 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -305,7 +305,7 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model (* proof of assert-input + preprocessing *) let pr = add_step @@ fun () -> - let lits = List.map Lit.atom c_ts in + let lits = List.map (Solver.mk_lit_t solver) c_ts in Proof_sat.sat_input_clause lits in diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 86c7d46d..68c044e7 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -61,7 +61,7 @@ end = struct add_step_ @@ mk_step_ @@ fun () -> Proof_core.lemma_rw_clause c0 ~using - ~res:[ Lit.atom (A.mk_bool tst (B_eq (a, b))) ] + ~res:[ Lit.atom tst (A.mk_bool tst (B_eq (a, b))) ] in let[@inline] ret u = @@ -227,7 +227,7 @@ end = struct (mk_step_ @@ fun () -> Proof_core.lemma_true (Lit.term lit)) | _ when expanded self lit -> () (* already done *) | B_and (a, b) -> - let subs = List.map Lit.atom [ a; b ] in + let subs = List.map (Lit.atom self.tst) [ a; b ] in if Lit.sign lit then (* assert [(and …t_i) => t_i] *) @@ -245,7 +245,7 @@ end = struct (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) ) | B_or (a, b) -> - let subs = List.map Lit.atom [ a; b ] in + let subs = List.map (Lit.atom self.tst) [ a; b ] in if not @@ Lit.sign lit then (* propagate [¬sub_i \/ lit] *) @@ -262,8 +262,8 @@ end = struct add_axiom c (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "or-e" [ t ]) ) | B_imply (a, b) -> - let a = Lit.atom a in - let b = Lit.atom b in + let a = Lit.atom self.tst a in + let b = Lit.atom self.tst b in if Lit.sign lit then ( (* axiom [lit => a => b] *) let c = [ Lit.neg lit; Lit.neg a; b ] in @@ -286,7 +286,7 @@ end = struct (* boolean ite: just add [a => (ite a b c <=> b)] and [¬a => (ite a b c <=> c)] *) - let lit_a = Lit.atom a in + let lit_a = Lit.atom self.tst a in add_axiom [ Lit.neg lit_a; Lit.make_eq self.tst t b ] (mk_step_ @@ fun () -> Proof_rules.lemma_ite_true ~ite:t); @@ -294,20 +294,20 @@ end = struct [ Lit.neg lit; lit_a; Lit.make_eq self.tst t c ] (mk_step_ @@ fun () -> Proof_rules.lemma_ite_false ~ite:t) | B_equiv (a, b) -> - let a = Lit.atom a in - let b = Lit.atom b in + let a = Lit.atom self.tst a in + let b = Lit.atom self.tst b in equiv_ ~is_xor:false a b | B_eq (a, b) when T.is_bool a -> - let a = Lit.atom a in - let b = Lit.atom b in + let a = Lit.atom self.tst a in + let b = Lit.atom self.tst b in equiv_ ~is_xor:false a b | B_xor (a, b) -> - let a = Lit.atom a in - let b = Lit.atom b in + let a = Lit.atom self.tst a in + let b = Lit.atom self.tst b in equiv_ ~is_xor:true a b | B_neq (a, b) when T.is_bool a -> - let a = Lit.atom a in - let b = Lit.atom b in + let a = Lit.atom self.tst a in + let b = Lit.atom self.tst b in equiv_ ~is_xor:true a b | B_eq _ | B_neq _ -> () diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index fa0bf125..41c1c9c7 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -51,7 +51,7 @@ end = struct add_step_ @@ mk_step_ @@ fun () -> Proof_core.lemma_rw_clause c0 ~using - ~res:[ Lit.atom (A.mk_bool tst (B_eq (a, b))) ] + ~res:[ Lit.atom tst (A.mk_bool tst (B_eq (a, b))) ] in let[@inline] ret u = diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 333f270d..2b308703 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -354,7 +354,7 @@ end = struct let pr_isa = Proof_trace.add_step self.proof @@ fun () -> Proof_rules.lemma_isa_split t - [ Lit.atom (A.mk_is_a self.tst cstor t) ] + [ Lit.atom self.tst (A.mk_is_a self.tst cstor t) ] and pr_eq_sel = Proof_trace.add_step self.proof @@ fun () -> Proof_rules.lemma_select_cstor ~cstor_t:u t diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index c178eb48..6bfc48e1 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -335,7 +335,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct | _ -> assert false) | LRA_pred ((Eq | Neq), t1, t2) -> (* equality: just punt to [t1 = t2 <=> (t1 <= t2 /\ t1 >= t2)] *) - let _, t = Term.abs t in + let _, t = Term.abs self.tst t in if not (Term.Tbl.mem self.encoded_eqs t) then ( let u1 = A.mk_lra tst (LRA_pred (Leq, t1, t2)) in let u2 = A.mk_lra tst (LRA_pred (Geq, t1, t2)) in @@ -400,10 +400,10 @@ module Make (A : ARG) = (* : S with module A = A *) struct (Term.t * Proof_step.id Iter.t) option = let proof_eq t u = Proof_trace.add_step self.proof @@ fun () -> - A.lemma_lra [ Lit.atom (Term.eq self.tst t u) ] + A.lemma_lra [ Lit.atom self.tst (Term.eq self.tst t u) ] in let proof_bool t ~sign:b = - let lit = Lit.atom ~sign:b t in + let lit = Lit.atom ~sign:b self.tst t in Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] in @@ -526,7 +526,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct if LE_.Comb.is_empty le_comb then ( if A.Q.(le_const <> zero) then ( (* [c=0] when [c] is not 0 *) - let lit = Lit.atom ~sign:false @@ Term.eq self.tst t1 t2 in + let lit = Lit.atom ~sign:false self.tst @@ Term.eq self.tst t1 t2 in let pr = Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] in From dd66efb772c5edb08b53220d48d807dd8f0c0817 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:06:34 -0400 Subject: [PATCH 151/174] feat(term): add `App_uncurried` constructor sometimes currying is really costly. For example, in boolean formulas, the formula `/\_i=1^100 a_i` has 100 atoms as subterms, but if represented curried with binary `/\` it also has 98 intermediate conjunctions as subterms. With how the rest of sidekick works, this means each of these gets its own atom and CNF; instead we're going to use App_uncurried. --- src/core-logic/term.ml | 30 ++++++++++++++++++++++++++++-- src/core-logic/term.mli | 2 ++ src/core-logic/types_.ml | 1 + src/core/t_printer.ml | 6 +++++- 4 files changed, 36 insertions(+), 3 deletions(-) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index dee2d459..319eedb7 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -10,6 +10,7 @@ type view = term_view = | E_bound_var of bvar | E_const of const | E_app of term * term + | E_app_uncurried of { c: const; ty: term; args: term list } | E_lam of string * term * term | E_pi of string * term * term @@ -74,6 +75,10 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) bod + | E_app_uncurried { c; args; ty = _ } -> + Fmt.fprintf out "(@[%a" Const.pp c; + List.iter (fun x -> Fmt.fprintf out "@ %a" pp' x) args; + Fmt.fprintf out "@])" | E_lam (n, _ty, bod) -> Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty (loop (k + 1) ~depth:(depth + 1) (n :: names)) @@ -123,12 +128,14 @@ module Hcons = Hashcons.Make (struct | E_var v1, E_var v2 -> Var.equal v1 v2 | E_bound_var v1, E_bound_var v2 -> Bvar.equal v1 v2 | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 + | E_app_uncurried a1, E_app_uncurried a2 -> + Const.equal a1.c a2.c && List.equal equal a1.args a2.args | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 | E_pi (_, ty1, bod1), E_pi (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 - | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ | E_lam _ - | E_pi _ ), + | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ + | E_app_uncurried _ | E_lam _ | E_pi _ ), _ ) -> false @@ -139,6 +146,8 @@ module Hcons = Hashcons.Make (struct | E_var v -> H.combine2 30 (Var.hash v) | E_bound_var v -> H.combine2 40 (Bvar.hash v) | E_app (f, a) -> H.combine3 50 (hash f) (hash a) + | E_app_uncurried a -> + H.combine3 55 (Const.hash a.c) (Hash.list hash a.args) | E_lam (_, ty, bod) -> H.combine3 60 (hash ty) (hash bod) | E_pi (_, ty, bod) -> H.combine3 70 (hash ty) (hash bod) @@ -180,6 +189,9 @@ let iter_shallow ~f (e : term) : unit = | E_app (hd, a) -> f false hd; f false a + | E_app_uncurried { ty; args; _ } -> + f false ty; + List.iter (fun u -> f false u) args | E_lam (_, tyv, bod) | E_pi (_, tyv, bod) -> f false tyv; f true bod) @@ -206,6 +218,13 @@ let map_shallow_ ~make ~f (e : term) : term = e else make (E_app (f false hd, f false a)) + | E_app_uncurried { args = l; c; ty } -> + let l' = List.map (fun u -> f false u) l in + let ty' = f false ty in + if equal ty ty' && CCList.equal equal l l' then + e + else + make (E_app_uncurried { c; ty = ty'; args = l' }) | E_lam (n, tyv, bod) -> let tyv' = f false tyv in let bod' = f true bod in @@ -285,6 +304,8 @@ module Make_ = struct | E_type _ | E_const _ | E_var _ -> 0 | E_bound_var v -> v.bv_idx + 1 | E_app (a, b) -> max (db_depth a) (db_depth b) + | E_app_uncurried { args; _ } -> + List.fold_left (fun x u -> max x (db_depth u)) 0 args | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> max (db_depth ty) (max 0 (db_depth bod - 1)) in @@ -301,6 +322,7 @@ module Make_ = struct | E_var _ -> true | E_type _ | E_bound_var _ | E_const _ -> false | E_app (a, b) -> has_fvars a || has_fvars b + | E_app_uncurried { args; _ } -> List.exists has_fvars args | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod let universe_ (e : term) : int = @@ -428,6 +450,7 @@ module Make_ = struct "@[<2>cannot apply %a@ (to %a),@ must have Pi type, but actual type \ is %a@]" pp_debug f pp_debug a pp_debug ty_f) + | E_app_uncurried { ty; _ } -> ty | E_pi (_, ty, bod) -> (* TODO: check the actual triplets for COC *) (*Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod;*) @@ -478,6 +501,9 @@ module Make_ = struct let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l + let app_uncurried store c args ~ty : t = + make_ store (E_app_uncurried { c; args; ty }) + type cache = t T_int_tbl.t let create_cache : int -> cache = T_int_tbl.create diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index c6adfc0a..c3bc06a7 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -32,6 +32,7 @@ type view = term_view = | E_bound_var of bvar | E_const of const | E_app of t * t + | E_app_uncurried of { c: const; ty: term; args: term list } | E_lam of string * t * t | E_pi of string * t * t @@ -117,6 +118,7 @@ val bvar_i : store -> int -> ty:t -> t val const : store -> const -> t val app : store -> t -> t -> t val app_l : store -> t -> t list -> t +val app_uncurried : store -> const -> t list -> ty:t -> t val lam : store -> var -> t -> t val pi : store -> var -> t -> t val arrow : store -> t -> t -> t diff --git a/src/core-logic/types_.ml b/src/core-logic/types_.ml index 69d6e95d..ac2f7e55 100644 --- a/src/core-logic/types_.ml +++ b/src/core-logic/types_.ml @@ -16,6 +16,7 @@ type term_view = | E_bound_var of bvar | E_const of const | E_app of term * term + | E_app_uncurried of { c: const; ty: term; args: term list } | E_lam of string * term * term | E_pi of string * term * term diff --git a/src/core/t_printer.ml b/src/core/t_printer.ml index b5fdea62..92b885ff 100644 --- a/src/core/t_printer.ml +++ b/src/core/t_printer.ml @@ -49,6 +49,10 @@ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = | E_app _ -> let f, args = unfold_app e in Fmt.fprintf out "(%a@ %a)" pp' f (Util.pp_list pp') args + | E_app_uncurried { c; args; ty = _ } -> + Fmt.fprintf out "(@[%a" Const.pp c; + List.iter (fun x -> Fmt.fprintf out "@ %a" pp' x) args; + Fmt.fprintf out "@])" | E_lam ("", _ty, bod) -> Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) @@ -74,7 +78,7 @@ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = bod ) in - Fmt.fprintf out "@[%a@]" (loop 0 ~depth:0 []) e + Fmt.fprintf out "@[<1>%a@]" (loop 0 ~depth:0 []) e let pp_with hooks out e : unit = expr_pp_with_ ~max_depth:max_int ~hooks out e let pp out e = pp_with !default_hooks out e From 97629683735628431b92ffcfc4922c001e4fd45b Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:08:19 -0400 Subject: [PATCH 152/174] feat(bool): use lists for B_and/B_or, along with App_uncurried --- src/core/bool_view.ml | 4 +- src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 56 +++++++++++++----- src/th-bool-dyn/intf.ml | 4 +- src/th-bool-static/Sidekick_th_bool_static.ml | 57 ++++++++++++++----- src/th-bool-static/intf.ml | 4 +- 5 files changed, 90 insertions(+), 35 deletions(-) diff --git a/src/core/bool_view.ml b/src/core/bool_view.ml index f348cec5..d033e6ab 100644 --- a/src/core/bool_view.ml +++ b/src/core/bool_view.ml @@ -4,8 +4,8 @@ type 'a t = | B_bool of bool | B_not of 'a - | B_and of 'a * 'a - | B_or of 'a * 'a + | B_and of 'a list + | B_or of 'a list | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 68c044e7..43c388fc 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -46,6 +46,22 @@ end = struct | Some false -> true | _ -> false + let unfold_and t : T.Set.t = + let rec aux acc t = + match A.view_as_bool t with + | B_and l -> List.fold_left aux acc l + | _ -> T.Set.add t acc + in + aux T.Set.empty t + + let unfold_or t : T.Set.t = + let rec aux acc t = + match A.view_as_bool t with + | B_or l -> List.fold_left aux acc l + | _ -> T.Set.add t acc + in + aux T.Set.empty t + (* TODO: share this with th-bool-static by way of a library for boolean simplification? (also handle one-point rule and the likes) *) let simplify (self : state) (simp : Simplify.t) (t : T.t) : @@ -81,20 +97,32 @@ end = struct | B_not u when is_false u -> ret_bequiv t (T.true_ tst) | B_not _ -> None | B_atom _ -> None - | B_and (a, b) -> - if is_false a || is_false b then + | B_and _ -> + let set = unfold_and t in + if T.Set.exists is_false set then ret (T.false_ tst) - else if is_true a && is_true b then + else if T.Set.for_all is_true set then ret (T.true_ tst) - else - None - | B_or (a, b) -> - if is_true a || is_true b then + else ( + let t' = A.mk_bool tst (B_and (T.Set.to_list set)) in + if not (T.equal t t') then + ret_bequiv t t' + else + None + ) + | B_or _ -> + let set = unfold_or t in + if T.Set.exists is_true set then ret (T.true_ tst) - else if is_false a && is_false b then + else if T.Set.for_all is_false set then ret (T.false_ tst) - else - None + else ( + let t' = A.mk_bool tst (B_or (T.Set.to_list set)) in + if not (T.equal t t') then + ret_bequiv t t' + else + None + ) | B_imply (a, b) -> if is_false a || is_true b then ret (T.true_ tst) @@ -226,8 +254,8 @@ end = struct [ Lit.neg lit ] (mk_step_ @@ fun () -> Proof_core.lemma_true (Lit.term lit)) | _ when expanded self lit -> () (* already done *) - | B_and (a, b) -> - let subs = List.map (Lit.atom self.tst) [ a; b ] in + | B_and l -> + let subs = List.map (Lit.atom self.tst) l in if Lit.sign lit then (* assert [(and …t_i) => t_i] *) @@ -244,8 +272,8 @@ end = struct add_axiom c (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) ) - | B_or (a, b) -> - let subs = List.map (Lit.atom self.tst) [ a; b ] in + | B_or l -> + let subs = List.map (Lit.atom self.tst) l in if not @@ Lit.sign lit then (* propagate [¬sub_i \/ lit] *) diff --git a/src/th-bool-dyn/intf.ml b/src/th-bool-dyn/intf.ml index 1e36c444..8552ced8 100644 --- a/src/th-bool-dyn/intf.ml +++ b/src/th-bool-dyn/intf.ml @@ -9,8 +9,8 @@ type ty = Term.t type 'a bool_view = 'a Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'a * 'a - | B_or of 'a * 'a + | B_and of 'a list + | B_or of 'a list | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 41c1c9c7..bb39457e 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -38,6 +38,22 @@ end = struct | Some false -> true | _ -> false + let unfold_and t : T.Set.t = + let rec aux acc t = + match A.view_as_bool t with + | B_and l -> List.fold_left aux acc l + | _ -> T.Set.add t acc + in + aux T.Set.empty t + + let unfold_or t : T.Set.t = + let rec aux acc t = + match A.view_as_bool t with + | B_or l -> List.fold_left aux acc l + | _ -> T.Set.add t acc + in + aux T.Set.empty t + let simplify (self : state) (simp : Simplify.t) (t : T.t) : (T.t * Proof_step.id Iter.t) option = let tst = self.tst in @@ -71,20 +87,32 @@ end = struct | B_not u when is_false u -> ret_bequiv t (T.true_ tst) | B_not _ -> None | B_atom _ -> None - | B_and (a, b) -> - if is_false a || is_false b then + | B_and _ -> + let set = unfold_and t in + if T.Set.exists is_false set then ret (T.false_ tst) - else if is_true a && is_true b then + else if T.Set.for_all is_true set then ret (T.true_ tst) - else - None - | B_or (a, b) -> - if is_true a || is_true b then + else ( + let t' = A.mk_bool tst (B_and (T.Set.to_list set)) in + if not (T.equal t t') then + ret_bequiv t t' + else + None + ) + | B_or _ -> + let set = unfold_or t in + if T.Set.exists is_true set then ret (T.true_ tst) - else if is_false a && is_false b then + else if T.Set.for_all is_false set then ret (T.false_ tst) - else - None + else ( + let t' = A.mk_bool tst (B_or (T.Set.to_list set)) in + if not (T.equal t t') then + ret_bequiv t t' + else + None + ) | B_imply (a, b) -> if is_false a || is_true b then ret (T.true_ tst) @@ -185,13 +213,12 @@ end = struct mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "eq-i-" [ t ]) in - (* make a literal for [t], with a proof of [|- abs(t) = abs(lit)] *) (match A.view_as_bool t with | B_bool _ -> () | B_not _ -> () - | B_and (a, b) -> + | B_and l -> let lit = PA.mk_lit t in - let subs = List.map PA.mk_lit [ a; b ] in + let subs = List.map PA.mk_lit l in (* add clauses *) List.iter @@ -207,8 +234,8 @@ end = struct PA.add_clause (lit :: List.map Lit.neg subs) (mk_step_ @@ fun () -> Proof_rules.lemma_bool_c "and-i" [ t ]) - | B_or (a, b) -> - let subs = List.map PA.mk_lit [ a; b ] in + | B_or l -> + let subs = List.map PA.mk_lit l in let lit = PA.mk_lit t in (* add clauses *) diff --git a/src/th-bool-static/intf.ml b/src/th-bool-static/intf.ml index 1e36c444..8552ced8 100644 --- a/src/th-bool-static/intf.ml +++ b/src/th-bool-static/intf.ml @@ -9,8 +9,8 @@ type ty = Term.t type 'a bool_view = 'a Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'a * 'a - | B_or of 'a * 'a + | B_and of 'a list + | B_or of 'a list | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a From 279ceade7869f6defbfeec2d26073c9784101a59 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:09:05 -0400 Subject: [PATCH 153/174] feat(base): in Form, use uncurried forms for and/or --- src/base/Form.ml | 94 ++++++++++++++++++++++++++------------------- src/base/Form.mli | 4 +- src/base/th_data.ml | 6 ++- 3 files changed, 61 insertions(+), 43 deletions(-) diff --git a/src/base/Form.ml b/src/base/Form.ml index 0c72c2b1..59ea3a01 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -8,8 +8,8 @@ type term = Term.t type 'a view = 'a Sidekick_core.Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'a * 'a - | B_or of 'a * 'a + | B_and of 'a list + | B_or of 'a list | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a @@ -18,51 +18,77 @@ type 'a view = 'a Sidekick_core.Bool_view.t = | B_ite of 'a * 'a * 'a | B_atom of 'a -(* ### allocate special IDs for connectors *) +type Const.view += C_and | C_or | C_imply -let id_and = ID.make "and" -let id_or = ID.make "or" -let id_imply = ID.make "=>" +let ops : Const.ops = + (module struct + let pp out = function + | C_and -> Fmt.string out "and" + | C_or -> Fmt.string out "or" + | C_imply -> Fmt.string out "=>" + | _ -> assert false + + let equal a b = + match a, b with + | C_and, C_and | C_or, C_or | C_imply, C_imply -> true + | _ -> false + + let hash = function + | C_and -> Hash.int 425 + | C_or -> Hash.int 426 + | C_imply -> Hash.int 427 + | _ -> assert false + end) (* ### view *) exception Not_a_th_term -let view_id_ fid args = - match args with - | [ a; b ] when ID.equal fid id_and -> B_and (a, b) - | [ a; b ] when ID.equal fid id_or -> B_or (a, b) - | [ a; b ] when ID.equal fid id_imply -> B_imply (a, b) - | _ -> raise_notrace Not_a_th_term - let view (t : T.t) : T.t view = let hd, args = T.unfold_app t in match T.view hd, args with | E_const { Const.c_view = T.C_true; _ }, [] -> B_bool true | E_const { Const.c_view = T.C_false; _ }, [] -> B_bool false | E_const { Const.c_view = T.C_not; _ }, [ a ] -> B_not a - | E_const { Const.c_view = T.C_eq; _ }, [ _ty; a; b ] -> B_eq (a, b) + | E_const { Const.c_view = T.C_eq; _ }, [ _ty; a; b ] -> + if Ty.is_bool a then + B_equiv (a, b) + else + B_eq (a, b) | E_const { Const.c_view = T.C_ite; _ }, [ _ty; a; b; c ] -> B_ite (a, b, c) - | E_const { Const.c_view = Uconst.Uconst { uc_id; _ }; _ }, _ -> - (try view_id_ uc_id args with Not_a_th_term -> B_atom t) + | E_app_uncurried { c = { Const.c_view = C_and; _ }; args; _ }, _ -> + B_and args + | E_app_uncurried { c = { Const.c_view = C_or; _ }; args; _ }, _ -> B_or args + | E_app_uncurried { c = { Const.c_view = C_imply; _ }; args = [ a; b ]; _ }, _ + -> + B_imply (a, b) | _ -> B_atom t -let c_and tst : Term.t = +let ty2b_ tst = let bool = Term.bool tst in - Uconst.uconst_of_id' tst id_and [ bool; bool ] bool + Term.arrow_l tst [ bool; bool ] bool -let c_or tst : Term.t = - let bool = Term.bool tst in - Uconst.uconst_of_id' tst id_or [ bool; bool ] bool +let c_and tst : Const.t = Const.make C_and ops ~ty:(ty2b_ tst) +let c_or tst : Const.t = Const.make C_or ops ~ty:(ty2b_ tst) +let c_imply tst : Const.t = Const.make C_imply ops ~ty:(ty2b_ tst) -let c_imply tst : Term.t = - let bool = Term.bool tst in - Uconst.uconst_of_id' tst id_imply [ bool; bool ] bool +let and_l tst = function + | [] -> T.true_ tst + | [ x ] -> x + | l -> Term.app_uncurried tst (c_and tst) l ~ty:(Term.bool tst) + +let or_l tst = function + | [] -> T.false_ tst + | [ x ] -> x + | l -> Term.app_uncurried tst (c_or tst) l ~ty:(Term.bool tst) let bool = Term.bool_val -let and_ tst a b = Term.app_l tst (c_and tst) [ a; b ] -let or_ tst a b = Term.app_l tst (c_or tst) [ a; b ] -let imply tst a b = Term.app_l tst (c_imply tst) [ a; b ] +let and_ tst a b = and_l tst [ a; b ] +let or_ tst a b = or_l tst [ a; b ] + +let imply tst a b : Term.t = + Term.app_uncurried tst (c_imply tst) [ a; b ] ~ty:(Term.bool tst) + let eq = T.eq let not_ = T.not let ite = T.ite @@ -76,16 +102,6 @@ let equiv tst a b = let xor tst a b = not_ tst (equiv tst a b) -let and_l tst = function - | [] -> T.true_ tst - | [ x ] -> x - | x :: tl -> List.fold_left (and_ tst) x tl - -let or_l tst = function - | [] -> T.false_ tst - | [ x ] -> x - | x :: tl -> List.fold_left (or_ tst) x tl - let distinct_l tst l = match l with | [] | [ _ ] -> T.true_ tst @@ -97,8 +113,8 @@ let distinct_l tst l = let mk_of_view tst = function | B_bool b -> T.bool_val tst b | B_atom t -> t - | B_and (a, b) -> and_ tst a b - | B_or (a, b) -> or_ tst a b + | B_and l -> and_l tst l + | B_or l -> or_l tst l | B_imply (a, b) -> imply tst a b | B_ite (a, b, c) -> ite tst a b c | B_equiv (a, b) -> equiv tst a b diff --git a/src/base/Form.mli b/src/base/Form.mli index 6b9c2c4f..aba84e9f 100644 --- a/src/base/Form.mli +++ b/src/base/Form.mli @@ -14,8 +14,8 @@ type term = Term.t type 'a view = 'a Sidekick_core.Bool_view.t = | B_bool of bool | B_not of 'a - | B_and of 'a * 'a - | B_or of 'a * 'a + | B_and of 'a list + | B_or of 'a list | B_imply of 'a * 'a | B_equiv of 'a * 'a | B_xor of 'a * 'a diff --git a/src/base/th_data.ml b/src/base/th_data.ml index 20ffeb16..338589bb 100644 --- a/src/base/th_data.ml +++ b/src/base/th_data.ml @@ -32,7 +32,9 @@ let arg = Ty_data { cstors } | None, E_app (a, b) -> Ty_other { sub = [ a; b ] } | None, E_pi (_, a, b) -> Ty_other { sub = [ a; b ] } - | None, (E_const _ | E_var _ | E_type _ | E_bound_var _ | E_lam _) -> + | ( None, + ( E_const _ | E_var _ | E_type _ | E_bound_var _ | E_lam _ + | E_app_uncurried _ ) ) -> Ty_other { sub = [] } ) @@ -67,7 +69,7 @@ let arg = let rec ty_is_finite ty = match Term.view ty with | E_const { Const.c_view = Uconst.Uconst _; _ } -> true - | E_const { Const.c_view = Data_ty.Data d; _ } -> true (* TODO: ?? *) + | E_const { Const.c_view = Data_ty.Data _d; _ } -> true (* TODO: ?? *) | E_pi (_, a, b) -> ty_is_finite a && ty_is_finite b | _ -> true From dde63a9ef23375829dd451116ea2e288078c83a7 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:09:36 -0400 Subject: [PATCH 154/174] refactor: stats, small changes --- src/smt/solver_internal.ml | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index c9b5b8c3..1efe553b 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -455,9 +455,12 @@ let check_cc_with_acts_ (self : t) (acts : theory_actions) = (function | CC.Result_action.Act_propagate { lit; reason } -> let reason = Sidekick_sat.Consequence reason in + Stat.incr self.count_propagate; A.propagate lit reason) acts - | Error (CC.Result_action.Conflict (lits, pr)) -> A.raise_conflict lits pr + | Error (CC.Result_action.Conflict (lits, pr)) -> + Stat.incr self.count_conflict; + A.raise_conflict lits pr (* handle a literal assumed by the SAT solver *) let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) @@ -471,16 +474,16 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) self.level (Util.pp_iter ~sep:"; " Lit.pp) lits); - (* transmit to CC *) let cc = cc self in + (* transmit to CC *) if not final then CC.assert_lits cc lits; - (* transmit to theories. *) check_cc_with_acts_ self acts; if final then ( Perform_delayed_th.top self acts; + (* transmit to theories. *) List.iter (fun f -> f self acts lits) self.on_final_check; check_cc_with_acts_ self acts; @@ -526,6 +529,7 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) Perform_delayed_th.top self acts ) else ( + (* partial check *) List.iter (fun f -> f self acts lits) self.on_partial_check; (* re-check CC after theory actions, which might have merged classes *) check_cc_with_acts_ self acts; @@ -563,15 +567,15 @@ let[@inline] final_check (self : t) (acts : Sidekick_sat.acts) : unit = let push_level self : unit = self.level <- 1 + self.level; CC.push_level (cc self); - push_lvl_ self.th_states + push_lvl_theories_ self.th_states let pop_levels self n : unit = self.last_model <- None; self.level <- self.level - n; CC.pop_levels (cc self) n; - pop_lvls_ n self.th_states + pop_lvls_theories_ n self.th_states -let n_levels self = self.level +let[@inline] n_levels self = self.level let to_sat_plugin (self : t) : (module Sidekick_sat.PLUGIN) = (module struct @@ -587,6 +591,7 @@ let declare_pb_is_incomplete self = self.complete <- false let add_theory_state ~st ~push_level ~pop_levels (self : t) = + assert (self.level = 0); self.th_states <- Ths_cons { st; push_level; pop_levels; next = self.th_states } From 6ad07921c4c986954edafe9868fb9d9670f48040 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Mon, 22 Aug 2022 22:09:58 -0400 Subject: [PATCH 155/174] details --- src/smt/solver_internal.ml | 8 ++++---- src/th-data/Sidekick_th_data.ml | 1 - 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 1efe553b..485a3a2b 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -314,17 +314,17 @@ let cc_resolve_expl self e : lit list * _ = (** {2 Interface with the SAT solver} *) -let rec push_lvl_ = function +let rec push_lvl_theories_ = function | Ths_nil -> () | Ths_cons r -> r.push_level r.st; - push_lvl_ r.next + push_lvl_theories_ r.next -let rec pop_lvls_ n = function +let rec pop_lvls_theories_ n = function | Ths_nil -> () | Ths_cons r -> r.pop_levels r.st n; - pop_lvls_ n r.next + pop_lvls_theories_ n r.next (** {2 Model construction and theory combination} *) diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 2b308703..17b34832 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -715,7 +715,6 @@ end = struct ) let on_partial_check self solver acts trail = - Profile.with_ "data.partial-check" @@ fun () -> check_is_a self solver acts trail; () From 4d78be0c52a8776cac92aec5508ff47bcf53e587 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 25 Aug 2022 20:13:49 -0400 Subject: [PATCH 156/174] wip: model builder --- src/smt/Sidekick_smt_solver.ml | 1 + src/smt/model_builder.ml | 60 ++++++++++++++++++ src/smt/model_builder.mli | 37 +++++++++++ src/smt/solver_internal.ml | 106 +++++++++++++------------------- src/smt/solver_internal.mli | 22 ++++--- src/th-data/Sidekick_th_data.ml | 63 ++++++++----------- src/th-lra/sidekick_th_lra.ml | 5 +- 7 files changed, 181 insertions(+), 113 deletions(-) create mode 100644 src/smt/model_builder.ml create mode 100644 src/smt/model_builder.mli diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index a0e5b0c7..a93e20c1 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -8,6 +8,7 @@ module Sigs = Sigs module Model = Model +module Model_builder = Model_builder module Registry = Registry module Solver_internal = Solver_internal module Solver = Solver diff --git a/src/smt/model_builder.ml b/src/smt/model_builder.ml new file mode 100644 index 00000000..7c6af253 --- /dev/null +++ b/src/smt/model_builder.ml @@ -0,0 +1,60 @@ +open Sidekick_core +open Sigs +module T = Term + +type t = { + tst: Term.store; + m: Term.t T.Tbl.t; + required: Term.t Queue.t; + gensym: Gensym.t; +} + +let create tst : t = + { + tst; + m = T.Tbl.create 8; + 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) + (Iter.of_queue self.required) + +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 -> Some t + +let require_eval (self : t) t : unit = + if not @@ T.Tbl.mem self.m t then Queue.push t self.required + +let mem self t : bool = T.Tbl.mem self.m t + +let add (self : t) ?(subs = []) t v : unit = + assert (not @@ T.Tbl.mem self.m t); + T.Tbl.add self.m t v; + 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 + T.Internal_.replace_ ~cache self.tst ~recursive:true t ~f:(fun ~recurse:_ u -> + T.Tbl.find_opt 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 + |> Iter.map (fun t -> t, eval ~cache self t) + |> T.Tbl.of_iter + in + Model.Internal_.of_tbl tbl diff --git a/src/smt/model_builder.mli b/src/smt/model_builder.mli new file mode 100644 index 00000000..f149a916 --- /dev/null +++ b/src/smt/model_builder.mli @@ -0,0 +1,37 @@ +(** Model Builder. + + This contains a partial model, in construction. It is accessible to every + theory, so they can contribute partial values. + + TODO: seen values? +*) + +open Sidekick_core +open Sigs + +type t + +include Sidekick_sigs.PRINT with type t := t + +val create : Term.store -> t +val mem : t -> Term.t -> bool + +val require_eval : t -> Term.t -> unit +(** Require that this term gets a value. *) + +val add : t -> ?subs:Term.t list -> Term.t -> value -> unit +(** Add a value to the model. + @param subs if provided, these terms will be passed to {!require_eval} + to ensure they map to a value. *) + +val gensym : t -> pre:string -> ty:Term.t -> Term.t +(** New fresh constant *) + +type eval_cache = Term.Internal_.cache + +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 diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 485a3a2b..77ce6b6e 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -63,9 +63,9 @@ type t = { and preprocess_hook = t -> preprocess_actions -> term -> unit and model_ask_hook = - recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option + t -> Model_builder.t -> Term.t -> (value * Term.t list) option -and model_completion_hook = t -> add:(term -> term -> unit) -> unit +and model_completion_hook = t -> add:(term -> value -> unit) -> unit type solver = t @@ -330,90 +330,70 @@ let rec pop_lvls_theories_ n = function (* make model from the congruence closure *) let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = + let@ () = Profile.with_ "smt-solver.mk-model" in Log.debug 1 "(smt.solver.mk-model)"; - Profile.with_ "smt-solver.mk-model" @@ fun () -> - let module M = Term.Tbl in + let module MB = Model_builder in let { cc; tst; model_ask = model_ask_hooks; model_complete; _ } = self in - let model = M.create 128 in + let model = Model_builder.create tst in (* first, add all literals to the model using the given propositional model - [lits]. *) + induced by the trail [lits]. *) lits (fun lit -> let t, sign = Lit.signed_term lit in - M.replace model t (Term.bool_val tst sign)); + MB.add model t (Term.bool_val tst sign)); - (* populate with information from the CC *) - (* FIXME - CC.get_model_for_each_class cc (fun (_, ts, v) -> - Iter.iter - (fun n -> - let t = E_node.term n in - M.replace model t v) - ts); - *) - - (* complete model with theory specific values *) + (* complete model with theory specific values using the completion hooks. + This generally adds values that theories already explicitly have + computed in their theory-specific models, e.g. in the simplexe. *) let complete_with f = - f self ~add:(fun t u -> - if not (M.mem model t) then ( + f self ~add:(fun t v -> + if not (MB.mem model t) then ( Log.debugf 20 (fun k -> - k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp_debug t - Term.pp_debug u); - M.replace model t u + k "(@[smt.model-complete@ %a@ :with-val %a@])" Term.pp t Term.pp v); + MB.add model t v )) in List.iter complete_with model_complete; - (* compute a value for [n]. *) - let rec val_for_class (n : E_node.t) : term = - Log.debugf 5 (fun k -> k "val-for-term %a" E_node.pp n); - let repr = CC.find cc n in - Log.debugf 5 (fun k -> k "val-for-term.repr %a" E_node.pp repr); + (* require a value for each class that doesn't already have one *) + CC.all_classes cc (fun repr -> + let t = E_node.term repr in + MB.require_eval model t); + + (* now for the fixpoint. This is typically where composite theories such + as arrays and datatypes contribute their skeleton values. *) + let rec compute_fixpoint () = + match MB.pop_required model with + | None -> () + | Some t -> + (* compute a value for [t] *) + Log.debugf 5 (fun k -> + k "(@[model.fixpoint.compute-for-required@ %a@])" Term.pp t); - (* see if a value is found already (always the case if it's a boolean) *) - match M.get model (E_node.term repr) with - | Some t_val -> - Log.debugf 5 (fun k -> k "cached val is %a" Term.pp_debug t_val); - t_val - | None -> (* try each model hook *) let rec try_hooks_ = function - | [] -> E_node.term repr + | [] -> + let c = MB.gensym model ~pre:"@c" ~ty:(Term.ty t) in + Log.debugf 10 (fun k -> + k "(@[model.fixpoint.pick-default-val@ %a@ :for %a@])" Term.pp c + Term.pp t); + MB.add model t c | h :: hooks -> - (match h ~recurse:(fun _ n -> val_for_class n) self repr with + (match h self model t with | None -> try_hooks_ hooks - | Some t -> t) + | Some (v, subs) -> + MB.add model ~subs t v; + ()) in - let t_val = - try_hooks_ model_ask_hooks - (* FIXME: the more complete version? - match - (* look for a value in the model for any term in the class *) - E_node.iter_class repr - |> Iter.find_map (fun n -> M.get model (E_node.term n)) - with - | Some v -> v - | None -> try_hooks_ model_ask_hooks - *) - in - - M.replace model (E_node.term repr) t_val; - (* be sure to cache the value *) - Log.debugf 5 (fun k -> k "val is %a" Term.pp_debug t_val); - t_val + try_hooks_ model_ask_hooks; + (* continue to next value *) + (compute_fixpoint [@tailcall]) () in - (* map terms of each CC class to the value computed for their class. *) - CC.all_classes cc (fun repr -> - let t_val = val_for_class repr in - (* value for this class *) - E_node.iter_class repr (fun u -> - let t_u = E_node.term u in - if (not (E_node.equal u repr)) && not (Term.equal t_u t_val) then - M.replace model t_u t_val)); - Model.Internal_.of_tbl model + compute_fixpoint (); + MB.to_model model (* do theory combination using the congruence closure. Each theory can merge classes, *) diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index 72a28d30..c9c03255 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -234,20 +234,24 @@ val declare_pb_is_incomplete : t -> unit (** {3 Model production} *) type model_ask_hook = - recurse:(t -> E_node.t -> term) -> t -> E_node.t -> term option + t -> Model_builder.t -> Term.t -> (value * Term.t list) option (** A model-production hook to query values from a theory. - It takes the solver, a class, and returns - a term for this class. For example, an arithmetic theory - might detect that a class contains a numeric constant, and return - this constant as a model value. + It takes the solver, a class, and returns an optional value for this class + (potentially with sub-terms to find values for, if the value is actually a + skeleton). - If no hook assigns a value to a class, a fake value is created for it. - *) + For example, an arithmetic theory might detect that a class contains a + numeric constant, and return this constant as a model value. The theory + of arrays might return [array.const $v] for an array [Array A B], + where [$v] will be picked by the theory of the sort [B]. -type model_completion_hook = t -> add:(term -> term -> unit) -> unit + If no hook assigns a value to a class, a fake value is created for it. +*) + +type model_completion_hook = t -> add:(term -> value -> unit) -> unit (** A model production hook, for the theory to add values. - The hook is given a [add] function to add bindings to the model. *) + The hook is given a [add] function to add bindings to the model. *) val on_model : ?ask:model_ask_hook -> ?complete:model_completion_hook -> t -> unit diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index 17b34832..b44fdd3e 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -4,6 +4,7 @@ open Sidekick_core open Sidekick_cc include Th_intf module SI = SMT.Solver_internal +module Model_builder = SMT.Model_builder let name = "th-data" @@ -749,52 +750,38 @@ end = struct l); Profile.instant "data.case-split"; List.iter (decide_class_ self solver acts) l); - - if remaining_to_decide = [] then ( - let next_decision = None in - match next_decision with - | None -> () (* all decided *) - | Some n -> - let t = E_node.term n in - - Profile.instant "data.decide"; - - (* use a constructor that will not lead to an infinite loop *) - let base_cstor = - match Card.base_cstor self.cards (Term.ty t) with - | None -> - Error.errorf "th-data:@ %a should have base cstor" E_node.pp n - | Some c -> c - in - let cstor_app = - let args = - A.Cstor.ty_args base_cstor - |> List.mapi (fun i _ -> A.mk_sel self.tst base_cstor i t) - in - A.mk_cstor self.tst base_cstor args - in - let t_eq_cstor = A.mk_eq self.tst t cstor_app in - Log.debugf 20 (fun k -> - k "(@[th-data.final-check.model.decide-cstor@ %a@])" Term.pp_debug - t_eq_cstor); - let lit = SI.mk_lit solver t_eq_cstor in - SI.push_decision solver acts lit - ); () - let on_model_gen (self : t) ~recurse (si : SI.t) (n : E_node.t) : - Term.t option = + let on_model_gen (self : t) (si : SI.t) (model : Model_builder.t) (t : Term.t) + : _ option = (* TODO: option to complete model or not (by picking sth at leaves)? *) let cc = SI.cc si in - let repr = CC.find cc n in - match ST_cstors.get self.cstors repr with - | None -> None + match + try + let repr = CC.find_t cc t in + ST_cstors.get self.cstors repr + with Not_found -> None + with | Some c -> + (* return the known constructor for this class *) Log.debugf 5 (fun k -> k "(@[th-data.mk-model.find-cstor@ %a@])" Monoid_cstor.pp c); - let args = List.map (recurse si) c.c_args in + let args = List.map E_node.term c.c_args in let t = A.mk_cstor self.tst c.c_cstor args in - Some t + Some (t, args) + | None when is_data_ty (Term.ty t) -> + (* datatype not split upon, use the base constructor for it *) + (match Card.base_cstor self.cards (Term.ty t) with + | None -> None + | Some c -> + (* invent new args *) + let args = + A.Cstor.ty_args c + |> List.map (fun ty -> Model_builder.gensym model ~pre:"c_arg" ~ty) + in + let c = A.mk_cstor self.tst c args in + Some (c, args)) + | None -> None let create_and_setup (solver : SI.t) : t = let self = diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index 6bfc48e1..ec9f9188 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -664,15 +664,14 @@ module Make (A : ARG) = (* : S with module A = A *) struct () (* help generating model *) - let model_ask_ (self : state) ~recurse:_ _si n : _ option = - let t = E_node.term n in + let model_ask_ (self : state) _si _model (t : Term.t) : _ option = match self.last_res with | Some (SimpSolver.Sat m) -> Log.debugf 50 (fun k -> k "(@[lra.model-ask@ %a@])" Term.pp_debug t); (match A.view_as_lra t with | LRA_const n -> Some n (* always eval constants to themselves *) | _ -> SimpSolver.V_map.get t m) - |> Option.map (t_const self) + |> Option.map (fun t -> t_const self t, []) | _ -> None (* help generating model *) From f6efc8f5758aa3369cfbbf087e5857de45046593 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 25 Aug 2022 20:50:50 -0400 Subject: [PATCH 157/174] more unsat tests --- tests/unsat/eq_diamond17.smt2 | 63 +++++++ tests/unsat/gensys_brn105.smt2 | 276 ++++++++++++++++++++++++++++ tests/unsat/typed_v2l20025.cvc.smt2 | 31 ++++ tests/unsat/typed_v3l60024.cvc.smt2 | 34 ++++ tests/unsat/typed_v5l50010.cvc.smt2 | 40 ++++ 5 files changed, 444 insertions(+) create mode 100644 tests/unsat/eq_diamond17.smt2 create mode 100644 tests/unsat/gensys_brn105.smt2 create mode 100644 tests/unsat/typed_v2l20025.cvc.smt2 create mode 100644 tests/unsat/typed_v3l60024.cvc.smt2 create mode 100644 tests/unsat/typed_v5l50010.cvc.smt2 diff --git a/tests/unsat/eq_diamond17.smt2 b/tests/unsat/eq_diamond17.smt2 new file mode 100644 index 00000000..9709591a --- /dev/null +++ b/tests/unsat/eq_diamond17.smt2 @@ -0,0 +1,63 @@ +(set-info :smt-lib-version 2.6) +(set-logic QF_UF) +(set-info :source | +Generating minimum transitivity constraints in P-time for deciding Equality Logic, +Ofer Strichman and Mirron Rozanov, +SMT Workshop 2005. + +Translator: Leonardo de Moura. |) +(set-info :category "crafted") +(set-info :status unsat) +(declare-sort U 0) +(declare-fun x0 () U) +(declare-fun y0 () U) +(declare-fun z0 () U) +(declare-fun x1 () U) +(declare-fun y1 () U) +(declare-fun z1 () U) +(declare-fun x2 () U) +(declare-fun y2 () U) +(declare-fun z2 () U) +(declare-fun x3 () U) +(declare-fun y3 () U) +(declare-fun z3 () U) +(declare-fun x4 () U) +(declare-fun y4 () U) +(declare-fun z4 () U) +(declare-fun x5 () U) +(declare-fun y5 () U) +(declare-fun z5 () U) +(declare-fun x6 () U) +(declare-fun y6 () U) +(declare-fun z6 () U) +(declare-fun x7 () U) +(declare-fun y7 () U) +(declare-fun z7 () U) +(declare-fun x8 () U) +(declare-fun y8 () U) +(declare-fun z8 () U) +(declare-fun x9 () U) +(declare-fun y9 () U) +(declare-fun z9 () U) +(declare-fun x10 () U) +(declare-fun y10 () U) +(declare-fun z10 () U) +(declare-fun x11 () U) +(declare-fun y11 () U) +(declare-fun z11 () U) +(declare-fun x12 () U) +(declare-fun y12 () U) +(declare-fun z12 () U) +(declare-fun x13 () U) +(declare-fun y13 () U) +(declare-fun z13 () U) +(declare-fun x14 () U) +(declare-fun y14 () U) +(declare-fun z14 () U) +(declare-fun x15 () U) +(declare-fun y15 () U) +(declare-fun z15 () U) +(declare-fun x16 () U) +(assert (and (or (and (= x0 y0) (= y0 x1)) (and (= x0 z0) (= z0 x1))) (or (and (= x1 y1) (= y1 x2)) (and (= x1 z1) (= z1 x2))) (or (and (= x2 y2) (= y2 x3)) (and (= x2 z2) (= z2 x3))) (or (and (= x3 y3) (= y3 x4)) (and (= x3 z3) (= z3 x4))) (or (and (= x4 y4) (= y4 x5)) (and (= x4 z4) (= z4 x5))) (or (and (= x5 y5) (= y5 x6)) (and (= x5 z5) (= z5 x6))) (or (and (= x6 y6) (= y6 x7)) (and (= x6 z6) (= z6 x7))) (or (and (= x7 y7) (= y7 x8)) (and (= x7 z7) (= z7 x8))) (or (and (= x8 y8) (= y8 x9)) (and (= x8 z8) (= z8 x9))) (or (and (= x9 y9) (= y9 x10)) (and (= x9 z9) (= z9 x10))) (or (and (= x10 y10) (= y10 x11)) (and (= x10 z10) (= z10 x11))) (or (and (= x11 y11) (= y11 x12)) (and (= x11 z11) (= z11 x12))) (or (and (= x12 y12) (= y12 x13)) (and (= x12 z12) (= z12 x13))) (or (and (= x13 y13) (= y13 x14)) (and (= x13 z13) (= z13 x14))) (or (and (= x14 y14) (= y14 x15)) (and (= x14 z14) (= z14 x15))) (or (and (= x15 y15) (= y15 x16)) (and (= x15 z15) (= z15 x16))) (not (= x0 x16)))) +(check-sat) +(exit) diff --git a/tests/unsat/gensys_brn105.smt2 b/tests/unsat/gensys_brn105.smt2 new file mode 100644 index 00000000..211de530 --- /dev/null +++ b/tests/unsat/gensys_brn105.smt2 @@ -0,0 +1,276 @@ +(set-info :smt-lib-version 2.6) +(set-logic QF_UF) +(set-info :source | +http://www.cs.bham.ac.uk/~vxs/quasigroups/benchmark/ + +|) +(set-info :category "crafted") +(set-info :status unsat) +(declare-sort U 0) +(declare-sort I 0) +(declare-fun unit () I) +(declare-fun op (I I) I) +(declare-fun e5 () I) +(declare-fun e4 () I) +(declare-fun e3 () I) +(declare-fun e2 () I) +(declare-fun e1 () I) +(declare-fun e0 () I) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e0 e1)) (?v_2 (op e0 e2)) (?v_3 (op e0 e3)) (?v_4 (op e0 e4)) (?v_5 (op e0 e5)) (?v_6 (op e1 e0)) (?v_7 (op e1 e1)) (?v_8 (op e1 e2)) (?v_9 (op e1 e3)) (?v_10 (op e1 e4)) (?v_11 (op e1 e5)) (?v_12 (op e2 e0)) (?v_13 (op e2 e1)) (?v_14 (op e2 e2)) (?v_15 (op e2 e3)) (?v_16 (op e2 e4)) (?v_17 (op e2 e5)) (?v_18 (op e3 e0)) (?v_19 (op e3 e1)) (?v_20 (op e3 e2)) (?v_21 (op e3 e3)) (?v_22 (op e3 e4)) (?v_23 (op e3 e5)) (?v_24 (op e4 e0)) (?v_25 (op e4 e1)) (?v_26 (op e4 e2)) (?v_27 (op e4 e3)) (?v_28 (op e4 e4)) (?v_29 (op e4 e5)) (?v_30 (op e5 e0)) (?v_31 (op e5 e1)) (?v_32 (op e5 e2)) (?v_33 (op e5 e3)) (?v_34 (op e5 e4)) (?v_35 (op e5 e5))) (and (and (and (and (and (and (and (and (and (and (or (or (or (or (or (= ?v_0 e0) (= ?v_0 e1)) (= ?v_0 e2)) (= ?v_0 e3)) (= ?v_0 e4)) (= ?v_0 e5)) (or (or (or (or (or (= ?v_1 e0) (= ?v_1 e1)) (= ?v_1 e2)) (= ?v_1 e3)) (= ?v_1 e4)) (= ?v_1 e5))) (or (or (or (or (or (= ?v_2 e0) (= ?v_2 e1)) (= ?v_2 e2)) (= ?v_2 e3)) (= ?v_2 e4)) (= ?v_2 e5))) (or (or (or (or (or (= ?v_3 e0) (= ?v_3 e1)) (= ?v_3 e2)) (= ?v_3 e3)) (= ?v_3 e4)) (= ?v_3 e5))) (or (or (or (or (or (= ?v_4 e0) (= ?v_4 e1)) (= ?v_4 e2)) (= ?v_4 e3)) (= ?v_4 e4)) (= ?v_4 e5))) (or (or (or (or (or (= ?v_5 e0) (= ?v_5 e1)) (= ?v_5 e2)) (= ?v_5 e3)) (= ?v_5 e4)) (= ?v_5 e5))) (and (and (and (and (and (or (or (or (or (or (= ?v_6 e0) (= ?v_6 e1)) (= ?v_6 e2)) (= ?v_6 e3)) (= ?v_6 e4)) (= ?v_6 e5)) (or (or (or (or (or (= ?v_7 e0) (= ?v_7 e1)) (= ?v_7 e2)) (= ?v_7 e3)) (= ?v_7 e4)) (= ?v_7 e5))) (or (or (or (or (or (= ?v_8 e0) (= ?v_8 e1)) (= ?v_8 e2)) (= ?v_8 e3)) (= ?v_8 e4)) (= ?v_8 e5))) (or (or (or (or (or (= ?v_9 e0) (= ?v_9 e1)) (= ?v_9 e2)) (= ?v_9 e3)) (= ?v_9 e4)) (= ?v_9 e5))) (or (or (or (or (or (= ?v_10 e0) (= ?v_10 e1)) (= ?v_10 e2)) (= ?v_10 e3)) (= ?v_10 e4)) (= ?v_10 e5))) (or (or (or (or (or (= ?v_11 e0) (= ?v_11 e1)) (= ?v_11 e2)) (= ?v_11 e3)) (= ?v_11 e4)) (= ?v_11 e5)))) (and (and (and (and (and (or (or (or (or (or (= ?v_12 e0) (= ?v_12 e1)) (= ?v_12 e2)) (= ?v_12 e3)) (= ?v_12 e4)) (= ?v_12 e5)) (or (or (or (or (or (= ?v_13 e0) (= ?v_13 e1)) (= ?v_13 e2)) (= ?v_13 e3)) (= ?v_13 e4)) (= ?v_13 e5))) (or (or (or (or (or (= ?v_14 e0) (= ?v_14 e1)) (= ?v_14 e2)) (= ?v_14 e3)) (= ?v_14 e4)) (= ?v_14 e5))) (or (or (or (or (or (= ?v_15 e0) (= ?v_15 e1)) (= ?v_15 e2)) (= ?v_15 e3)) (= ?v_15 e4)) (= ?v_15 e5))) (or (or (or (or (or (= ?v_16 e0) (= ?v_16 e1)) (= ?v_16 e2)) (= ?v_16 e3)) (= ?v_16 e4)) (= ?v_16 e5))) (or (or (or (or (or (= ?v_17 e0) (= ?v_17 e1)) (= ?v_17 e2)) (= ?v_17 e3)) (= ?v_17 e4)) (= ?v_17 e5)))) (and (and (and (and (and (or (or (or (or (or (= ?v_18 e0) (= ?v_18 e1)) (= ?v_18 e2)) (= ?v_18 e3)) (= ?v_18 e4)) (= ?v_18 e5)) (or (or (or (or (or (= ?v_19 e0) (= ?v_19 e1)) (= ?v_19 e2)) (= ?v_19 e3)) (= ?v_19 e4)) (= ?v_19 e5))) (or (or (or (or (or (= ?v_20 e0) (= ?v_20 e1)) (= ?v_20 e2)) (= ?v_20 e3)) (= ?v_20 e4)) (= ?v_20 e5))) (or (or (or (or (or (= ?v_21 e0) (= ?v_21 e1)) (= ?v_21 e2)) (= ?v_21 e3)) (= ?v_21 e4)) (= ?v_21 e5))) (or (or (or (or (or (= ?v_22 e0) (= ?v_22 e1)) (= ?v_22 e2)) (= ?v_22 e3)) (= ?v_22 e4)) (= ?v_22 e5))) (or (or (or (or (or (= ?v_23 e0) (= ?v_23 e1)) (= ?v_23 e2)) (= ?v_23 e3)) (= ?v_23 e4)) (= ?v_23 e5)))) (and (and (and (and (and (or (or (or (or (or (= ?v_24 e0) (= ?v_24 e1)) (= ?v_24 e2)) (= ?v_24 e3)) (= ?v_24 e4)) (= ?v_24 e5)) (or (or (or (or (or (= ?v_25 e0) (= ?v_25 e1)) (= ?v_25 e2)) (= ?v_25 e3)) (= ?v_25 e4)) (= ?v_25 e5))) (or (or (or (or (or (= ?v_26 e0) (= ?v_26 e1)) (= ?v_26 e2)) (= ?v_26 e3)) (= ?v_26 e4)) (= ?v_26 e5))) (or (or (or (or (or (= ?v_27 e0) (= ?v_27 e1)) (= ?v_27 e2)) (= ?v_27 e3)) (= ?v_27 e4)) (= ?v_27 e5))) (or (or (or (or (or (= ?v_28 e0) (= ?v_28 e1)) (= ?v_28 e2)) (= ?v_28 e3)) (= ?v_28 e4)) (= ?v_28 e5))) (or (or (or (or (or (= ?v_29 e0) (= ?v_29 e1)) (= ?v_29 e2)) (= ?v_29 e3)) (= ?v_29 e4)) (= ?v_29 e5)))) (and (and (and (and (and (or (or (or (or (or (= ?v_30 e0) (= ?v_30 e1)) (= ?v_30 e2)) (= ?v_30 e3)) (= ?v_30 e4)) (= ?v_30 e5)) (or (or (or (or (or (= ?v_31 e0) (= ?v_31 e1)) (= ?v_31 e2)) (= ?v_31 e3)) (= ?v_31 e4)) (= ?v_31 e5))) (or (or (or (or (or (= ?v_32 e0) (= ?v_32 e1)) (= ?v_32 e2)) (= ?v_32 e3)) (= ?v_32 e4)) (= ?v_32 e5))) (or (or (or (or (or (= ?v_33 e0) (= ?v_33 e1)) (= ?v_33 e2)) (= ?v_33 e3)) (= ?v_33 e4)) (= ?v_33 e5))) (or (or (or (or (or (= ?v_34 e0) (= ?v_34 e1)) (= ?v_34 e2)) (= ?v_34 e3)) (= ?v_34 e4)) (= ?v_34 e5))) (or (or (or (or (or (= ?v_35 e0) (= ?v_35 e1)) (= ?v_35 e2)) (= ?v_35 e3)) (= ?v_35 e4)) (= ?v_35 e5)))))) +(assert (let ((?v_1 (op e0 e0)) (?v_2 (op e0 e1)) (?v_3 (op e0 e2)) (?v_4 (op e0 e3)) (?v_5 (op e0 e4)) (?v_6 (op e0 e5)) (?v_8 (op e1 e0)) (?v_21 (op e1 e1)) (?v_22 (op e1 e2)) (?v_23 (op e1 e3)) (?v_24 (op e1 e4)) (?v_25 (op e1 e5)) (?v_9 (op e2 e0)) (?v_28 (op e2 e1)) (?v_51 (op e2 e2)) (?v_52 (op e2 e3)) (?v_53 (op e2 e4)) (?v_54 (op e2 e5)) (?v_10 (op e3 e0)) (?v_29 (op e3 e1)) (?v_58 (op e3 e2)) (?v_91 (op e3 e3)) (?v_92 (op e3 e4)) (?v_93 (op e3 e5)) (?v_11 (op e4 e0)) (?v_30 (op e4 e1)) (?v_59 (op e4 e2)) (?v_98 (op e4 e3)) (?v_141 (op e4 e4)) (?v_142 (op e4 e5)) (?v_12 (op e5 e0)) (?v_31 (op e5 e1)) (?v_60 (op e5 e2)) (?v_99 (op e5 e3)) (?v_148 (op e5 e4)) (?v_201 (op e5 e5))) (let ((?v_0 (= ?v_1 e0)) (?v_7 (= ?v_1 e1)) (?v_13 (= ?v_1 e2)) (?v_14 (= ?v_1 e3)) (?v_15 (= ?v_1 e4)) (?v_16 (= ?v_1 e5)) (?v_18 (= ?v_2 e0)) (?v_26 (= ?v_2 e1)) (?v_33 (= ?v_2 e2)) (?v_36 (= ?v_2 e3)) (?v_39 (= ?v_2 e4)) (?v_42 (= ?v_2 e5)) (?v_46 (= ?v_3 e0)) (?v_55 (= ?v_3 e1)) (?v_63 (= ?v_3 e2)) (?v_68 (= ?v_3 e3)) (?v_73 (= ?v_3 e4)) (?v_78 (= ?v_3 e5)) (?v_84 (= ?v_4 e0)) (?v_94 (= ?v_4 e1)) (?v_103 (= ?v_4 e2)) (?v_110 (= ?v_4 e3)) (?v_117 (= ?v_4 e4)) (?v_124 (= ?v_4 e5)) (?v_132 (= ?v_5 e0)) (?v_143 (= ?v_5 e1)) (?v_153 (= ?v_5 e2)) (?v_162 (= ?v_5 e3)) (?v_171 (= ?v_5 e4)) (?v_180 (= ?v_5 e5)) (?v_190 (= ?v_6 e0)) (?v_202 (= ?v_6 e1)) (?v_213 (= ?v_6 e2)) (?v_224 (= ?v_6 e3)) (?v_235 (= ?v_6 e4)) (?v_246 (= ?v_6 e5)) (?v_17 (= ?v_8 e0)) (?v_20 (= ?v_8 e1)) (?v_32 (= ?v_8 e2)) (?v_35 (= ?v_8 e3)) (?v_38 (= ?v_8 e4)) (?v_41 (= ?v_8 e5)) (?v_19 (= ?v_21 e0)) (?v_27 (= ?v_21 e1)) (?v_34 (= ?v_21 e2)) (?v_37 (= ?v_21 e3)) (?v_40 (= ?v_21 e4)) (?v_43 (= ?v_21 e5)) (?v_47 (= ?v_22 e0)) (?v_56 (= ?v_22 e1)) (?v_64 (= ?v_22 e2)) (?v_69 (= ?v_22 e3)) (?v_74 (= ?v_22 e4)) (?v_79 (= ?v_22 e5)) (?v_85 (= ?v_23 e0)) (?v_95 (= ?v_23 e1)) (?v_104 (= ?v_23 e2)) (?v_111 (= ?v_23 e3)) (?v_118 (= ?v_23 e4)) (?v_125 (= ?v_23 e5)) (?v_133 (= ?v_24 e0)) (?v_144 (= ?v_24 e1)) (?v_154 (= ?v_24 e2)) (?v_163 (= ?v_24 e3)) (?v_172 (= ?v_24 e4)) (?v_181 (= ?v_24 e5)) (?v_191 (= ?v_25 e0)) (?v_203 (= ?v_25 e1)) (?v_214 (= ?v_25 e2)) (?v_225 (= ?v_25 e3)) (?v_236 (= ?v_25 e4)) (?v_247 (= ?v_25 e5)) (?v_44 (= ?v_9 e0)) (?v_49 (= ?v_9 e1)) (?v_61 (= ?v_9 e2)) (?v_66 (= ?v_9 e3)) (?v_71 (= ?v_9 e4)) (?v_76 (= ?v_9 e5)) (?v_45 (= ?v_28 e0)) (?v_50 (= ?v_28 e1)) (?v_62 (= ?v_28 e2)) (?v_67 (= ?v_28 e3)) (?v_72 (= ?v_28 e4)) (?v_77 (= ?v_28 e5)) (?v_48 (= ?v_51 e0)) (?v_57 (= ?v_51 e1)) (?v_65 (= ?v_51 e2)) (?v_70 (= ?v_51 e3)) (?v_75 (= ?v_51 e4)) (?v_80 (= ?v_51 e5)) (?v_86 (= ?v_52 e0)) (?v_96 (= ?v_52 e1)) (?v_105 (= ?v_52 e2)) (?v_112 (= ?v_52 e3)) (?v_119 (= ?v_52 e4)) (?v_126 (= ?v_52 e5)) (?v_134 (= ?v_53 e0)) (?v_145 (= ?v_53 e1)) (?v_155 (= ?v_53 e2)) (?v_164 (= ?v_53 e3)) (?v_173 (= ?v_53 e4)) (?v_182 (= ?v_53 e5)) (?v_192 (= ?v_54 e0)) (?v_204 (= ?v_54 e1)) (?v_215 (= ?v_54 e2)) (?v_226 (= ?v_54 e3)) (?v_237 (= ?v_54 e4)) (?v_248 (= ?v_54 e5)) (?v_81 (= ?v_10 e0)) (?v_88 (= ?v_10 e1)) (?v_100 (= ?v_10 e2)) (?v_107 (= ?v_10 e3)) (?v_114 (= ?v_10 e4)) (?v_121 (= ?v_10 e5)) (?v_82 (= ?v_29 e0)) (?v_89 (= ?v_29 e1)) (?v_101 (= ?v_29 e2)) (?v_108 (= ?v_29 e3)) (?v_115 (= ?v_29 e4)) (?v_122 (= ?v_29 e5)) (?v_83 (= ?v_58 e0)) (?v_90 (= ?v_58 e1)) (?v_102 (= ?v_58 e2)) (?v_109 (= ?v_58 e3)) (?v_116 (= ?v_58 e4)) (?v_123 (= ?v_58 e5)) (?v_87 (= ?v_91 e0)) (?v_97 (= ?v_91 e1)) (?v_106 (= ?v_91 e2)) (?v_113 (= ?v_91 e3)) (?v_120 (= ?v_91 e4)) (?v_127 (= ?v_91 e5)) (?v_135 (= ?v_92 e0)) (?v_146 (= ?v_92 e1)) (?v_156 (= ?v_92 e2)) (?v_165 (= ?v_92 e3)) (?v_174 (= ?v_92 e4)) (?v_183 (= ?v_92 e5)) (?v_193 (= ?v_93 e0)) (?v_205 (= ?v_93 e1)) (?v_216 (= ?v_93 e2)) (?v_227 (= ?v_93 e3)) (?v_238 (= ?v_93 e4)) (?v_249 (= ?v_93 e5)) (?v_128 (= ?v_11 e0)) (?v_137 (= ?v_11 e1)) (?v_149 (= ?v_11 e2)) (?v_158 (= ?v_11 e3)) (?v_167 (= ?v_11 e4)) (?v_176 (= ?v_11 e5)) (?v_129 (= ?v_30 e0)) (?v_138 (= ?v_30 e1)) (?v_150 (= ?v_30 e2)) (?v_159 (= ?v_30 e3)) (?v_168 (= ?v_30 e4)) (?v_177 (= ?v_30 e5)) (?v_130 (= ?v_59 e0)) (?v_139 (= ?v_59 e1)) (?v_151 (= ?v_59 e2)) (?v_160 (= ?v_59 e3)) (?v_169 (= ?v_59 e4)) (?v_178 (= ?v_59 e5)) (?v_131 (= ?v_98 e0)) (?v_140 (= ?v_98 e1)) (?v_152 (= ?v_98 e2)) (?v_161 (= ?v_98 e3)) (?v_170 (= ?v_98 e4)) (?v_179 (= ?v_98 e5)) (?v_136 (= ?v_141 e0)) (?v_147 (= ?v_141 e1)) (?v_157 (= ?v_141 e2)) (?v_166 (= ?v_141 e3)) (?v_175 (= ?v_141 e4)) (?v_184 (= ?v_141 e5)) (?v_194 (= ?v_142 e0)) (?v_206 (= ?v_142 e1)) (?v_217 (= ?v_142 e2)) (?v_228 (= ?v_142 e3)) (?v_239 (= ?v_142 e4)) (?v_250 (= ?v_142 e5)) (?v_185 (= ?v_12 e0)) (?v_196 (= ?v_12 e1)) (?v_208 (= ?v_12 e2)) (?v_219 (= ?v_12 e3)) (?v_230 (= ?v_12 e4)) (?v_241 (= ?v_12 e5)) (?v_186 (= ?v_31 e0)) (?v_197 (= ?v_31 e1)) (?v_209 (= ?v_31 e2)) (?v_220 (= ?v_31 e3)) (?v_231 (= ?v_31 e4)) (?v_242 (= ?v_31 e5)) (?v_187 (= ?v_60 e0)) (?v_198 (= ?v_60 e1)) (?v_210 (= ?v_60 e2)) (?v_221 (= ?v_60 e3)) (?v_232 (= ?v_60 e4)) (?v_243 (= ?v_60 e5)) (?v_188 (= ?v_99 e0)) (?v_199 (= ?v_99 e1)) (?v_211 (= ?v_99 e2)) (?v_222 (= ?v_99 e3)) (?v_233 (= ?v_99 e4)) (?v_244 (= ?v_99 e5)) (?v_189 (= ?v_148 e0)) (?v_200 (= ?v_148 e1)) (?v_212 (= ?v_148 e2)) (?v_223 (= ?v_148 e3)) (?v_234 (= ?v_148 e4)) (?v_245 (= ?v_148 e5)) (?v_195 (= ?v_201 e0)) (?v_207 (= ?v_201 e1)) (?v_218 (= ?v_201 e2)) (?v_229 (= ?v_201 e3)) (?v_240 (= ?v_201 e4)) (?v_251 (= ?v_201 e5))) (and (and (and (and (and (and (and (and (and (and (and (or (or (or (or (or ?v_0 ?v_18) ?v_46) ?v_84) ?v_132) ?v_190) (or (or (or (or (or ?v_0 ?v_17) ?v_44) ?v_81) ?v_128) ?v_185)) (and (or (or (or (or (or ?v_7 ?v_26) ?v_55) ?v_94) ?v_143) ?v_202) (or (or (or (or (or ?v_7 ?v_20) ?v_49) ?v_88) ?v_137) ?v_196))) (and (or (or (or (or (or ?v_13 ?v_33) ?v_63) ?v_103) ?v_153) ?v_213) (or (or (or (or (or ?v_13 ?v_32) ?v_61) ?v_100) ?v_149) ?v_208))) (and (or (or (or (or (or ?v_14 ?v_36) ?v_68) ?v_110) ?v_162) ?v_224) (or (or (or (or (or ?v_14 ?v_35) ?v_66) ?v_107) ?v_158) ?v_219))) (and (or (or (or (or (or ?v_15 ?v_39) ?v_73) ?v_117) ?v_171) ?v_235) (or (or (or (or (or ?v_15 ?v_38) ?v_71) ?v_114) ?v_167) ?v_230))) (and (or (or (or (or (or ?v_16 ?v_42) ?v_78) ?v_124) ?v_180) ?v_246) (or (or (or (or (or ?v_16 ?v_41) ?v_76) ?v_121) ?v_176) ?v_241))) (and (and (and (and (and (and (or (or (or (or (or ?v_17 ?v_19) ?v_47) ?v_85) ?v_133) ?v_191) (or (or (or (or (or ?v_18 ?v_19) ?v_45) ?v_82) ?v_129) ?v_186)) (and (or (or (or (or (or ?v_20 ?v_27) ?v_56) ?v_95) ?v_144) ?v_203) (or (or (or (or (or ?v_26 ?v_27) ?v_50) ?v_89) ?v_138) ?v_197))) (and (or (or (or (or (or ?v_32 ?v_34) ?v_64) ?v_104) ?v_154) ?v_214) (or (or (or (or (or ?v_33 ?v_34) ?v_62) ?v_101) ?v_150) ?v_209))) (and (or (or (or (or (or ?v_35 ?v_37) ?v_69) ?v_111) ?v_163) ?v_225) (or (or (or (or (or ?v_36 ?v_37) ?v_67) ?v_108) ?v_159) ?v_220))) (and (or (or (or (or (or ?v_38 ?v_40) ?v_74) ?v_118) ?v_172) ?v_236) (or (or (or (or (or ?v_39 ?v_40) ?v_72) ?v_115) ?v_168) ?v_231))) (and (or (or (or (or (or ?v_41 ?v_43) ?v_79) ?v_125) ?v_181) ?v_247) (or (or (or (or (or ?v_42 ?v_43) ?v_77) ?v_122) ?v_177) ?v_242)))) (and (and (and (and (and (and (or (or (or (or (or ?v_44 ?v_45) ?v_48) ?v_86) ?v_134) ?v_192) (or (or (or (or (or ?v_46 ?v_47) ?v_48) ?v_83) ?v_130) ?v_187)) (and (or (or (or (or (or ?v_49 ?v_50) ?v_57) ?v_96) ?v_145) ?v_204) (or (or (or (or (or ?v_55 ?v_56) ?v_57) ?v_90) ?v_139) ?v_198))) (and (or (or (or (or (or ?v_61 ?v_62) ?v_65) ?v_105) ?v_155) ?v_215) (or (or (or (or (or ?v_63 ?v_64) ?v_65) ?v_102) ?v_151) ?v_210))) (and (or (or (or (or (or ?v_66 ?v_67) ?v_70) ?v_112) ?v_164) ?v_226) (or (or (or (or (or ?v_68 ?v_69) ?v_70) ?v_109) ?v_160) ?v_221))) (and (or (or (or (or (or ?v_71 ?v_72) ?v_75) ?v_119) ?v_173) ?v_237) (or (or (or (or (or ?v_73 ?v_74) ?v_75) ?v_116) ?v_169) ?v_232))) (and (or (or (or (or (or ?v_76 ?v_77) ?v_80) ?v_126) ?v_182) ?v_248) (or (or (or (or (or ?v_78 ?v_79) ?v_80) ?v_123) ?v_178) ?v_243)))) (and (and (and (and (and (and (or (or (or (or (or ?v_81 ?v_82) ?v_83) ?v_87) ?v_135) ?v_193) (or (or (or (or (or ?v_84 ?v_85) ?v_86) ?v_87) ?v_131) ?v_188)) (and (or (or (or (or (or ?v_88 ?v_89) ?v_90) ?v_97) ?v_146) ?v_205) (or (or (or (or (or ?v_94 ?v_95) ?v_96) ?v_97) ?v_140) ?v_199))) (and (or (or (or (or (or ?v_100 ?v_101) ?v_102) ?v_106) ?v_156) ?v_216) (or (or (or (or (or ?v_103 ?v_104) ?v_105) ?v_106) ?v_152) ?v_211))) (and (or (or (or (or (or ?v_107 ?v_108) ?v_109) ?v_113) ?v_165) ?v_227) (or (or (or (or (or ?v_110 ?v_111) ?v_112) ?v_113) ?v_161) ?v_222))) (and (or (or (or (or (or ?v_114 ?v_115) ?v_116) ?v_120) ?v_174) ?v_238) (or (or (or (or (or ?v_117 ?v_118) ?v_119) ?v_120) ?v_170) ?v_233))) (and (or (or (or (or (or ?v_121 ?v_122) ?v_123) ?v_127) ?v_183) ?v_249) (or (or (or (or (or ?v_124 ?v_125) ?v_126) ?v_127) ?v_179) ?v_244)))) (and (and (and (and (and (and (or (or (or (or (or ?v_128 ?v_129) ?v_130) ?v_131) ?v_136) ?v_194) (or (or (or (or (or ?v_132 ?v_133) ?v_134) ?v_135) ?v_136) ?v_189)) (and (or (or (or (or (or ?v_137 ?v_138) ?v_139) ?v_140) ?v_147) ?v_206) (or (or (or (or (or ?v_143 ?v_144) ?v_145) ?v_146) ?v_147) ?v_200))) (and (or (or (or (or (or ?v_149 ?v_150) ?v_151) ?v_152) ?v_157) ?v_217) (or (or (or (or (or ?v_153 ?v_154) ?v_155) ?v_156) ?v_157) ?v_212))) (and (or (or (or (or (or ?v_158 ?v_159) ?v_160) ?v_161) ?v_166) ?v_228) (or (or (or (or (or ?v_162 ?v_163) ?v_164) ?v_165) ?v_166) ?v_223))) (and (or (or (or (or (or ?v_167 ?v_168) ?v_169) ?v_170) ?v_175) ?v_239) (or (or (or (or (or ?v_171 ?v_172) ?v_173) ?v_174) ?v_175) ?v_234))) (and (or (or (or (or (or ?v_176 ?v_177) ?v_178) ?v_179) ?v_184) ?v_250) (or (or (or (or (or ?v_180 ?v_181) ?v_182) ?v_183) ?v_184) ?v_245)))) (and (and (and (and (and (and (or (or (or (or (or ?v_185 ?v_186) ?v_187) ?v_188) ?v_189) ?v_195) (or (or (or (or (or ?v_190 ?v_191) ?v_192) ?v_193) ?v_194) ?v_195)) (and (or (or (or (or (or ?v_196 ?v_197) ?v_198) ?v_199) ?v_200) ?v_207) (or (or (or (or (or ?v_202 ?v_203) ?v_204) ?v_205) ?v_206) ?v_207))) (and (or (or (or (or (or ?v_208 ?v_209) ?v_210) ?v_211) ?v_212) ?v_218) (or (or (or (or (or ?v_213 ?v_214) ?v_215) ?v_216) ?v_217) ?v_218))) (and (or (or (or (or (or ?v_219 ?v_220) ?v_221) ?v_222) ?v_223) ?v_229) (or (or (or (or (or ?v_224 ?v_225) ?v_226) ?v_227) ?v_228) ?v_229))) (and (or (or (or (or (or ?v_230 ?v_231) ?v_232) ?v_233) ?v_234) ?v_240) (or (or (or (or (or ?v_235 ?v_236) ?v_237) ?v_238) ?v_239) ?v_240))) (and (or (or (or (or (or ?v_241 ?v_242) ?v_243) ?v_244) ?v_245) ?v_251) (or (or (or (or (or ?v_246 ?v_247) ?v_248) ?v_249) ?v_250) ?v_251))))))) +(assert (and (and (and (and (and (and (and (= (op unit e0) e0) (= (op e0 unit) e0)) (and (= (op unit e1) e1) (= (op e1 unit) e1))) (and (= (op unit e2) e2) (= (op e2 unit) e2))) (and (= (op unit e3) e3) (= (op e3 unit) e3))) (and (= (op unit e4) e4) (= (op e4 unit) e4))) (and (= (op unit e5) e5) (= (op e5 unit) e5))) (or (or (or (or (or (= unit e0) (= unit e1)) (= unit e2)) (= unit e3)) (= unit e4)) (= unit e5)))) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e0 e1)) (?v_4 (op e0 e2)) (?v_9 (op e0 e3)) (?v_16 (op e0 e4)) (?v_25 (op e0 e5)) (?v_2 (op e1 e0)) (?v_3 (op e1 e1)) (?v_6 (op e1 e2)) (?v_11 (op e1 e3)) (?v_18 (op e1 e4)) (?v_27 (op e1 e5)) (?v_5 (op e2 e0)) (?v_7 (op e2 e1)) (?v_8 (op e2 e2)) (?v_13 (op e2 e3)) (?v_20 (op e2 e4)) (?v_29 (op e2 e5)) (?v_10 (op e3 e0)) (?v_12 (op e3 e1)) (?v_14 (op e3 e2)) (?v_15 (op e3 e3)) (?v_22 (op e3 e4)) (?v_31 (op e3 e5)) (?v_17 (op e4 e0)) (?v_19 (op e4 e1)) (?v_21 (op e4 e2)) (?v_23 (op e4 e3)) (?v_24 (op e4 e4)) (?v_33 (op e4 e5)) (?v_26 (op e5 e0)) (?v_28 (op e5 e1)) (?v_30 (op e5 e2)) (?v_32 (op e5 e3)) (?v_34 (op e5 e4)) (?v_35 (op e5 e5))) (or (or (or (or (or (or (or (or (or (or (not (= ?v_0 ?v_0)) (not (= ?v_2 ?v_1))) (not (= ?v_5 ?v_4))) (not (= ?v_10 ?v_9))) (not (= ?v_17 ?v_16))) (not (= ?v_26 ?v_25))) (or (or (or (or (or (not (= ?v_1 ?v_2)) (not (= ?v_3 ?v_3))) (not (= ?v_7 ?v_6))) (not (= ?v_12 ?v_11))) (not (= ?v_19 ?v_18))) (not (= ?v_28 ?v_27)))) (or (or (or (or (or (not (= ?v_4 ?v_5)) (not (= ?v_6 ?v_7))) (not (= ?v_8 ?v_8))) (not (= ?v_14 ?v_13))) (not (= ?v_21 ?v_20))) (not (= ?v_30 ?v_29)))) (or (or (or (or (or (not (= ?v_9 ?v_10)) (not (= ?v_11 ?v_12))) (not (= ?v_13 ?v_14))) (not (= ?v_15 ?v_15))) (not (= ?v_23 ?v_22))) (not (= ?v_32 ?v_31)))) (or (or (or (or (or (not (= ?v_16 ?v_17)) (not (= ?v_18 ?v_19))) (not (= ?v_20 ?v_21))) (not (= ?v_22 ?v_23))) (not (= ?v_24 ?v_24))) (not (= ?v_34 ?v_33)))) (or (or (or (or (or (not (= ?v_25 ?v_26)) (not (= ?v_27 ?v_28))) (not (= ?v_29 ?v_30))) (not (= ?v_31 ?v_32))) (not (= ?v_33 ?v_34))) (not (= ?v_35 ?v_35)))))) +(assert (or (or (or (or (or (and (and (and (and (and (not (= (op (op e0 e0) e0) e0)) (not (= (op (op e0 e1) e0) e1))) (not (= (op (op e0 e2) e0) e2))) (not (= (op (op e0 e3) e0) e3))) (not (= (op (op e0 e4) e0) e4))) (not (= (op (op e0 e5) e0) e5))) (and (and (and (and (and (not (= (op (op e1 e0) e1) e0)) (not (= (op (op e1 e1) e1) e1))) (not (= (op (op e1 e2) e1) e2))) (not (= (op (op e1 e3) e1) e3))) (not (= (op (op e1 e4) e1) e4))) (not (= (op (op e1 e5) e1) e5)))) (and (and (and (and (and (not (= (op (op e2 e0) e2) e0)) (not (= (op (op e2 e1) e2) e1))) (not (= (op (op e2 e2) e2) e2))) (not (= (op (op e2 e3) e2) e3))) (not (= (op (op e2 e4) e2) e4))) (not (= (op (op e2 e5) e2) e5)))) (and (and (and (and (and (not (= (op (op e3 e0) e3) e0)) (not (= (op (op e3 e1) e3) e1))) (not (= (op (op e3 e2) e3) e2))) (not (= (op (op e3 e3) e3) e3))) (not (= (op (op e3 e4) e3) e4))) (not (= (op (op e3 e5) e3) e5)))) (and (and (and (and (and (not (= (op (op e4 e0) e4) e0)) (not (= (op (op e4 e1) e4) e1))) (not (= (op (op e4 e2) e4) e2))) (not (= (op (op e4 e3) e4) e3))) (not (= (op (op e4 e4) e4) e4))) (not (= (op (op e4 e5) e4) e5)))) (and (and (and (and (and (not (= (op (op e5 e0) e5) e0)) (not (= (op (op e5 e1) e5) e1))) (not (= (op (op e5 e2) e5) e2))) (not (= (op (op e5 e3) e5) e3))) (not (= (op (op e5 e4) e5) e4))) (not (= (op (op e5 e5) e5) e5))))) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e0 e1)) (?v_2 (op e0 e2)) (?v_3 (op e0 e3)) (?v_4 (op e0 e4)) (?v_5 (op e0 e5)) (?v_6 (op e1 e0)) (?v_7 (op e1 e1)) (?v_8 (op e1 e2)) (?v_9 (op e1 e3)) (?v_10 (op e1 e4)) (?v_11 (op e1 e5)) (?v_12 (op e2 e0)) (?v_13 (op e2 e1)) (?v_14 (op e2 e2)) (?v_15 (op e2 e3)) (?v_16 (op e2 e4)) (?v_17 (op e2 e5)) (?v_18 (op e3 e0)) (?v_19 (op e3 e1)) (?v_20 (op e3 e2)) (?v_21 (op e3 e3)) (?v_22 (op e3 e4)) (?v_23 (op e3 e5)) (?v_24 (op e4 e0)) (?v_25 (op e4 e1)) (?v_26 (op e4 e2)) (?v_27 (op e4 e3)) (?v_28 (op e4 e4)) (?v_29 (op e4 e5)) (?v_30 (op e5 e0)) (?v_31 (op e5 e1)) (?v_32 (op e5 e2)) (?v_33 (op e5 e3)) (?v_34 (op e5 e4)) (?v_35 (op e5 e5))) (or (or (or (or (or (and (and (and (and (and (not (= (op ?v_0 ?v_0) e0)) (not (= (op ?v_1 ?v_1) e1))) (not (= (op ?v_2 ?v_2) e2))) (not (= (op ?v_3 ?v_3) e3))) (not (= (op ?v_4 ?v_4) e4))) (not (= (op ?v_5 ?v_5) e5))) (and (and (and (and (and (not (= (op ?v_6 ?v_6) e0)) (not (= (op ?v_7 ?v_7) e1))) (not (= (op ?v_8 ?v_8) e2))) (not (= (op ?v_9 ?v_9) e3))) (not (= (op ?v_10 ?v_10) e4))) (not (= (op ?v_11 ?v_11) e5)))) (and (and (and (and (and (not (= (op ?v_12 ?v_12) e0)) (not (= (op ?v_13 ?v_13) e1))) (not (= (op ?v_14 ?v_14) e2))) (not (= (op ?v_15 ?v_15) e3))) (not (= (op ?v_16 ?v_16) e4))) (not (= (op ?v_17 ?v_17) e5)))) (and (and (and (and (and (not (= (op ?v_18 ?v_18) e0)) (not (= (op ?v_19 ?v_19) e1))) (not (= (op ?v_20 ?v_20) e2))) (not (= (op ?v_21 ?v_21) e3))) (not (= (op ?v_22 ?v_22) e4))) (not (= (op ?v_23 ?v_23) e5)))) (and (and (and (and (and (not (= (op ?v_24 ?v_24) e0)) (not (= (op ?v_25 ?v_25) e1))) (not (= (op ?v_26 ?v_26) e2))) (not (= (op ?v_27 ?v_27) e3))) (not (= (op ?v_28 ?v_28) e4))) (not (= (op ?v_29 ?v_29) e5)))) (and (and (and (and (and (not (= (op ?v_30 ?v_30) e0)) (not (= (op ?v_31 ?v_31) e1))) (not (= (op ?v_32 ?v_32) e2))) (not (= (op ?v_33 ?v_33) e3))) (not (= (op ?v_34 ?v_34) e4))) (not (= (op ?v_35 ?v_35) e5)))))) +(assert (let ((?v_36 (op e0 e0)) (?v_38 (op e0 e1)) (?v_40 (op e0 e2)) (?v_42 (op e0 e3)) (?v_44 (op e0 e4)) (?v_46 (op e0 e5)) (?v_39 (op e1 e0)) (?v_50 (op e1 e1)) (?v_52 (op e1 e2)) (?v_54 (op e1 e3)) (?v_56 (op e1 e4)) (?v_58 (op e1 e5)) (?v_41 (op e2 e0)) (?v_53 (op e2 e1)) (?v_64 (op e2 e2)) (?v_66 (op e2 e3)) (?v_68 (op e2 e4)) (?v_70 (op e2 e5)) (?v_43 (op e3 e0)) (?v_55 (op e3 e1)) (?v_67 (op e3 e2)) (?v_78 (op e3 e3)) (?v_80 (op e3 e4)) (?v_82 (op e3 e5)) (?v_45 (op e4 e0)) (?v_57 (op e4 e1)) (?v_69 (op e4 e2)) (?v_81 (op e4 e3)) (?v_92 (op e4 e4)) (?v_94 (op e4 e5)) (?v_47 (op e5 e0)) (?v_59 (op e5 e1)) (?v_71 (op e5 e2)) (?v_83 (op e5 e3)) (?v_95 (op e5 e4)) (?v_106 (op e5 e5))) (let ((?v_0 (= ?v_36 e0)) (?v_37 (= ?v_36 e1)) (?v_108 (= ?v_36 e2)) (?v_144 (= ?v_36 e3)) (?v_180 (= ?v_36 e4)) (?v_216 (= ?v_36 e5)) (?v_2 (= ?v_38 e0)) (?v_49 (= ?v_38 e1)) (?v_110 (= ?v_38 e2)) (?v_146 (= ?v_38 e3)) (?v_182 (= ?v_38 e4)) (?v_218 (= ?v_38 e5)) (?v_5 (= ?v_40 e0)) (?v_61 (= ?v_40 e1)) (?v_113 (= ?v_40 e2)) (?v_149 (= ?v_40 e3)) (?v_185 (= ?v_40 e4)) (?v_221 (= ?v_40 e5)) (?v_10 (= ?v_42 e0)) (?v_73 (= ?v_42 e1)) (?v_118 (= ?v_42 e2)) (?v_154 (= ?v_42 e3)) (?v_190 (= ?v_42 e4)) (?v_226 (= ?v_42 e5)) (?v_17 (= ?v_44 e0)) (?v_85 (= ?v_44 e1)) (?v_125 (= ?v_44 e2)) (?v_161 (= ?v_44 e3)) (?v_197 (= ?v_44 e4)) (?v_233 (= ?v_44 e5)) (?v_26 (= ?v_46 e0)) (?v_97 (= ?v_46 e1)) (?v_134 (= ?v_46 e2)) (?v_170 (= ?v_46 e3)) (?v_206 (= ?v_46 e4)) (?v_242 (= ?v_46 e5)) (?v_1 (= ?v_39 e0)) (?v_48 (= ?v_39 e1)) (?v_109 (= ?v_39 e2)) (?v_145 (= ?v_39 e3)) (?v_181 (= ?v_39 e4)) (?v_217 (= ?v_39 e5)) (?v_3 (= ?v_50 e0)) (?v_51 (= ?v_50 e1)) (?v_111 (= ?v_50 e2)) (?v_147 (= ?v_50 e3)) (?v_183 (= ?v_50 e4)) (?v_219 (= ?v_50 e5)) (?v_7 (= ?v_52 e0)) (?v_63 (= ?v_52 e1)) (?v_115 (= ?v_52 e2)) (?v_151 (= ?v_52 e3)) (?v_187 (= ?v_52 e4)) (?v_223 (= ?v_52 e5)) (?v_12 (= ?v_54 e0)) (?v_75 (= ?v_54 e1)) (?v_120 (= ?v_54 e2)) (?v_156 (= ?v_54 e3)) (?v_192 (= ?v_54 e4)) (?v_228 (= ?v_54 e5)) (?v_19 (= ?v_56 e0)) (?v_87 (= ?v_56 e1)) (?v_127 (= ?v_56 e2)) (?v_163 (= ?v_56 e3)) (?v_199 (= ?v_56 e4)) (?v_235 (= ?v_56 e5)) (?v_28 (= ?v_58 e0)) (?v_99 (= ?v_58 e1)) (?v_136 (= ?v_58 e2)) (?v_172 (= ?v_58 e3)) (?v_208 (= ?v_58 e4)) (?v_244 (= ?v_58 e5)) (?v_4 (= ?v_41 e0)) (?v_60 (= ?v_41 e1)) (?v_112 (= ?v_41 e2)) (?v_148 (= ?v_41 e3)) (?v_184 (= ?v_41 e4)) (?v_220 (= ?v_41 e5)) (?v_6 (= ?v_53 e0)) (?v_62 (= ?v_53 e1)) (?v_114 (= ?v_53 e2)) (?v_150 (= ?v_53 e3)) (?v_186 (= ?v_53 e4)) (?v_222 (= ?v_53 e5)) (?v_8 (= ?v_64 e0)) (?v_65 (= ?v_64 e1)) (?v_116 (= ?v_64 e2)) (?v_152 (= ?v_64 e3)) (?v_188 (= ?v_64 e4)) (?v_224 (= ?v_64 e5)) (?v_14 (= ?v_66 e0)) (?v_77 (= ?v_66 e1)) (?v_122 (= ?v_66 e2)) (?v_158 (= ?v_66 e3)) (?v_194 (= ?v_66 e4)) (?v_230 (= ?v_66 e5)) (?v_21 (= ?v_68 e0)) (?v_89 (= ?v_68 e1)) (?v_129 (= ?v_68 e2)) (?v_165 (= ?v_68 e3)) (?v_201 (= ?v_68 e4)) (?v_237 (= ?v_68 e5)) (?v_30 (= ?v_70 e0)) (?v_101 (= ?v_70 e1)) (?v_138 (= ?v_70 e2)) (?v_174 (= ?v_70 e3)) (?v_210 (= ?v_70 e4)) (?v_246 (= ?v_70 e5)) (?v_9 (= ?v_43 e0)) (?v_72 (= ?v_43 e1)) (?v_117 (= ?v_43 e2)) (?v_153 (= ?v_43 e3)) (?v_189 (= ?v_43 e4)) (?v_225 (= ?v_43 e5)) (?v_11 (= ?v_55 e0)) (?v_74 (= ?v_55 e1)) (?v_119 (= ?v_55 e2)) (?v_155 (= ?v_55 e3)) (?v_191 (= ?v_55 e4)) (?v_227 (= ?v_55 e5)) (?v_13 (= ?v_67 e0)) (?v_76 (= ?v_67 e1)) (?v_121 (= ?v_67 e2)) (?v_157 (= ?v_67 e3)) (?v_193 (= ?v_67 e4)) (?v_229 (= ?v_67 e5)) (?v_15 (= ?v_78 e0)) (?v_79 (= ?v_78 e1)) (?v_123 (= ?v_78 e2)) (?v_159 (= ?v_78 e3)) (?v_195 (= ?v_78 e4)) (?v_231 (= ?v_78 e5)) (?v_23 (= ?v_80 e0)) (?v_91 (= ?v_80 e1)) (?v_131 (= ?v_80 e2)) (?v_167 (= ?v_80 e3)) (?v_203 (= ?v_80 e4)) (?v_239 (= ?v_80 e5)) (?v_32 (= ?v_82 e0)) (?v_103 (= ?v_82 e1)) (?v_140 (= ?v_82 e2)) (?v_176 (= ?v_82 e3)) (?v_212 (= ?v_82 e4)) (?v_248 (= ?v_82 e5)) (?v_16 (= ?v_45 e0)) (?v_84 (= ?v_45 e1)) (?v_124 (= ?v_45 e2)) (?v_160 (= ?v_45 e3)) (?v_196 (= ?v_45 e4)) (?v_232 (= ?v_45 e5)) (?v_18 (= ?v_57 e0)) (?v_86 (= ?v_57 e1)) (?v_126 (= ?v_57 e2)) (?v_162 (= ?v_57 e3)) (?v_198 (= ?v_57 e4)) (?v_234 (= ?v_57 e5)) (?v_20 (= ?v_69 e0)) (?v_88 (= ?v_69 e1)) (?v_128 (= ?v_69 e2)) (?v_164 (= ?v_69 e3)) (?v_200 (= ?v_69 e4)) (?v_236 (= ?v_69 e5)) (?v_22 (= ?v_81 e0)) (?v_90 (= ?v_81 e1)) (?v_130 (= ?v_81 e2)) (?v_166 (= ?v_81 e3)) (?v_202 (= ?v_81 e4)) (?v_238 (= ?v_81 e5)) (?v_24 (= ?v_92 e0)) (?v_93 (= ?v_92 e1)) (?v_132 (= ?v_92 e2)) (?v_168 (= ?v_92 e3)) (?v_204 (= ?v_92 e4)) (?v_240 (= ?v_92 e5)) (?v_34 (= ?v_94 e0)) (?v_105 (= ?v_94 e1)) (?v_142 (= ?v_94 e2)) (?v_178 (= ?v_94 e3)) (?v_214 (= ?v_94 e4)) (?v_250 (= ?v_94 e5)) (?v_25 (= ?v_47 e0)) (?v_96 (= ?v_47 e1)) (?v_133 (= ?v_47 e2)) (?v_169 (= ?v_47 e3)) (?v_205 (= ?v_47 e4)) (?v_241 (= ?v_47 e5)) (?v_27 (= ?v_59 e0)) (?v_98 (= ?v_59 e1)) (?v_135 (= ?v_59 e2)) (?v_171 (= ?v_59 e3)) (?v_207 (= ?v_59 e4)) (?v_243 (= ?v_59 e5)) (?v_29 (= ?v_71 e0)) (?v_100 (= ?v_71 e1)) (?v_137 (= ?v_71 e2)) (?v_173 (= ?v_71 e3)) (?v_209 (= ?v_71 e4)) (?v_245 (= ?v_71 e5)) (?v_31 (= ?v_83 e0)) (?v_102 (= ?v_83 e1)) (?v_139 (= ?v_83 e2)) (?v_175 (= ?v_83 e3)) (?v_211 (= ?v_83 e4)) (?v_247 (= ?v_83 e5)) (?v_33 (= ?v_95 e0)) (?v_104 (= ?v_95 e1)) (?v_141 (= ?v_95 e2)) (?v_177 (= ?v_95 e3)) (?v_213 (= ?v_95 e4)) (?v_249 (= ?v_95 e5)) (?v_35 (= ?v_106 e0)) (?v_107 (= ?v_106 e1)) (?v_143 (= ?v_106 e2)) (?v_179 (= ?v_106 e3)) (?v_215 (= ?v_106 e4)) (?v_251 (= ?v_106 e5))) (and (and (and (and (and (or (or (or (or (or (or (or (or (or (or (and ?v_0 (not ?v_0)) (and ?v_2 (not ?v_1))) (and ?v_5 (not ?v_4))) (and ?v_10 (not ?v_9))) (and ?v_17 (not ?v_16))) (and ?v_26 (not ?v_25))) (or (or (or (or (or (and ?v_1 (not ?v_2)) (and ?v_3 (not ?v_3))) (and ?v_7 (not ?v_6))) (and ?v_12 (not ?v_11))) (and ?v_19 (not ?v_18))) (and ?v_28 (not ?v_27)))) (or (or (or (or (or (and ?v_4 (not ?v_5)) (and ?v_6 (not ?v_7))) (and ?v_8 (not ?v_8))) (and ?v_14 (not ?v_13))) (and ?v_21 (not ?v_20))) (and ?v_30 (not ?v_29)))) (or (or (or (or (or (and ?v_9 (not ?v_10)) (and ?v_11 (not ?v_12))) (and ?v_13 (not ?v_14))) (and ?v_15 (not ?v_15))) (and ?v_23 (not ?v_22))) (and ?v_32 (not ?v_31)))) (or (or (or (or (or (and ?v_16 (not ?v_17)) (and ?v_18 (not ?v_19))) (and ?v_20 (not ?v_21))) (and ?v_22 (not ?v_23))) (and ?v_24 (not ?v_24))) (and ?v_34 (not ?v_33)))) (or (or (or (or (or (and ?v_25 (not ?v_26)) (and ?v_27 (not ?v_28))) (and ?v_29 (not ?v_30))) (and ?v_31 (not ?v_32))) (and ?v_33 (not ?v_34))) (and ?v_35 (not ?v_35)))) (or (or (or (or (or (or (or (or (or (or (and ?v_37 (not ?v_37)) (and ?v_49 (not ?v_48))) (and ?v_61 (not ?v_60))) (and ?v_73 (not ?v_72))) (and ?v_85 (not ?v_84))) (and ?v_97 (not ?v_96))) (or (or (or (or (or (and ?v_48 (not ?v_49)) (and ?v_51 (not ?v_51))) (and ?v_63 (not ?v_62))) (and ?v_75 (not ?v_74))) (and ?v_87 (not ?v_86))) (and ?v_99 (not ?v_98)))) (or (or (or (or (or (and ?v_60 (not ?v_61)) (and ?v_62 (not ?v_63))) (and ?v_65 (not ?v_65))) (and ?v_77 (not ?v_76))) (and ?v_89 (not ?v_88))) (and ?v_101 (not ?v_100)))) (or (or (or (or (or (and ?v_72 (not ?v_73)) (and ?v_74 (not ?v_75))) (and ?v_76 (not ?v_77))) (and ?v_79 (not ?v_79))) (and ?v_91 (not ?v_90))) (and ?v_103 (not ?v_102)))) (or (or (or (or (or (and ?v_84 (not ?v_85)) (and ?v_86 (not ?v_87))) (and ?v_88 (not ?v_89))) (and ?v_90 (not ?v_91))) (and ?v_93 (not ?v_93))) (and ?v_105 (not ?v_104)))) (or (or (or (or (or (and ?v_96 (not ?v_97)) (and ?v_98 (not ?v_99))) (and ?v_100 (not ?v_101))) (and ?v_102 (not ?v_103))) (and ?v_104 (not ?v_105))) (and ?v_107 (not ?v_107))))) (or (or (or (or (or (or (or (or (or (or (and ?v_108 (not ?v_108)) (and ?v_110 (not ?v_109))) (and ?v_113 (not ?v_112))) (and ?v_118 (not ?v_117))) (and ?v_125 (not ?v_124))) (and ?v_134 (not ?v_133))) (or (or (or (or (or (and ?v_109 (not ?v_110)) (and ?v_111 (not ?v_111))) (and ?v_115 (not ?v_114))) (and ?v_120 (not ?v_119))) (and ?v_127 (not ?v_126))) (and ?v_136 (not ?v_135)))) (or (or (or (or (or (and ?v_112 (not ?v_113)) (and ?v_114 (not ?v_115))) (and ?v_116 (not ?v_116))) (and ?v_122 (not ?v_121))) (and ?v_129 (not ?v_128))) (and ?v_138 (not ?v_137)))) (or (or (or (or (or (and ?v_117 (not ?v_118)) (and ?v_119 (not ?v_120))) (and ?v_121 (not ?v_122))) (and ?v_123 (not ?v_123))) (and ?v_131 (not ?v_130))) (and ?v_140 (not ?v_139)))) (or (or (or (or (or (and ?v_124 (not ?v_125)) (and ?v_126 (not ?v_127))) (and ?v_128 (not ?v_129))) (and ?v_130 (not ?v_131))) (and ?v_132 (not ?v_132))) (and ?v_142 (not ?v_141)))) (or (or (or (or (or (and ?v_133 (not ?v_134)) (and ?v_135 (not ?v_136))) (and ?v_137 (not ?v_138))) (and ?v_139 (not ?v_140))) (and ?v_141 (not ?v_142))) (and ?v_143 (not ?v_143))))) (or (or (or (or (or (or (or (or (or (or (and ?v_144 (not ?v_144)) (and ?v_146 (not ?v_145))) (and ?v_149 (not ?v_148))) (and ?v_154 (not ?v_153))) (and ?v_161 (not ?v_160))) (and ?v_170 (not ?v_169))) (or (or (or (or (or (and ?v_145 (not ?v_146)) (and ?v_147 (not ?v_147))) (and ?v_151 (not ?v_150))) (and ?v_156 (not ?v_155))) (and ?v_163 (not ?v_162))) (and ?v_172 (not ?v_171)))) (or (or (or (or (or (and ?v_148 (not ?v_149)) (and ?v_150 (not ?v_151))) (and ?v_152 (not ?v_152))) (and ?v_158 (not ?v_157))) (and ?v_165 (not ?v_164))) (and ?v_174 (not ?v_173)))) (or (or (or (or (or (and ?v_153 (not ?v_154)) (and ?v_155 (not ?v_156))) (and ?v_157 (not ?v_158))) (and ?v_159 (not ?v_159))) (and ?v_167 (not ?v_166))) (and ?v_176 (not ?v_175)))) (or (or (or (or (or (and ?v_160 (not ?v_161)) (and ?v_162 (not ?v_163))) (and ?v_164 (not ?v_165))) (and ?v_166 (not ?v_167))) (and ?v_168 (not ?v_168))) (and ?v_178 (not ?v_177)))) (or (or (or (or (or (and ?v_169 (not ?v_170)) (and ?v_171 (not ?v_172))) (and ?v_173 (not ?v_174))) (and ?v_175 (not ?v_176))) (and ?v_177 (not ?v_178))) (and ?v_179 (not ?v_179))))) (or (or (or (or (or (or (or (or (or (or (and ?v_180 (not ?v_180)) (and ?v_182 (not ?v_181))) (and ?v_185 (not ?v_184))) (and ?v_190 (not ?v_189))) (and ?v_197 (not ?v_196))) (and ?v_206 (not ?v_205))) (or (or (or (or (or (and ?v_181 (not ?v_182)) (and ?v_183 (not ?v_183))) (and ?v_187 (not ?v_186))) (and ?v_192 (not ?v_191))) (and ?v_199 (not ?v_198))) (and ?v_208 (not ?v_207)))) (or (or (or (or (or (and ?v_184 (not ?v_185)) (and ?v_186 (not ?v_187))) (and ?v_188 (not ?v_188))) (and ?v_194 (not ?v_193))) (and ?v_201 (not ?v_200))) (and ?v_210 (not ?v_209)))) (or (or (or (or (or (and ?v_189 (not ?v_190)) (and ?v_191 (not ?v_192))) (and ?v_193 (not ?v_194))) (and ?v_195 (not ?v_195))) (and ?v_203 (not ?v_202))) (and ?v_212 (not ?v_211)))) (or (or (or (or (or (and ?v_196 (not ?v_197)) (and ?v_198 (not ?v_199))) (and ?v_200 (not ?v_201))) (and ?v_202 (not ?v_203))) (and ?v_204 (not ?v_204))) (and ?v_214 (not ?v_213)))) (or (or (or (or (or (and ?v_205 (not ?v_206)) (and ?v_207 (not ?v_208))) (and ?v_209 (not ?v_210))) (and ?v_211 (not ?v_212))) (and ?v_213 (not ?v_214))) (and ?v_215 (not ?v_215))))) (or (or (or (or (or (or (or (or (or (or (and ?v_216 (not ?v_216)) (and ?v_218 (not ?v_217))) (and ?v_221 (not ?v_220))) (and ?v_226 (not ?v_225))) (and ?v_233 (not ?v_232))) (and ?v_242 (not ?v_241))) (or (or (or (or (or (and ?v_217 (not ?v_218)) (and ?v_219 (not ?v_219))) (and ?v_223 (not ?v_222))) (and ?v_228 (not ?v_227))) (and ?v_235 (not ?v_234))) (and ?v_244 (not ?v_243)))) (or (or (or (or (or (and ?v_220 (not ?v_221)) (and ?v_222 (not ?v_223))) (and ?v_224 (not ?v_224))) (and ?v_230 (not ?v_229))) (and ?v_237 (not ?v_236))) (and ?v_246 (not ?v_245)))) (or (or (or (or (or (and ?v_225 (not ?v_226)) (and ?v_227 (not ?v_228))) (and ?v_229 (not ?v_230))) (and ?v_231 (not ?v_231))) (and ?v_239 (not ?v_238))) (and ?v_248 (not ?v_247)))) (or (or (or (or (or (and ?v_232 (not ?v_233)) (and ?v_234 (not ?v_235))) (and ?v_236 (not ?v_237))) (and ?v_238 (not ?v_239))) (and ?v_240 (not ?v_240))) (and ?v_250 (not ?v_249)))) (or (or (or (or (or (and ?v_241 (not ?v_242)) (and ?v_243 (not ?v_244))) (and ?v_245 (not ?v_246))) (and ?v_247 (not ?v_248))) (and ?v_249 (not ?v_250))) (and ?v_251 (not ?v_251)))))))) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e0 e1)) (?v_2 (op e0 e2)) (?v_3 (op e0 e3)) (?v_4 (op e0 e4)) (?v_5 (op e0 e5)) (?v_6 (op e1 e0)) (?v_7 (op e1 e1)) (?v_8 (op e1 e2)) (?v_9 (op e1 e3)) (?v_10 (op e1 e4)) (?v_11 (op e1 e5)) (?v_12 (op e2 e0)) (?v_13 (op e2 e1)) (?v_14 (op e2 e2)) (?v_15 (op e2 e3)) (?v_16 (op e2 e4)) (?v_17 (op e2 e5)) (?v_18 (op e3 e0)) (?v_19 (op e3 e1)) (?v_20 (op e3 e2)) (?v_21 (op e3 e3)) (?v_22 (op e3 e4)) (?v_23 (op e3 e5)) (?v_24 (op e4 e0)) (?v_25 (op e4 e1)) (?v_26 (op e4 e2)) (?v_27 (op e4 e3)) (?v_28 (op e4 e4)) (?v_29 (op e4 e5)) (?v_30 (op e5 e0)) (?v_31 (op e5 e1)) (?v_32 (op e5 e2)) (?v_33 (op e5 e3)) (?v_34 (op e5 e4)) (?v_35 (op e5 e5))) (or (or (or (or (or (or (or (or (or (or (and (not (= (op e0 ?v_0) e0)) (= (op ?v_0 ?v_0) e0)) (and (not (= (op e0 ?v_1) e1)) (= (op ?v_1 ?v_1) e0))) (and (not (= (op e0 ?v_2) e2)) (= (op ?v_2 ?v_2) e0))) (and (not (= (op e0 ?v_3) e3)) (= (op ?v_3 ?v_3) e0))) (and (not (= (op e0 ?v_4) e4)) (= (op ?v_4 ?v_4) e0))) (and (not (= (op e0 ?v_5) e5)) (= (op ?v_5 ?v_5) e0))) (or (or (or (or (or (and (not (= (op e1 ?v_6) e0)) (= (op ?v_6 ?v_6) e1)) (and (not (= (op e1 ?v_7) e1)) (= (op ?v_7 ?v_7) e1))) (and (not (= (op e1 ?v_8) e2)) (= (op ?v_8 ?v_8) e1))) (and (not (= (op e1 ?v_9) e3)) (= (op ?v_9 ?v_9) e1))) (and (not (= (op e1 ?v_10) e4)) (= (op ?v_10 ?v_10) e1))) (and (not (= (op e1 ?v_11) e5)) (= (op ?v_11 ?v_11) e1)))) (or (or (or (or (or (and (not (= (op e2 ?v_12) e0)) (= (op ?v_12 ?v_12) e2)) (and (not (= (op e2 ?v_13) e1)) (= (op ?v_13 ?v_13) e2))) (and (not (= (op e2 ?v_14) e2)) (= (op ?v_14 ?v_14) e2))) (and (not (= (op e2 ?v_15) e3)) (= (op ?v_15 ?v_15) e2))) (and (not (= (op e2 ?v_16) e4)) (= (op ?v_16 ?v_16) e2))) (and (not (= (op e2 ?v_17) e5)) (= (op ?v_17 ?v_17) e2)))) (or (or (or (or (or (and (not (= (op e3 ?v_18) e0)) (= (op ?v_18 ?v_18) e3)) (and (not (= (op e3 ?v_19) e1)) (= (op ?v_19 ?v_19) e3))) (and (not (= (op e3 ?v_20) e2)) (= (op ?v_20 ?v_20) e3))) (and (not (= (op e3 ?v_21) e3)) (= (op ?v_21 ?v_21) e3))) (and (not (= (op e3 ?v_22) e4)) (= (op ?v_22 ?v_22) e3))) (and (not (= (op e3 ?v_23) e5)) (= (op ?v_23 ?v_23) e3)))) (or (or (or (or (or (and (not (= (op e4 ?v_24) e0)) (= (op ?v_24 ?v_24) e4)) (and (not (= (op e4 ?v_25) e1)) (= (op ?v_25 ?v_25) e4))) (and (not (= (op e4 ?v_26) e2)) (= (op ?v_26 ?v_26) e4))) (and (not (= (op e4 ?v_27) e3)) (= (op ?v_27 ?v_27) e4))) (and (not (= (op e4 ?v_28) e4)) (= (op ?v_28 ?v_28) e4))) (and (not (= (op e4 ?v_29) e5)) (= (op ?v_29 ?v_29) e4)))) (or (or (or (or (or (and (not (= (op e5 ?v_30) e0)) (= (op ?v_30 ?v_30) e5)) (and (not (= (op e5 ?v_31) e1)) (= (op ?v_31 ?v_31) e5))) (and (not (= (op e5 ?v_32) e2)) (= (op ?v_32 ?v_32) e5))) (and (not (= (op e5 ?v_33) e3)) (= (op ?v_33 ?v_33) e5))) (and (not (= (op e5 ?v_34) e4)) (= (op ?v_34 ?v_34) e5))) (and (not (= (op e5 ?v_35) e5)) (= (op ?v_35 ?v_35) e5)))))) +(assert (let ((?v_2 (op e0 e0)) (?v_51 (op e0 e1)) (?v_54 (op e0 e2)) (?v_56 (op e0 e3)) (?v_58 (op e0 e4)) (?v_60 (op e0 e5)) (?v_6 (op e1 e0)) (?v_65 (op e1 e1)) (?v_68 (op e1 e2)) (?v_70 (op e1 e3)) (?v_72 (op e1 e4)) (?v_74 (op e1 e5)) (?v_12 (op e2 e0)) (?v_69 (op e2 e1)) (?v_82 (op e2 e2)) (?v_84 (op e2 e3)) (?v_86 (op e2 e4)) (?v_88 (op e2 e5)) (?v_19 (op e3 e0)) (?v_71 (op e3 e1)) (?v_85 (op e3 e2)) (?v_98 (op e3 e3)) (?v_100 (op e3 e4)) (?v_102 (op e3 e5)) (?v_28 (op e4 e0)) (?v_73 (op e4 e1)) (?v_87 (op e4 e2)) (?v_101 (op e4 e3)) (?v_114 (op e4 e4)) (?v_116 (op e4 e5)) (?v_39 (op e5 e0)) (?v_75 (op e5 e1)) (?v_89 (op e5 e2)) (?v_103 (op e5 e3)) (?v_117 (op e5 e4)) (?v_130 (op e5 e5))) (let ((?v_0 (= ?v_2 e0)) (?v_48 (= ?v_2 e1)) (?v_132 (= ?v_2 e2)) (?v_198 (= ?v_2 e3)) (?v_276 (= ?v_2 e4)) (?v_366 (= ?v_2 e5)) (?v_5 (= ?v_51 e0)) (?v_52 (= ?v_51 e1)) (?v_135 (= ?v_51 e2)) (?v_201 (= ?v_51 e3)) (?v_279 (= ?v_51 e4)) (?v_369 (= ?v_51 e5)) (?v_10 (= ?v_54 e0)) (?v_78 (= ?v_54 e1)) (?v_138 (= ?v_54 e2)) (?v_204 (= ?v_54 e3)) (?v_282 (= ?v_54 e4)) (?v_372 (= ?v_54 e5)) (?v_17 (= ?v_56 e0)) (?v_92 (= ?v_56 e1)) (?v_164 (= ?v_56 e2)) (?v_207 (= ?v_56 e3)) (?v_285 (= ?v_56 e4)) (?v_375 (= ?v_56 e5)) (?v_26 (= ?v_58 e0)) (?v_106 (= ?v_58 e1)) (?v_174 (= ?v_58 e2)) (?v_250 (= ?v_58 e3)) (?v_288 (= ?v_58 e4)) (?v_378 (= ?v_58 e5)) (?v_37 (= ?v_60 e0)) (?v_120 (= ?v_60 e1)) (?v_186 (= ?v_60 e2)) (?v_263 (= ?v_60 e3)) (?v_352 (= ?v_60 e4)) (?v_381 (= ?v_60 e5)) (?v_3 (= ?v_6 e0)) (?v_62 (= ?v_6 e1)) (?v_143 (= ?v_6 e2)) (?v_211 (= ?v_6 e3)) (?v_291 (= ?v_6 e4)) (?v_383 (= ?v_6 e5)) (?v_7 (= ?v_65 e0)) (?v_66 (= ?v_65 e1)) (?v_146 (= ?v_65 e2)) (?v_214 (= ?v_65 e3)) (?v_294 (= ?v_65 e4)) (?v_386 (= ?v_65 e5)) (?v_13 (= ?v_68 e0)) (?v_81 (= ?v_68 e1)) (?v_149 (= ?v_68 e2)) (?v_217 (= ?v_68 e3)) (?v_297 (= ?v_68 e4)) (?v_389 (= ?v_68 e5)) (?v_20 (= ?v_70 e0)) (?v_95 (= ?v_70 e1)) (?v_167 (= ?v_70 e2)) (?v_220 (= ?v_70 e3)) (?v_300 (= ?v_70 e4)) (?v_392 (= ?v_70 e5)) (?v_29 (= ?v_72 e0)) (?v_109 (= ?v_72 e1)) (?v_177 (= ?v_72 e2)) (?v_253 (= ?v_72 e3)) (?v_303 (= ?v_72 e4)) (?v_395 (= ?v_72 e5)) (?v_40 (= ?v_74 e0)) (?v_123 (= ?v_74 e1)) (?v_189 (= ?v_74 e2)) (?v_266 (= ?v_74 e3)) (?v_355 (= ?v_74 e4)) (?v_398 (= ?v_74 e5)) (?v_8 (= ?v_12 e0)) (?v_76 (= ?v_12 e1)) (?v_154 (= ?v_12 e2)) (?v_224 (= ?v_12 e3)) (?v_306 (= ?v_12 e4)) (?v_400 (= ?v_12 e5)) (?v_11 (= ?v_69 e0)) (?v_79 (= ?v_69 e1)) (?v_157 (= ?v_69 e2)) (?v_227 (= ?v_69 e3)) (?v_309 (= ?v_69 e4)) (?v_403 (= ?v_69 e5)) (?v_14 (= ?v_82 e0)) (?v_83 (= ?v_82 e1)) (?v_160 (= ?v_82 e2)) (?v_230 (= ?v_82 e3)) (?v_312 (= ?v_82 e4)) (?v_406 (= ?v_82 e5)) (?v_22 (= ?v_84 e0)) (?v_97 (= ?v_84 e1)) (?v_170 (= ?v_84 e2)) (?v_233 (= ?v_84 e3)) (?v_315 (= ?v_84 e4)) (?v_409 (= ?v_84 e5)) (?v_31 (= ?v_86 e0)) (?v_111 (= ?v_86 e1)) (?v_180 (= ?v_86 e2)) (?v_256 (= ?v_86 e3)) (?v_318 (= ?v_86 e4)) (?v_412 (= ?v_86 e5)) (?v_42 (= ?v_88 e0)) (?v_125 (= ?v_88 e1)) (?v_192 (= ?v_88 e2)) (?v_269 (= ?v_88 e3)) (?v_358 (= ?v_88 e4)) (?v_415 (= ?v_88 e5)) (?v_15 (= ?v_19 e0)) (?v_90 (= ?v_19 e1)) (?v_162 (= ?v_19 e2)) (?v_237 (= ?v_19 e3)) (?v_321 (= ?v_19 e4)) (?v_417 (= ?v_19 e5)) (?v_18 (= ?v_71 e0)) (?v_93 (= ?v_71 e1)) (?v_165 (= ?v_71 e2)) (?v_240 (= ?v_71 e3)) (?v_324 (= ?v_71 e4)) (?v_420 (= ?v_71 e5)) (?v_21 (= ?v_85 e0)) (?v_96 (= ?v_85 e1)) (?v_168 (= ?v_85 e2)) (?v_243 (= ?v_85 e3)) (?v_327 (= ?v_85 e4)) (?v_423 (= ?v_85 e5)) (?v_23 (= ?v_98 e0)) (?v_99 (= ?v_98 e1)) (?v_171 (= ?v_98 e2)) (?v_246 (= ?v_98 e3)) (?v_330 (= ?v_98 e4)) (?v_426 (= ?v_98 e5)) (?v_33 (= ?v_100 e0)) (?v_113 (= ?v_100 e1)) (?v_182 (= ?v_100 e2)) (?v_259 (= ?v_100 e3)) (?v_333 (= ?v_100 e4)) (?v_429 (= ?v_100 e5)) (?v_44 (= ?v_102 e0)) (?v_127 (= ?v_102 e1)) (?v_194 (= ?v_102 e2)) (?v_272 (= ?v_102 e3)) (?v_361 (= ?v_102 e4)) (?v_432 (= ?v_102 e5)) (?v_24 (= ?v_28 e0)) (?v_104 (= ?v_28 e1)) (?v_172 (= ?v_28 e2)) (?v_248 (= ?v_28 e3)) (?v_336 (= ?v_28 e4)) (?v_434 (= ?v_28 e5)) (?v_27 (= ?v_73 e0)) (?v_107 (= ?v_73 e1)) (?v_175 (= ?v_73 e2)) (?v_251 (= ?v_73 e3)) (?v_339 (= ?v_73 e4)) (?v_437 (= ?v_73 e5)) (?v_30 (= ?v_87 e0)) (?v_110 (= ?v_87 e1)) (?v_178 (= ?v_87 e2)) (?v_254 (= ?v_87 e3)) (?v_342 (= ?v_87 e4)) (?v_440 (= ?v_87 e5)) (?v_32 (= ?v_101 e0)) (?v_112 (= ?v_101 e1)) (?v_181 (= ?v_101 e2)) (?v_257 (= ?v_101 e3)) (?v_345 (= ?v_101 e4)) (?v_443 (= ?v_101 e5)) (?v_34 (= ?v_114 e0)) (?v_115 (= ?v_114 e1)) (?v_183 (= ?v_114 e2)) (?v_260 (= ?v_114 e3)) (?v_348 (= ?v_114 e4)) (?v_446 (= ?v_114 e5)) (?v_46 (= ?v_116 e0)) (?v_129 (= ?v_116 e1)) (?v_196 (= ?v_116 e2)) (?v_274 (= ?v_116 e3)) (?v_364 (= ?v_116 e4)) (?v_449 (= ?v_116 e5)) (?v_35 (= ?v_39 e0)) (?v_118 (= ?v_39 e1)) (?v_184 (= ?v_39 e2)) (?v_261 (= ?v_39 e3)) (?v_350 (= ?v_39 e4)) (?v_451 (= ?v_39 e5)) (?v_38 (= ?v_75 e0)) (?v_121 (= ?v_75 e1)) (?v_187 (= ?v_75 e2)) (?v_264 (= ?v_75 e3)) (?v_353 (= ?v_75 e4)) (?v_454 (= ?v_75 e5)) (?v_41 (= ?v_89 e0)) (?v_124 (= ?v_89 e1)) (?v_190 (= ?v_89 e2)) (?v_267 (= ?v_89 e3)) (?v_356 (= ?v_89 e4)) (?v_457 (= ?v_89 e5)) (?v_43 (= ?v_103 e0)) (?v_126 (= ?v_103 e1)) (?v_193 (= ?v_103 e2)) (?v_270 (= ?v_103 e3)) (?v_359 (= ?v_103 e4)) (?v_460 (= ?v_103 e5)) (?v_45 (= ?v_117 e0)) (?v_128 (= ?v_117 e1)) (?v_195 (= ?v_117 e2)) (?v_273 (= ?v_117 e3)) (?v_362 (= ?v_117 e4)) (?v_463 (= ?v_117 e5)) (?v_47 (= ?v_130 e0)) (?v_131 (= ?v_130 e1)) (?v_197 (= ?v_130 e2)) (?v_275 (= ?v_130 e3)) (?v_365 (= ?v_130 e4)) (?v_466 (= ?v_130 e5))) (let ((?v_1 (not ?v_0)) (?v_4 (not ?v_3)) (?v_9 (not ?v_8)) (?v_16 (not ?v_15)) (?v_25 (not ?v_24)) (?v_36 (not ?v_35)) (?v_49 (not ?v_5)) (?v_63 (not ?v_7)) (?v_77 (not ?v_11)) (?v_91 (not ?v_18)) (?v_105 (not ?v_27)) (?v_119 (not ?v_38)) (?v_133 (not ?v_10)) (?v_144 (not ?v_13)) (?v_155 (not ?v_14)) (?v_163 (not ?v_21)) (?v_173 (not ?v_30)) (?v_185 (not ?v_41)) (?v_199 (not ?v_17)) (?v_212 (not ?v_20)) (?v_225 (not ?v_22)) (?v_238 (not ?v_23)) (?v_249 (not ?v_32)) (?v_262 (not ?v_43)) (?v_277 (not ?v_26)) (?v_292 (not ?v_29)) (?v_307 (not ?v_31)) (?v_322 (not ?v_33)) (?v_337 (not ?v_34)) (?v_351 (not ?v_45)) (?v_367 (not ?v_37)) (?v_384 (not ?v_40)) (?v_401 (not ?v_42)) (?v_418 (not ?v_44)) (?v_435 (not ?v_46)) (?v_452 (not ?v_47)) (?v_50 (not ?v_48)) (?v_53 (not ?v_62)) (?v_55 (not ?v_76)) (?v_57 (not ?v_90)) (?v_59 (not ?v_104)) (?v_61 (not ?v_118)) (?v_64 (not ?v_52)) (?v_67 (not ?v_66)) (?v_80 (not ?v_79)) (?v_94 (not ?v_93)) (?v_108 (not ?v_107)) (?v_122 (not ?v_121)) (?v_136 (not ?v_78)) (?v_147 (not ?v_81)) (?v_158 (not ?v_83)) (?v_166 (not ?v_96)) (?v_176 (not ?v_110)) (?v_188 (not ?v_124)) (?v_202 (not ?v_92)) (?v_215 (not ?v_95)) (?v_228 (not ?v_97)) (?v_241 (not ?v_99)) (?v_252 (not ?v_112)) (?v_265 (not ?v_126)) (?v_280 (not ?v_106)) (?v_295 (not ?v_109)) (?v_310 (not ?v_111)) (?v_325 (not ?v_113)) (?v_340 (not ?v_115)) (?v_354 (not ?v_128)) (?v_370 (not ?v_120)) (?v_387 (not ?v_123)) (?v_404 (not ?v_125)) (?v_421 (not ?v_127)) (?v_438 (not ?v_129)) (?v_455 (not ?v_131)) (?v_134 (not ?v_132)) (?v_137 (not ?v_143)) (?v_139 (not ?v_154)) (?v_140 (not ?v_162)) (?v_141 (not ?v_172)) (?v_142 (not ?v_184)) (?v_145 (not ?v_135)) (?v_148 (not ?v_146)) (?v_150 (not ?v_157)) (?v_151 (not ?v_165)) (?v_152 (not ?v_175)) (?v_153 (not ?v_187)) (?v_156 (not ?v_138)) (?v_159 (not ?v_149)) (?v_161 (not ?v_160)) (?v_169 (not ?v_168)) (?v_179 (not ?v_178)) (?v_191 (not ?v_190)) (?v_205 (not ?v_164)) (?v_218 (not ?v_167)) (?v_231 (not ?v_170)) (?v_244 (not ?v_171)) (?v_255 (not ?v_181)) (?v_268 (not ?v_193)) (?v_283 (not ?v_174)) (?v_298 (not ?v_177)) (?v_313 (not ?v_180)) (?v_328 (not ?v_182)) (?v_343 (not ?v_183)) (?v_357 (not ?v_195)) (?v_373 (not ?v_186)) (?v_390 (not ?v_189)) (?v_407 (not ?v_192)) (?v_424 (not ?v_194)) (?v_441 (not ?v_196)) (?v_458 (not ?v_197)) (?v_200 (not ?v_198)) (?v_203 (not ?v_211)) (?v_206 (not ?v_224)) (?v_208 (not ?v_237)) (?v_209 (not ?v_248)) (?v_210 (not ?v_261)) (?v_213 (not ?v_201)) (?v_216 (not ?v_214)) (?v_219 (not ?v_227)) (?v_221 (not ?v_240)) (?v_222 (not ?v_251)) (?v_223 (not ?v_264)) (?v_226 (not ?v_204)) (?v_229 (not ?v_217)) (?v_232 (not ?v_230)) (?v_234 (not ?v_243)) (?v_235 (not ?v_254)) (?v_236 (not ?v_267)) (?v_239 (not ?v_207)) (?v_242 (not ?v_220)) (?v_245 (not ?v_233)) (?v_247 (not ?v_246)) (?v_258 (not ?v_257)) (?v_271 (not ?v_270)) (?v_286 (not ?v_250)) (?v_301 (not ?v_253)) (?v_316 (not ?v_256)) (?v_331 (not ?v_259)) (?v_346 (not ?v_260)) (?v_360 (not ?v_273)) (?v_376 (not ?v_263)) (?v_393 (not ?v_266)) (?v_410 (not ?v_269)) (?v_427 (not ?v_272)) (?v_444 (not ?v_274)) (?v_461 (not ?v_275)) (?v_278 (not ?v_276)) (?v_281 (not ?v_291)) (?v_284 (not ?v_306)) (?v_287 (not ?v_321)) (?v_289 (not ?v_336)) (?v_290 (not ?v_350)) (?v_293 (not ?v_279)) (?v_296 (not ?v_294)) (?v_299 (not ?v_309)) (?v_302 (not ?v_324)) (?v_304 (not ?v_339)) (?v_305 (not ?v_353)) (?v_308 (not ?v_282)) (?v_311 (not ?v_297)) (?v_314 (not ?v_312)) (?v_317 (not ?v_327)) (?v_319 (not ?v_342)) (?v_320 (not ?v_356)) (?v_323 (not ?v_285)) (?v_326 (not ?v_300)) (?v_329 (not ?v_315)) (?v_332 (not ?v_330)) (?v_334 (not ?v_345)) (?v_335 (not ?v_359)) (?v_338 (not ?v_288)) (?v_341 (not ?v_303)) (?v_344 (not ?v_318)) (?v_347 (not ?v_333)) (?v_349 (not ?v_348)) (?v_363 (not ?v_362)) (?v_379 (not ?v_352)) (?v_396 (not ?v_355)) (?v_413 (not ?v_358)) (?v_430 (not ?v_361)) (?v_447 (not ?v_364)) (?v_464 (not ?v_365)) (?v_368 (not ?v_366)) (?v_371 (not ?v_383)) (?v_374 (not ?v_400)) (?v_377 (not ?v_417)) (?v_380 (not ?v_434)) (?v_382 (not ?v_451)) (?v_385 (not ?v_369)) (?v_388 (not ?v_386)) (?v_391 (not ?v_403)) (?v_394 (not ?v_420)) (?v_397 (not ?v_437)) (?v_399 (not ?v_454)) (?v_402 (not ?v_372)) (?v_405 (not ?v_389)) (?v_408 (not ?v_406)) (?v_411 (not ?v_423)) (?v_414 (not ?v_440)) (?v_416 (not ?v_457)) (?v_419 (not ?v_375)) (?v_422 (not ?v_392)) (?v_425 (not ?v_409)) (?v_428 (not ?v_426)) (?v_431 (not ?v_443)) (?v_433 (not ?v_460)) (?v_436 (not ?v_378)) (?v_439 (not ?v_395)) (?v_442 (not ?v_412)) (?v_445 (not ?v_429)) (?v_448 (not ?v_446)) (?v_450 (not ?v_463)) (?v_453 (not ?v_381)) (?v_456 (not ?v_398)) (?v_459 (not ?v_415)) (?v_462 (not ?v_432)) (?v_465 (not ?v_449)) (?v_467 (not ?v_466))) (and (and (and (and (and (or (or (or (or (or (or (or (or (or (or (and ?v_0 (and ?v_1 ?v_1)) (and ?v_5 (and ?v_50 ?v_4))) (and ?v_10 (and ?v_134 ?v_9))) (and ?v_17 (and ?v_200 ?v_16))) (and ?v_26 (and ?v_278 ?v_25))) (and ?v_37 (and ?v_368 ?v_36))) (or (or (or (or (or (and ?v_3 (and ?v_4 ?v_49)) (and ?v_7 (and ?v_53 ?v_63))) (and ?v_13 (and ?v_137 ?v_77))) (and ?v_20 (and ?v_203 ?v_91))) (and ?v_29 (and ?v_281 ?v_105))) (and ?v_40 (and ?v_371 ?v_119)))) (or (or (or (or (or (and ?v_8 (and ?v_9 ?v_133)) (and ?v_11 (and ?v_55 ?v_144))) (and ?v_14 (and ?v_139 ?v_155))) (and ?v_22 (and ?v_206 ?v_163))) (and ?v_31 (and ?v_284 ?v_173))) (and ?v_42 (and ?v_374 ?v_185)))) (or (or (or (or (or (and ?v_15 (and ?v_16 ?v_199)) (and ?v_18 (and ?v_57 ?v_212))) (and ?v_21 (and ?v_140 ?v_225))) (and ?v_23 (and ?v_208 ?v_238))) (and ?v_33 (and ?v_287 ?v_249))) (and ?v_44 (and ?v_377 ?v_262)))) (or (or (or (or (or (and ?v_24 (and ?v_25 ?v_277)) (and ?v_27 (and ?v_59 ?v_292))) (and ?v_30 (and ?v_141 ?v_307))) (and ?v_32 (and ?v_209 ?v_322))) (and ?v_34 (and ?v_289 ?v_337))) (and ?v_46 (and ?v_380 ?v_351)))) (or (or (or (or (or (and ?v_35 (and ?v_36 ?v_367)) (and ?v_38 (and ?v_61 ?v_384))) (and ?v_41 (and ?v_142 ?v_401))) (and ?v_43 (and ?v_210 ?v_418))) (and ?v_45 (and ?v_290 ?v_435))) (and ?v_47 (and ?v_382 ?v_452)))) (or (or (or (or (or (or (or (or (or (or (and ?v_48 (and ?v_49 ?v_50)) (and ?v_52 (and ?v_64 ?v_53))) (and ?v_78 (and ?v_145 ?v_55))) (and ?v_92 (and ?v_213 ?v_57))) (and ?v_106 (and ?v_293 ?v_59))) (and ?v_120 (and ?v_385 ?v_61))) (or (or (or (or (or (and ?v_62 (and ?v_63 ?v_64)) (and ?v_66 (and ?v_67 ?v_67))) (and ?v_81 (and ?v_148 ?v_80))) (and ?v_95 (and ?v_216 ?v_94))) (and ?v_109 (and ?v_296 ?v_108))) (and ?v_123 (and ?v_388 ?v_122)))) (or (or (or (or (or (and ?v_76 (and ?v_77 ?v_136)) (and ?v_79 (and ?v_80 ?v_147))) (and ?v_83 (and ?v_150 ?v_158))) (and ?v_97 (and ?v_219 ?v_166))) (and ?v_111 (and ?v_299 ?v_176))) (and ?v_125 (and ?v_391 ?v_188)))) (or (or (or (or (or (and ?v_90 (and ?v_91 ?v_202)) (and ?v_93 (and ?v_94 ?v_215))) (and ?v_96 (and ?v_151 ?v_228))) (and ?v_99 (and ?v_221 ?v_241))) (and ?v_113 (and ?v_302 ?v_252))) (and ?v_127 (and ?v_394 ?v_265)))) (or (or (or (or (or (and ?v_104 (and ?v_105 ?v_280)) (and ?v_107 (and ?v_108 ?v_295))) (and ?v_110 (and ?v_152 ?v_310))) (and ?v_112 (and ?v_222 ?v_325))) (and ?v_115 (and ?v_304 ?v_340))) (and ?v_129 (and ?v_397 ?v_354)))) (or (or (or (or (or (and ?v_118 (and ?v_119 ?v_370)) (and ?v_121 (and ?v_122 ?v_387))) (and ?v_124 (and ?v_153 ?v_404))) (and ?v_126 (and ?v_223 ?v_421))) (and ?v_128 (and ?v_305 ?v_438))) (and ?v_131 (and ?v_399 ?v_455))))) (or (or (or (or (or (or (or (or (or (or (and ?v_132 (and ?v_133 ?v_134)) (and ?v_135 (and ?v_136 ?v_137))) (and ?v_138 (and ?v_156 ?v_139))) (and ?v_164 (and ?v_226 ?v_140))) (and ?v_174 (and ?v_308 ?v_141))) (and ?v_186 (and ?v_402 ?v_142))) (or (or (or (or (or (and ?v_143 (and ?v_144 ?v_145)) (and ?v_146 (and ?v_147 ?v_148))) (and ?v_149 (and ?v_159 ?v_150))) (and ?v_167 (and ?v_229 ?v_151))) (and ?v_177 (and ?v_311 ?v_152))) (and ?v_189 (and ?v_405 ?v_153)))) (or (or (or (or (or (and ?v_154 (and ?v_155 ?v_156)) (and ?v_157 (and ?v_158 ?v_159))) (and ?v_160 (and ?v_161 ?v_161))) (and ?v_170 (and ?v_232 ?v_169))) (and ?v_180 (and ?v_314 ?v_179))) (and ?v_192 (and ?v_408 ?v_191)))) (or (or (or (or (or (and ?v_162 (and ?v_163 ?v_205)) (and ?v_165 (and ?v_166 ?v_218))) (and ?v_168 (and ?v_169 ?v_231))) (and ?v_171 (and ?v_234 ?v_244))) (and ?v_182 (and ?v_317 ?v_255))) (and ?v_194 (and ?v_411 ?v_268)))) (or (or (or (or (or (and ?v_172 (and ?v_173 ?v_283)) (and ?v_175 (and ?v_176 ?v_298))) (and ?v_178 (and ?v_179 ?v_313))) (and ?v_181 (and ?v_235 ?v_328))) (and ?v_183 (and ?v_319 ?v_343))) (and ?v_196 (and ?v_414 ?v_357)))) (or (or (or (or (or (and ?v_184 (and ?v_185 ?v_373)) (and ?v_187 (and ?v_188 ?v_390))) (and ?v_190 (and ?v_191 ?v_407))) (and ?v_193 (and ?v_236 ?v_424))) (and ?v_195 (and ?v_320 ?v_441))) (and ?v_197 (and ?v_416 ?v_458))))) (or (or (or (or (or (or (or (or (or (or (and ?v_198 (and ?v_199 ?v_200)) (and ?v_201 (and ?v_202 ?v_203))) (and ?v_204 (and ?v_205 ?v_206))) (and ?v_207 (and ?v_239 ?v_208))) (and ?v_250 (and ?v_323 ?v_209))) (and ?v_263 (and ?v_419 ?v_210))) (or (or (or (or (or (and ?v_211 (and ?v_212 ?v_213)) (and ?v_214 (and ?v_215 ?v_216))) (and ?v_217 (and ?v_218 ?v_219))) (and ?v_220 (and ?v_242 ?v_221))) (and ?v_253 (and ?v_326 ?v_222))) (and ?v_266 (and ?v_422 ?v_223)))) (or (or (or (or (or (and ?v_224 (and ?v_225 ?v_226)) (and ?v_227 (and ?v_228 ?v_229))) (and ?v_230 (and ?v_231 ?v_232))) (and ?v_233 (and ?v_245 ?v_234))) (and ?v_256 (and ?v_329 ?v_235))) (and ?v_269 (and ?v_425 ?v_236)))) (or (or (or (or (or (and ?v_237 (and ?v_238 ?v_239)) (and ?v_240 (and ?v_241 ?v_242))) (and ?v_243 (and ?v_244 ?v_245))) (and ?v_246 (and ?v_247 ?v_247))) (and ?v_259 (and ?v_332 ?v_258))) (and ?v_272 (and ?v_428 ?v_271)))) (or (or (or (or (or (and ?v_248 (and ?v_249 ?v_286)) (and ?v_251 (and ?v_252 ?v_301))) (and ?v_254 (and ?v_255 ?v_316))) (and ?v_257 (and ?v_258 ?v_331))) (and ?v_260 (and ?v_334 ?v_346))) (and ?v_274 (and ?v_431 ?v_360)))) (or (or (or (or (or (and ?v_261 (and ?v_262 ?v_376)) (and ?v_264 (and ?v_265 ?v_393))) (and ?v_267 (and ?v_268 ?v_410))) (and ?v_270 (and ?v_271 ?v_427))) (and ?v_273 (and ?v_335 ?v_444))) (and ?v_275 (and ?v_433 ?v_461))))) (or (or (or (or (or (or (or (or (or (or (and ?v_276 (and ?v_277 ?v_278)) (and ?v_279 (and ?v_280 ?v_281))) (and ?v_282 (and ?v_283 ?v_284))) (and ?v_285 (and ?v_286 ?v_287))) (and ?v_288 (and ?v_338 ?v_289))) (and ?v_352 (and ?v_436 ?v_290))) (or (or (or (or (or (and ?v_291 (and ?v_292 ?v_293)) (and ?v_294 (and ?v_295 ?v_296))) (and ?v_297 (and ?v_298 ?v_299))) (and ?v_300 (and ?v_301 ?v_302))) (and ?v_303 (and ?v_341 ?v_304))) (and ?v_355 (and ?v_439 ?v_305)))) (or (or (or (or (or (and ?v_306 (and ?v_307 ?v_308)) (and ?v_309 (and ?v_310 ?v_311))) (and ?v_312 (and ?v_313 ?v_314))) (and ?v_315 (and ?v_316 ?v_317))) (and ?v_318 (and ?v_344 ?v_319))) (and ?v_358 (and ?v_442 ?v_320)))) (or (or (or (or (or (and ?v_321 (and ?v_322 ?v_323)) (and ?v_324 (and ?v_325 ?v_326))) (and ?v_327 (and ?v_328 ?v_329))) (and ?v_330 (and ?v_331 ?v_332))) (and ?v_333 (and ?v_347 ?v_334))) (and ?v_361 (and ?v_445 ?v_335)))) (or (or (or (or (or (and ?v_336 (and ?v_337 ?v_338)) (and ?v_339 (and ?v_340 ?v_341))) (and ?v_342 (and ?v_343 ?v_344))) (and ?v_345 (and ?v_346 ?v_347))) (and ?v_348 (and ?v_349 ?v_349))) (and ?v_364 (and ?v_448 ?v_363)))) (or (or (or (or (or (and ?v_350 (and ?v_351 ?v_379)) (and ?v_353 (and ?v_354 ?v_396))) (and ?v_356 (and ?v_357 ?v_413))) (and ?v_359 (and ?v_360 ?v_430))) (and ?v_362 (and ?v_363 ?v_447))) (and ?v_365 (and ?v_450 ?v_464))))) (or (or (or (or (or (or (or (or (or (or (and ?v_366 (and ?v_367 ?v_368)) (and ?v_369 (and ?v_370 ?v_371))) (and ?v_372 (and ?v_373 ?v_374))) (and ?v_375 (and ?v_376 ?v_377))) (and ?v_378 (and ?v_379 ?v_380))) (and ?v_381 (and ?v_453 ?v_382))) (or (or (or (or (or (and ?v_383 (and ?v_384 ?v_385)) (and ?v_386 (and ?v_387 ?v_388))) (and ?v_389 (and ?v_390 ?v_391))) (and ?v_392 (and ?v_393 ?v_394))) (and ?v_395 (and ?v_396 ?v_397))) (and ?v_398 (and ?v_456 ?v_399)))) (or (or (or (or (or (and ?v_400 (and ?v_401 ?v_402)) (and ?v_403 (and ?v_404 ?v_405))) (and ?v_406 (and ?v_407 ?v_408))) (and ?v_409 (and ?v_410 ?v_411))) (and ?v_412 (and ?v_413 ?v_414))) (and ?v_415 (and ?v_459 ?v_416)))) (or (or (or (or (or (and ?v_417 (and ?v_418 ?v_419)) (and ?v_420 (and ?v_421 ?v_422))) (and ?v_423 (and ?v_424 ?v_425))) (and ?v_426 (and ?v_427 ?v_428))) (and ?v_429 (and ?v_430 ?v_431))) (and ?v_432 (and ?v_462 ?v_433)))) (or (or (or (or (or (and ?v_434 (and ?v_435 ?v_436)) (and ?v_437 (and ?v_438 ?v_439))) (and ?v_440 (and ?v_441 ?v_442))) (and ?v_443 (and ?v_444 ?v_445))) (and ?v_446 (and ?v_447 ?v_448))) (and ?v_449 (and ?v_465 ?v_450)))) (or (or (or (or (or (and ?v_451 (and ?v_452 ?v_453)) (and ?v_454 (and ?v_455 ?v_456))) (and ?v_457 (and ?v_458 ?v_459))) (and ?v_460 (and ?v_461 ?v_462))) (and ?v_463 (and ?v_464 ?v_465))) (and ?v_466 (and ?v_467 ?v_467))))))))) +(assert (let ((?v_2 (op e0 e0)) (?v_11 (op e0 e1)) (?v_12 (op e0 e2)) (?v_13 (op e0 e3)) (?v_14 (op e0 e4)) (?v_15 (op e0 e5)) (?v_10 (op e1 e0)) (?v_49 (op e1 e1)) (?v_52 (op e1 e2)) (?v_54 (op e1 e3)) (?v_56 (op e1 e4)) (?v_58 (op e1 e5)) (?v_18 (op e2 e0)) (?v_63 (op e2 e1)) (?v_66 (op e2 e2)) (?v_67 (op e2 e3)) (?v_68 (op e2 e4)) (?v_69 (op e2 e5)) (?v_21 (op e3 e0)) (?v_73 (op e3 e1)) (?v_76 (op e3 e2)) (?v_77 (op e3 e3)) (?v_78 (op e3 e4)) (?v_79 (op e3 e5)) (?v_24 (op e4 e0)) (?v_83 (op e4 e1)) (?v_86 (op e4 e2)) (?v_87 (op e4 e3)) (?v_88 (op e4 e4)) (?v_89 (op e4 e5)) (?v_27 (op e5 e0)) (?v_93 (op e5 e1)) (?v_96 (op e5 e2)) (?v_97 (op e5 e3)) (?v_98 (op e5 e4)) (?v_99 (op e5 e5))) (let ((?v_0 (= ?v_2 e0)) (?v_28 (= ?v_2 e1)) (?v_100 (= ?v_2 e2)) (?v_171 (= ?v_2 e3)) (?v_260 (= ?v_2 e4)) (?v_361 (= ?v_2 e5)) (?v_3 (= ?v_11 e0)) (?v_31 (= ?v_11 e1)) (?v_103 (= ?v_11 e2)) (?v_174 (= ?v_11 e3)) (?v_263 (= ?v_11 e4)) (?v_364 (= ?v_11 e5)) (?v_4 (= ?v_12 e0)) (?v_34 (= ?v_12 e1)) (?v_106 (= ?v_12 e2)) (?v_177 (= ?v_12 e3)) (?v_266 (= ?v_12 e4)) (?v_367 (= ?v_12 e5)) (?v_5 (= ?v_13 e0)) (?v_37 (= ?v_13 e1)) (?v_109 (= ?v_13 e2)) (?v_180 (= ?v_13 e3)) (?v_269 (= ?v_13 e4)) (?v_370 (= ?v_13 e5)) (?v_6 (= ?v_14 e0)) (?v_40 (= ?v_14 e1)) (?v_112 (= ?v_14 e2)) (?v_183 (= ?v_14 e3)) (?v_272 (= ?v_14 e4)) (?v_373 (= ?v_14 e5)) (?v_7 (= ?v_15 e0)) (?v_43 (= ?v_15 e1)) (?v_115 (= ?v_15 e2)) (?v_186 (= ?v_15 e3)) (?v_275 (= ?v_15 e4)) (?v_376 (= ?v_15 e5)) (?v_8 (= ?v_10 e0)) (?v_46 (= ?v_10 e1)) (?v_118 (= ?v_10 e2)) (?v_189 (= ?v_10 e3)) (?v_278 (= ?v_10 e4)) (?v_379 (= ?v_10 e5)) (?v_33 (= ?v_49 e0)) (?v_50 (= ?v_49 e1)) (?v_121 (= ?v_49 e2)) (?v_192 (= ?v_49 e3)) (?v_281 (= ?v_49 e4)) (?v_382 (= ?v_49 e5)) (?v_36 (= ?v_52 e0)) (?v_53 (= ?v_52 e1)) (?v_124 (= ?v_52 e2)) (?v_195 (= ?v_52 e3)) (?v_284 (= ?v_52 e4)) (?v_385 (= ?v_52 e5)) (?v_39 (= ?v_54 e0)) (?v_55 (= ?v_54 e1)) (?v_127 (= ?v_54 e2)) (?v_198 (= ?v_54 e3)) (?v_287 (= ?v_54 e4)) (?v_388 (= ?v_54 e5)) (?v_42 (= ?v_56 e0)) (?v_57 (= ?v_56 e1)) (?v_130 (= ?v_56 e2)) (?v_201 (= ?v_56 e3)) (?v_290 (= ?v_56 e4)) (?v_391 (= ?v_56 e5)) (?v_45 (= ?v_58 e0)) (?v_59 (= ?v_58 e1)) (?v_133 (= ?v_58 e2)) (?v_204 (= ?v_58 e3)) (?v_293 (= ?v_58 e4)) (?v_394 (= ?v_58 e5)) (?v_16 (= ?v_18 e0)) (?v_60 (= ?v_18 e1)) (?v_136 (= ?v_18 e2)) (?v_207 (= ?v_18 e3)) (?v_296 (= ?v_18 e4)) (?v_397 (= ?v_18 e5)) (?v_61 (= ?v_63 e0)) (?v_64 (= ?v_63 e1)) (?v_139 (= ?v_63 e2)) (?v_210 (= ?v_63 e3)) (?v_299 (= ?v_63 e4)) (?v_400 (= ?v_63 e5)) (?v_108 (= ?v_66 e0)) (?v_126 (= ?v_66 e1)) (?v_142 (= ?v_66 e2)) (?v_213 (= ?v_66 e3)) (?v_302 (= ?v_66 e4)) (?v_403 (= ?v_66 e5)) (?v_111 (= ?v_67 e0)) (?v_129 (= ?v_67 e1)) (?v_144 (= ?v_67 e2)) (?v_216 (= ?v_67 e3)) (?v_305 (= ?v_67 e4)) (?v_406 (= ?v_67 e5)) (?v_114 (= ?v_68 e0)) (?v_132 (= ?v_68 e1)) (?v_145 (= ?v_68 e2)) (?v_219 (= ?v_68 e3)) (?v_308 (= ?v_68 e4)) (?v_409 (= ?v_68 e5)) (?v_117 (= ?v_69 e0)) (?v_135 (= ?v_69 e1)) (?v_146 (= ?v_69 e2)) (?v_222 (= ?v_69 e3)) (?v_311 (= ?v_69 e4)) (?v_412 (= ?v_69 e5)) (?v_19 (= ?v_21 e0)) (?v_70 (= ?v_21 e1)) (?v_147 (= ?v_21 e2)) (?v_225 (= ?v_21 e3)) (?v_314 (= ?v_21 e4)) (?v_415 (= ?v_21 e5)) (?v_71 (= ?v_73 e0)) (?v_74 (= ?v_73 e1)) (?v_150 (= ?v_73 e2)) (?v_228 (= ?v_73 e3)) (?v_317 (= ?v_73 e4)) (?v_418 (= ?v_73 e5)) (?v_148 (= ?v_76 e0)) (?v_151 (= ?v_76 e1)) (?v_153 (= ?v_76 e2)) (?v_231 (= ?v_76 e3)) (?v_320 (= ?v_76 e4)) (?v_421 (= ?v_76 e5)) (?v_182 (= ?v_77 e0)) (?v_200 (= ?v_77 e1)) (?v_218 (= ?v_77 e2)) (?v_234 (= ?v_77 e3)) (?v_323 (= ?v_77 e4)) (?v_424 (= ?v_77 e5)) (?v_185 (= ?v_78 e0)) (?v_203 (= ?v_78 e1)) (?v_221 (= ?v_78 e2)) (?v_236 (= ?v_78 e3)) (?v_326 (= ?v_78 e4)) (?v_427 (= ?v_78 e5)) (?v_188 (= ?v_79 e0)) (?v_206 (= ?v_79 e1)) (?v_224 (= ?v_79 e2)) (?v_237 (= ?v_79 e3)) (?v_329 (= ?v_79 e4)) (?v_430 (= ?v_79 e5)) (?v_22 (= ?v_24 e0)) (?v_80 (= ?v_24 e1)) (?v_155 (= ?v_24 e2)) (?v_238 (= ?v_24 e3)) (?v_332 (= ?v_24 e4)) (?v_433 (= ?v_24 e5)) (?v_81 (= ?v_83 e0)) (?v_84 (= ?v_83 e1)) (?v_158 (= ?v_83 e2)) (?v_241 (= ?v_83 e3)) (?v_335 (= ?v_83 e4)) (?v_436 (= ?v_83 e5)) (?v_156 (= ?v_86 e0)) (?v_159 (= ?v_86 e1)) (?v_161 (= ?v_86 e2)) (?v_244 (= ?v_86 e3)) (?v_338 (= ?v_86 e4)) (?v_439 (= ?v_86 e5)) (?v_239 (= ?v_87 e0)) (?v_242 (= ?v_87 e1)) (?v_245 (= ?v_87 e2)) (?v_247 (= ?v_87 e3)) (?v_341 (= ?v_87 e4)) (?v_442 (= ?v_87 e5)) (?v_274 (= ?v_88 e0)) (?v_292 (= ?v_88 e1)) (?v_310 (= ?v_88 e2)) (?v_328 (= ?v_88 e3)) (?v_344 (= ?v_88 e4)) (?v_445 (= ?v_88 e5)) (?v_277 (= ?v_89 e0)) (?v_295 (= ?v_89 e1)) (?v_313 (= ?v_89 e2)) (?v_331 (= ?v_89 e3)) (?v_346 (= ?v_89 e4)) (?v_448 (= ?v_89 e5)) (?v_25 (= ?v_27 e0)) (?v_90 (= ?v_27 e1)) (?v_163 (= ?v_27 e2)) (?v_249 (= ?v_27 e3)) (?v_347 (= ?v_27 e4)) (?v_451 (= ?v_27 e5)) (?v_91 (= ?v_93 e0)) (?v_94 (= ?v_93 e1)) (?v_166 (= ?v_93 e2)) (?v_252 (= ?v_93 e3)) (?v_350 (= ?v_93 e4)) (?v_454 (= ?v_93 e5)) (?v_164 (= ?v_96 e0)) (?v_167 (= ?v_96 e1)) (?v_169 (= ?v_96 e2)) (?v_255 (= ?v_96 e3)) (?v_353 (= ?v_96 e4)) (?v_457 (= ?v_96 e5)) (?v_250 (= ?v_97 e0)) (?v_253 (= ?v_97 e1)) (?v_256 (= ?v_97 e2)) (?v_258 (= ?v_97 e3)) (?v_356 (= ?v_97 e4)) (?v_460 (= ?v_97 e5)) (?v_348 (= ?v_98 e0)) (?v_351 (= ?v_98 e1)) (?v_354 (= ?v_98 e2)) (?v_357 (= ?v_98 e3)) (?v_359 (= ?v_98 e4)) (?v_463 (= ?v_98 e5)) (?v_378 (= ?v_99 e0)) (?v_396 (= ?v_99 e1)) (?v_414 (= ?v_99 e2)) (?v_432 (= ?v_99 e3)) (?v_450 (= ?v_99 e4)) (?v_466 (= ?v_99 e5))) (let ((?v_1 (not ?v_0)) (?v_30 (not ?v_8)) (?v_102 (not ?v_16)) (?v_173 (not ?v_19)) (?v_262 (not ?v_22)) (?v_363 (not ?v_25)) (?v_29 (not ?v_3)) (?v_47 (not ?v_33)) (?v_105 (not ?v_61)) (?v_176 (not ?v_71)) (?v_265 (not ?v_81)) (?v_366 (not ?v_91)) (?v_101 (not ?v_4)) (?v_119 (not ?v_36)) (?v_137 (not ?v_108)) (?v_179 (not ?v_148)) (?v_268 (not ?v_156)) (?v_369 (not ?v_164)) (?v_172 (not ?v_5)) (?v_190 (not ?v_39)) (?v_208 (not ?v_111)) (?v_226 (not ?v_182)) (?v_271 (not ?v_239)) (?v_372 (not ?v_250)) (?v_261 (not ?v_6)) (?v_279 (not ?v_42)) (?v_297 (not ?v_114)) (?v_315 (not ?v_185)) (?v_333 (not ?v_274)) (?v_375 (not ?v_348)) (?v_362 (not ?v_7)) (?v_380 (not ?v_45)) (?v_398 (not ?v_117)) (?v_416 (not ?v_188)) (?v_434 (not ?v_277)) (?v_452 (not ?v_378)) (?v_9 (not ?v_28)) (?v_48 (not ?v_46)) (?v_120 (not ?v_60)) (?v_191 (not ?v_70)) (?v_280 (not ?v_80)) (?v_381 (not ?v_90)) (?v_32 (not ?v_31)) (?v_51 (not ?v_50)) (?v_123 (not ?v_64)) (?v_194 (not ?v_74)) (?v_283 (not ?v_84)) (?v_384 (not ?v_94)) (?v_104 (not ?v_34)) (?v_122 (not ?v_53)) (?v_140 (not ?v_126)) (?v_197 (not ?v_151)) (?v_286 (not ?v_159)) (?v_387 (not ?v_167)) (?v_175 (not ?v_37)) (?v_193 (not ?v_55)) (?v_211 (not ?v_129)) (?v_229 (not ?v_200)) (?v_289 (not ?v_242)) (?v_390 (not ?v_253)) (?v_264 (not ?v_40)) (?v_282 (not ?v_57)) (?v_300 (not ?v_132)) (?v_318 (not ?v_203)) (?v_336 (not ?v_292)) (?v_393 (not ?v_351)) (?v_365 (not ?v_43)) (?v_383 (not ?v_59)) (?v_401 (not ?v_135)) (?v_419 (not ?v_206)) (?v_437 (not ?v_295)) (?v_455 (not ?v_396)) (?v_17 (not ?v_100)) (?v_62 (not ?v_118)) (?v_138 (not ?v_136)) (?v_209 (not ?v_147)) (?v_298 (not ?v_155)) (?v_399 (not ?v_163)) (?v_35 (not ?v_103)) (?v_65 (not ?v_121)) (?v_141 (not ?v_139)) (?v_212 (not ?v_150)) (?v_301 (not ?v_158)) (?v_402 (not ?v_166)) (?v_107 (not ?v_106)) (?v_125 (not ?v_124)) (?v_143 (not ?v_142)) (?v_215 (not ?v_153)) (?v_304 (not ?v_161)) (?v_405 (not ?v_169)) (?v_178 (not ?v_109)) (?v_196 (not ?v_127)) (?v_214 (not ?v_144)) (?v_232 (not ?v_218)) (?v_307 (not ?v_245)) (?v_408 (not ?v_256)) (?v_267 (not ?v_112)) (?v_285 (not ?v_130)) (?v_303 (not ?v_145)) (?v_321 (not ?v_221)) (?v_339 (not ?v_310)) (?v_411 (not ?v_354)) (?v_368 (not ?v_115)) (?v_386 (not ?v_133)) (?v_404 (not ?v_146)) (?v_422 (not ?v_224)) (?v_440 (not ?v_313)) (?v_458 (not ?v_414)) (?v_20 (not ?v_171)) (?v_72 (not ?v_189)) (?v_149 (not ?v_207)) (?v_227 (not ?v_225)) (?v_316 (not ?v_238)) (?v_417 (not ?v_249)) (?v_38 (not ?v_174)) (?v_75 (not ?v_192)) (?v_152 (not ?v_210)) (?v_230 (not ?v_228)) (?v_319 (not ?v_241)) (?v_420 (not ?v_252)) (?v_110 (not ?v_177)) (?v_128 (not ?v_195)) (?v_154 (not ?v_213)) (?v_233 (not ?v_231)) (?v_322 (not ?v_244)) (?v_423 (not ?v_255)) (?v_181 (not ?v_180)) (?v_199 (not ?v_198)) (?v_217 (not ?v_216)) (?v_235 (not ?v_234)) (?v_325 (not ?v_247)) (?v_426 (not ?v_258)) (?v_270 (not ?v_183)) (?v_288 (not ?v_201)) (?v_306 (not ?v_219)) (?v_324 (not ?v_236)) (?v_342 (not ?v_328)) (?v_429 (not ?v_357)) (?v_371 (not ?v_186)) (?v_389 (not ?v_204)) (?v_407 (not ?v_222)) (?v_425 (not ?v_237)) (?v_443 (not ?v_331)) (?v_461 (not ?v_432)) (?v_23 (not ?v_260)) (?v_82 (not ?v_278)) (?v_157 (not ?v_296)) (?v_240 (not ?v_314)) (?v_334 (not ?v_332)) (?v_435 (not ?v_347)) (?v_41 (not ?v_263)) (?v_85 (not ?v_281)) (?v_160 (not ?v_299)) (?v_243 (not ?v_317)) (?v_337 (not ?v_335)) (?v_438 (not ?v_350)) (?v_113 (not ?v_266)) (?v_131 (not ?v_284)) (?v_162 (not ?v_302)) (?v_246 (not ?v_320)) (?v_340 (not ?v_338)) (?v_441 (not ?v_353)) (?v_184 (not ?v_269)) (?v_202 (not ?v_287)) (?v_220 (not ?v_305)) (?v_248 (not ?v_323)) (?v_343 (not ?v_341)) (?v_444 (not ?v_356)) (?v_273 (not ?v_272)) (?v_291 (not ?v_290)) (?v_309 (not ?v_308)) (?v_327 (not ?v_326)) (?v_345 (not ?v_344)) (?v_447 (not ?v_359)) (?v_374 (not ?v_275)) (?v_392 (not ?v_293)) (?v_410 (not ?v_311)) (?v_428 (not ?v_329)) (?v_446 (not ?v_346)) (?v_464 (not ?v_450)) (?v_26 (not ?v_361)) (?v_92 (not ?v_379)) (?v_165 (not ?v_397)) (?v_251 (not ?v_415)) (?v_349 (not ?v_433)) (?v_453 (not ?v_451)) (?v_44 (not ?v_364)) (?v_95 (not ?v_382)) (?v_168 (not ?v_400)) (?v_254 (not ?v_418)) (?v_352 (not ?v_436)) (?v_456 (not ?v_454)) (?v_116 (not ?v_367)) (?v_134 (not ?v_385)) (?v_170 (not ?v_403)) (?v_257 (not ?v_421)) (?v_355 (not ?v_439)) (?v_459 (not ?v_457)) (?v_187 (not ?v_370)) (?v_205 (not ?v_388)) (?v_223 (not ?v_406)) (?v_259 (not ?v_424)) (?v_358 (not ?v_442)) (?v_462 (not ?v_460)) (?v_276 (not ?v_373)) (?v_294 (not ?v_391)) (?v_312 (not ?v_409)) (?v_330 (not ?v_427)) (?v_360 (not ?v_445)) (?v_465 (not ?v_463)) (?v_377 (not ?v_376)) (?v_395 (not ?v_394)) (?v_413 (not ?v_412)) (?v_431 (not ?v_430)) (?v_449 (not ?v_448)) (?v_467 (not ?v_466))) (and (and (and (and (and (or (or (or (or (or (or (or (or (or (or (and ?v_0 (and ?v_1 ?v_1)) (and ?v_3 (and ?v_9 ?v_29))) (and ?v_4 (and ?v_17 ?v_101))) (and ?v_5 (and ?v_20 ?v_172))) (and ?v_6 (and ?v_23 ?v_261))) (and ?v_7 (and ?v_26 ?v_362))) (or (or (or (or (or (and ?v_8 (and ?v_30 ?v_9)) (and ?v_33 (and ?v_48 ?v_32))) (and ?v_36 (and ?v_62 ?v_104))) (and ?v_39 (and ?v_72 ?v_175))) (and ?v_42 (and ?v_82 ?v_264))) (and ?v_45 (and ?v_92 ?v_365)))) (or (or (or (or (or (and ?v_16 (and ?v_102 ?v_17)) (and ?v_61 (and ?v_120 ?v_35))) (and ?v_108 (and ?v_138 ?v_107))) (and ?v_111 (and ?v_149 ?v_178))) (and ?v_114 (and ?v_157 ?v_267))) (and ?v_117 (and ?v_165 ?v_368)))) (or (or (or (or (or (and ?v_19 (and ?v_173 ?v_20)) (and ?v_71 (and ?v_191 ?v_38))) (and ?v_148 (and ?v_209 ?v_110))) (and ?v_182 (and ?v_227 ?v_181))) (and ?v_185 (and ?v_240 ?v_270))) (and ?v_188 (and ?v_251 ?v_371)))) (or (or (or (or (or (and ?v_22 (and ?v_262 ?v_23)) (and ?v_81 (and ?v_280 ?v_41))) (and ?v_156 (and ?v_298 ?v_113))) (and ?v_239 (and ?v_316 ?v_184))) (and ?v_274 (and ?v_334 ?v_273))) (and ?v_277 (and ?v_349 ?v_374)))) (or (or (or (or (or (and ?v_25 (and ?v_363 ?v_26)) (and ?v_91 (and ?v_381 ?v_44))) (and ?v_164 (and ?v_399 ?v_116))) (and ?v_250 (and ?v_417 ?v_187))) (and ?v_348 (and ?v_435 ?v_276))) (and ?v_378 (and ?v_453 ?v_377)))) (or (or (or (or (or (or (or (or (or (or (and ?v_28 (and ?v_29 ?v_30)) (and ?v_31 (and ?v_32 ?v_47))) (and ?v_34 (and ?v_35 ?v_119))) (and ?v_37 (and ?v_38 ?v_190))) (and ?v_40 (and ?v_41 ?v_279))) (and ?v_43 (and ?v_44 ?v_380))) (or (or (or (or (or (and ?v_46 (and ?v_47 ?v_48)) (and ?v_50 (and ?v_51 ?v_51))) (and ?v_53 (and ?v_65 ?v_122))) (and ?v_55 (and ?v_75 ?v_193))) (and ?v_57 (and ?v_85 ?v_282))) (and ?v_59 (and ?v_95 ?v_383)))) (or (or (or (or (or (and ?v_60 (and ?v_105 ?v_62)) (and ?v_64 (and ?v_123 ?v_65))) (and ?v_126 (and ?v_141 ?v_125))) (and ?v_129 (and ?v_152 ?v_196))) (and ?v_132 (and ?v_160 ?v_285))) (and ?v_135 (and ?v_168 ?v_386)))) (or (or (or (or (or (and ?v_70 (and ?v_176 ?v_72)) (and ?v_74 (and ?v_194 ?v_75))) (and ?v_151 (and ?v_212 ?v_128))) (and ?v_200 (and ?v_230 ?v_199))) (and ?v_203 (and ?v_243 ?v_288))) (and ?v_206 (and ?v_254 ?v_389)))) (or (or (or (or (or (and ?v_80 (and ?v_265 ?v_82)) (and ?v_84 (and ?v_283 ?v_85))) (and ?v_159 (and ?v_301 ?v_131))) (and ?v_242 (and ?v_319 ?v_202))) (and ?v_292 (and ?v_337 ?v_291))) (and ?v_295 (and ?v_352 ?v_392)))) (or (or (or (or (or (and ?v_90 (and ?v_366 ?v_92)) (and ?v_94 (and ?v_384 ?v_95))) (and ?v_167 (and ?v_402 ?v_134))) (and ?v_253 (and ?v_420 ?v_205))) (and ?v_351 (and ?v_438 ?v_294))) (and ?v_396 (and ?v_456 ?v_395))))) (or (or (or (or (or (or (or (or (or (or (and ?v_100 (and ?v_101 ?v_102)) (and ?v_103 (and ?v_104 ?v_105))) (and ?v_106 (and ?v_107 ?v_137))) (and ?v_109 (and ?v_110 ?v_208))) (and ?v_112 (and ?v_113 ?v_297))) (and ?v_115 (and ?v_116 ?v_398))) (or (or (or (or (or (and ?v_118 (and ?v_119 ?v_120)) (and ?v_121 (and ?v_122 ?v_123))) (and ?v_124 (and ?v_125 ?v_140))) (and ?v_127 (and ?v_128 ?v_211))) (and ?v_130 (and ?v_131 ?v_300))) (and ?v_133 (and ?v_134 ?v_401)))) (or (or (or (or (or (and ?v_136 (and ?v_137 ?v_138)) (and ?v_139 (and ?v_140 ?v_141))) (and ?v_142 (and ?v_143 ?v_143))) (and ?v_144 (and ?v_154 ?v_214))) (and ?v_145 (and ?v_162 ?v_303))) (and ?v_146 (and ?v_170 ?v_404)))) (or (or (or (or (or (and ?v_147 (and ?v_179 ?v_149)) (and ?v_150 (and ?v_197 ?v_152))) (and ?v_153 (and ?v_215 ?v_154))) (and ?v_218 (and ?v_233 ?v_217))) (and ?v_221 (and ?v_246 ?v_306))) (and ?v_224 (and ?v_257 ?v_407)))) (or (or (or (or (or (and ?v_155 (and ?v_268 ?v_157)) (and ?v_158 (and ?v_286 ?v_160))) (and ?v_161 (and ?v_304 ?v_162))) (and ?v_245 (and ?v_322 ?v_220))) (and ?v_310 (and ?v_340 ?v_309))) (and ?v_313 (and ?v_355 ?v_410)))) (or (or (or (or (or (and ?v_163 (and ?v_369 ?v_165)) (and ?v_166 (and ?v_387 ?v_168))) (and ?v_169 (and ?v_405 ?v_170))) (and ?v_256 (and ?v_423 ?v_223))) (and ?v_354 (and ?v_441 ?v_312))) (and ?v_414 (and ?v_459 ?v_413))))) (or (or (or (or (or (or (or (or (or (or (and ?v_171 (and ?v_172 ?v_173)) (and ?v_174 (and ?v_175 ?v_176))) (and ?v_177 (and ?v_178 ?v_179))) (and ?v_180 (and ?v_181 ?v_226))) (and ?v_183 (and ?v_184 ?v_315))) (and ?v_186 (and ?v_187 ?v_416))) (or (or (or (or (or (and ?v_189 (and ?v_190 ?v_191)) (and ?v_192 (and ?v_193 ?v_194))) (and ?v_195 (and ?v_196 ?v_197))) (and ?v_198 (and ?v_199 ?v_229))) (and ?v_201 (and ?v_202 ?v_318))) (and ?v_204 (and ?v_205 ?v_419)))) (or (or (or (or (or (and ?v_207 (and ?v_208 ?v_209)) (and ?v_210 (and ?v_211 ?v_212))) (and ?v_213 (and ?v_214 ?v_215))) (and ?v_216 (and ?v_217 ?v_232))) (and ?v_219 (and ?v_220 ?v_321))) (and ?v_222 (and ?v_223 ?v_422)))) (or (or (or (or (or (and ?v_225 (and ?v_226 ?v_227)) (and ?v_228 (and ?v_229 ?v_230))) (and ?v_231 (and ?v_232 ?v_233))) (and ?v_234 (and ?v_235 ?v_235))) (and ?v_236 (and ?v_248 ?v_324))) (and ?v_237 (and ?v_259 ?v_425)))) (or (or (or (or (or (and ?v_238 (and ?v_271 ?v_240)) (and ?v_241 (and ?v_289 ?v_243))) (and ?v_244 (and ?v_307 ?v_246))) (and ?v_247 (and ?v_325 ?v_248))) (and ?v_328 (and ?v_343 ?v_327))) (and ?v_331 (and ?v_358 ?v_428)))) (or (or (or (or (or (and ?v_249 (and ?v_372 ?v_251)) (and ?v_252 (and ?v_390 ?v_254))) (and ?v_255 (and ?v_408 ?v_257))) (and ?v_258 (and ?v_426 ?v_259))) (and ?v_357 (and ?v_444 ?v_330))) (and ?v_432 (and ?v_462 ?v_431))))) (or (or (or (or (or (or (or (or (or (or (and ?v_260 (and ?v_261 ?v_262)) (and ?v_263 (and ?v_264 ?v_265))) (and ?v_266 (and ?v_267 ?v_268))) (and ?v_269 (and ?v_270 ?v_271))) (and ?v_272 (and ?v_273 ?v_333))) (and ?v_275 (and ?v_276 ?v_434))) (or (or (or (or (or (and ?v_278 (and ?v_279 ?v_280)) (and ?v_281 (and ?v_282 ?v_283))) (and ?v_284 (and ?v_285 ?v_286))) (and ?v_287 (and ?v_288 ?v_289))) (and ?v_290 (and ?v_291 ?v_336))) (and ?v_293 (and ?v_294 ?v_437)))) (or (or (or (or (or (and ?v_296 (and ?v_297 ?v_298)) (and ?v_299 (and ?v_300 ?v_301))) (and ?v_302 (and ?v_303 ?v_304))) (and ?v_305 (and ?v_306 ?v_307))) (and ?v_308 (and ?v_309 ?v_339))) (and ?v_311 (and ?v_312 ?v_440)))) (or (or (or (or (or (and ?v_314 (and ?v_315 ?v_316)) (and ?v_317 (and ?v_318 ?v_319))) (and ?v_320 (and ?v_321 ?v_322))) (and ?v_323 (and ?v_324 ?v_325))) (and ?v_326 (and ?v_327 ?v_342))) (and ?v_329 (and ?v_330 ?v_443)))) (or (or (or (or (or (and ?v_332 (and ?v_333 ?v_334)) (and ?v_335 (and ?v_336 ?v_337))) (and ?v_338 (and ?v_339 ?v_340))) (and ?v_341 (and ?v_342 ?v_343))) (and ?v_344 (and ?v_345 ?v_345))) (and ?v_346 (and ?v_360 ?v_446)))) (or (or (or (or (or (and ?v_347 (and ?v_375 ?v_349)) (and ?v_350 (and ?v_393 ?v_352))) (and ?v_353 (and ?v_411 ?v_355))) (and ?v_356 (and ?v_429 ?v_358))) (and ?v_359 (and ?v_447 ?v_360))) (and ?v_450 (and ?v_465 ?v_449))))) (or (or (or (or (or (or (or (or (or (or (and ?v_361 (and ?v_362 ?v_363)) (and ?v_364 (and ?v_365 ?v_366))) (and ?v_367 (and ?v_368 ?v_369))) (and ?v_370 (and ?v_371 ?v_372))) (and ?v_373 (and ?v_374 ?v_375))) (and ?v_376 (and ?v_377 ?v_452))) (or (or (or (or (or (and ?v_379 (and ?v_380 ?v_381)) (and ?v_382 (and ?v_383 ?v_384))) (and ?v_385 (and ?v_386 ?v_387))) (and ?v_388 (and ?v_389 ?v_390))) (and ?v_391 (and ?v_392 ?v_393))) (and ?v_394 (and ?v_395 ?v_455)))) (or (or (or (or (or (and ?v_397 (and ?v_398 ?v_399)) (and ?v_400 (and ?v_401 ?v_402))) (and ?v_403 (and ?v_404 ?v_405))) (and ?v_406 (and ?v_407 ?v_408))) (and ?v_409 (and ?v_410 ?v_411))) (and ?v_412 (and ?v_413 ?v_458)))) (or (or (or (or (or (and ?v_415 (and ?v_416 ?v_417)) (and ?v_418 (and ?v_419 ?v_420))) (and ?v_421 (and ?v_422 ?v_423))) (and ?v_424 (and ?v_425 ?v_426))) (and ?v_427 (and ?v_428 ?v_429))) (and ?v_430 (and ?v_431 ?v_461)))) (or (or (or (or (or (and ?v_433 (and ?v_434 ?v_435)) (and ?v_436 (and ?v_437 ?v_438))) (and ?v_439 (and ?v_440 ?v_441))) (and ?v_442 (and ?v_443 ?v_444))) (and ?v_445 (and ?v_446 ?v_447))) (and ?v_448 (and ?v_449 ?v_464)))) (or (or (or (or (or (and ?v_451 (and ?v_452 ?v_453)) (and ?v_454 (and ?v_455 ?v_456))) (and ?v_457 (and ?v_458 ?v_459))) (and ?v_460 (and ?v_461 ?v_462))) (and ?v_463 (and ?v_464 ?v_465))) (and ?v_466 (and ?v_467 ?v_467))))))))) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e1 e1)) (?v_2 (op e2 e2)) (?v_3 (op e3 e3)) (?v_4 (op e4 e4)) (?v_5 (op e5 e5))) (and (and (and (and (and (or (not (= (op e0 ?v_0) e0)) (or (or (or (or (or (= ?v_0 e0) (= ?v_1 e0)) (= ?v_2 e0)) (= ?v_3 e0)) (= ?v_4 e0)) (= ?v_5 e0))) (or (not (= (op e1 ?v_1) e1)) (or (or (or (or (or (= ?v_0 e1) (= ?v_1 e1)) (= ?v_2 e1)) (= ?v_3 e1)) (= ?v_4 e1)) (= ?v_5 e1)))) (or (not (= (op e2 ?v_2) e2)) (or (or (or (or (or (= ?v_0 e2) (= ?v_1 e2)) (= ?v_2 e2)) (= ?v_3 e2)) (= ?v_4 e2)) (= ?v_5 e2)))) (or (not (= (op e3 ?v_3) e3)) (or (or (or (or (or (= ?v_0 e3) (= ?v_1 e3)) (= ?v_2 e3)) (= ?v_3 e3)) (= ?v_4 e3)) (= ?v_5 e3)))) (or (not (= (op e4 ?v_4) e4)) (or (or (or (or (or (= ?v_0 e4) (= ?v_1 e4)) (= ?v_2 e4)) (= ?v_3 e4)) (= ?v_4 e4)) (= ?v_5 e4)))) (or (not (= (op e5 ?v_5) e5)) (or (or (or (or (or (= ?v_0 e5) (= ?v_1 e5)) (= ?v_2 e5)) (= ?v_3 e5)) (= ?v_4 e5)) (= ?v_5 e5)))))) +(assert (let ((?v_0 (op e0 e0)) (?v_11 (op e0 e1)) (?v_16 (op e0 e2)) (?v_21 (op e0 e3)) (?v_26 (op e0 e4)) (?v_31 (op e0 e5)) (?v_1 (op e1 e0)) (?v_2 (op e1 e1)) (?v_17 (op e1 e2)) (?v_22 (op e1 e3)) (?v_27 (op e1 e4)) (?v_32 (op e1 e5)) (?v_7 (op e2 e0)) (?v_12 (op e2 e1)) (?v_3 (op e2 e2)) (?v_23 (op e2 e3)) (?v_28 (op e2 e4)) (?v_33 (op e2 e5)) (?v_8 (op e3 e0)) (?v_13 (op e3 e1)) (?v_18 (op e3 e2)) (?v_4 (op e3 e3)) (?v_29 (op e3 e4)) (?v_34 (op e3 e5)) (?v_9 (op e4 e0)) (?v_14 (op e4 e1)) (?v_19 (op e4 e2)) (?v_24 (op e4 e3)) (?v_5 (op e4 e4)) (?v_35 (op e4 e5)) (?v_10 (op e5 e0)) (?v_15 (op e5 e1)) (?v_20 (op e5 e2)) (?v_25 (op e5 e3)) (?v_30 (op e5 e4)) (?v_6 (op e5 e5))) (or (or (or (or (or (and (and (and (and (and (or (= (op e0 ?v_0) e0) (or (or (or (or (or (= ?v_0 ?v_0) (= ?v_2 ?v_0)) (= ?v_3 ?v_0)) (= ?v_4 ?v_0)) (= ?v_5 ?v_0)) (= ?v_6 ?v_0))) (or (= (op e1 ?v_1) e0) (or (or (or (or (or (= ?v_0 ?v_1) (= ?v_2 ?v_1)) (= ?v_3 ?v_1)) (= ?v_4 ?v_1)) (= ?v_5 ?v_1)) (= ?v_6 ?v_1)))) (or (= (op e2 ?v_7) e0) (or (or (or (or (or (= ?v_0 ?v_7) (= ?v_2 ?v_7)) (= ?v_3 ?v_7)) (= ?v_4 ?v_7)) (= ?v_5 ?v_7)) (= ?v_6 ?v_7)))) (or (= (op e3 ?v_8) e0) (or (or (or (or (or (= ?v_0 ?v_8) (= ?v_2 ?v_8)) (= ?v_3 ?v_8)) (= ?v_4 ?v_8)) (= ?v_5 ?v_8)) (= ?v_6 ?v_8)))) (or (= (op e4 ?v_9) e0) (or (or (or (or (or (= ?v_0 ?v_9) (= ?v_2 ?v_9)) (= ?v_3 ?v_9)) (= ?v_4 ?v_9)) (= ?v_5 ?v_9)) (= ?v_6 ?v_9)))) (or (= (op e5 ?v_10) e0) (or (or (or (or (or (= ?v_0 ?v_10) (= ?v_2 ?v_10)) (= ?v_3 ?v_10)) (= ?v_4 ?v_10)) (= ?v_5 ?v_10)) (= ?v_6 ?v_10)))) (and (and (and (and (and (or (= (op e0 ?v_11) e1) (or (or (or (or (or (= ?v_0 ?v_11) (= ?v_2 ?v_11)) (= ?v_3 ?v_11)) (= ?v_4 ?v_11)) (= ?v_5 ?v_11)) (= ?v_6 ?v_11))) (or (= (op e1 ?v_2) e1) (or (or (or (or (or (= ?v_0 ?v_2) (= ?v_2 ?v_2)) (= ?v_3 ?v_2)) (= ?v_4 ?v_2)) (= ?v_5 ?v_2)) (= ?v_6 ?v_2)))) (or (= (op e2 ?v_12) e1) (or (or (or (or (or (= ?v_0 ?v_12) (= ?v_2 ?v_12)) (= ?v_3 ?v_12)) (= ?v_4 ?v_12)) (= ?v_5 ?v_12)) (= ?v_6 ?v_12)))) (or (= (op e3 ?v_13) e1) (or (or (or (or (or (= ?v_0 ?v_13) (= ?v_2 ?v_13)) (= ?v_3 ?v_13)) (= ?v_4 ?v_13)) (= ?v_5 ?v_13)) (= ?v_6 ?v_13)))) (or (= (op e4 ?v_14) e1) (or (or (or (or (or (= ?v_0 ?v_14) (= ?v_2 ?v_14)) (= ?v_3 ?v_14)) (= ?v_4 ?v_14)) (= ?v_5 ?v_14)) (= ?v_6 ?v_14)))) (or (= (op e5 ?v_15) e1) (or (or (or (or (or (= ?v_0 ?v_15) (= ?v_2 ?v_15)) (= ?v_3 ?v_15)) (= ?v_4 ?v_15)) (= ?v_5 ?v_15)) (= ?v_6 ?v_15))))) (and (and (and (and (and (or (= (op e0 ?v_16) e2) (or (or (or (or (or (= ?v_0 ?v_16) (= ?v_2 ?v_16)) (= ?v_3 ?v_16)) (= ?v_4 ?v_16)) (= ?v_5 ?v_16)) (= ?v_6 ?v_16))) (or (= (op e1 ?v_17) e2) (or (or (or (or (or (= ?v_0 ?v_17) (= ?v_2 ?v_17)) (= ?v_3 ?v_17)) (= ?v_4 ?v_17)) (= ?v_5 ?v_17)) (= ?v_6 ?v_17)))) (or (= (op e2 ?v_3) e2) (or (or (or (or (or (= ?v_0 ?v_3) (= ?v_2 ?v_3)) (= ?v_3 ?v_3)) (= ?v_4 ?v_3)) (= ?v_5 ?v_3)) (= ?v_6 ?v_3)))) (or (= (op e3 ?v_18) e2) (or (or (or (or (or (= ?v_0 ?v_18) (= ?v_2 ?v_18)) (= ?v_3 ?v_18)) (= ?v_4 ?v_18)) (= ?v_5 ?v_18)) (= ?v_6 ?v_18)))) (or (= (op e4 ?v_19) e2) (or (or (or (or (or (= ?v_0 ?v_19) (= ?v_2 ?v_19)) (= ?v_3 ?v_19)) (= ?v_4 ?v_19)) (= ?v_5 ?v_19)) (= ?v_6 ?v_19)))) (or (= (op e5 ?v_20) e2) (or (or (or (or (or (= ?v_0 ?v_20) (= ?v_2 ?v_20)) (= ?v_3 ?v_20)) (= ?v_4 ?v_20)) (= ?v_5 ?v_20)) (= ?v_6 ?v_20))))) (and (and (and (and (and (or (= (op e0 ?v_21) e3) (or (or (or (or (or (= ?v_0 ?v_21) (= ?v_2 ?v_21)) (= ?v_3 ?v_21)) (= ?v_4 ?v_21)) (= ?v_5 ?v_21)) (= ?v_6 ?v_21))) (or (= (op e1 ?v_22) e3) (or (or (or (or (or (= ?v_0 ?v_22) (= ?v_2 ?v_22)) (= ?v_3 ?v_22)) (= ?v_4 ?v_22)) (= ?v_5 ?v_22)) (= ?v_6 ?v_22)))) (or (= (op e2 ?v_23) e3) (or (or (or (or (or (= ?v_0 ?v_23) (= ?v_2 ?v_23)) (= ?v_3 ?v_23)) (= ?v_4 ?v_23)) (= ?v_5 ?v_23)) (= ?v_6 ?v_23)))) (or (= (op e3 ?v_4) e3) (or (or (or (or (or (= ?v_0 ?v_4) (= ?v_2 ?v_4)) (= ?v_3 ?v_4)) (= ?v_4 ?v_4)) (= ?v_5 ?v_4)) (= ?v_6 ?v_4)))) (or (= (op e4 ?v_24) e3) (or (or (or (or (or (= ?v_0 ?v_24) (= ?v_2 ?v_24)) (= ?v_3 ?v_24)) (= ?v_4 ?v_24)) (= ?v_5 ?v_24)) (= ?v_6 ?v_24)))) (or (= (op e5 ?v_25) e3) (or (or (or (or (or (= ?v_0 ?v_25) (= ?v_2 ?v_25)) (= ?v_3 ?v_25)) (= ?v_4 ?v_25)) (= ?v_5 ?v_25)) (= ?v_6 ?v_25))))) (and (and (and (and (and (or (= (op e0 ?v_26) e4) (or (or (or (or (or (= ?v_0 ?v_26) (= ?v_2 ?v_26)) (= ?v_3 ?v_26)) (= ?v_4 ?v_26)) (= ?v_5 ?v_26)) (= ?v_6 ?v_26))) (or (= (op e1 ?v_27) e4) (or (or (or (or (or (= ?v_0 ?v_27) (= ?v_2 ?v_27)) (= ?v_3 ?v_27)) (= ?v_4 ?v_27)) (= ?v_5 ?v_27)) (= ?v_6 ?v_27)))) (or (= (op e2 ?v_28) e4) (or (or (or (or (or (= ?v_0 ?v_28) (= ?v_2 ?v_28)) (= ?v_3 ?v_28)) (= ?v_4 ?v_28)) (= ?v_5 ?v_28)) (= ?v_6 ?v_28)))) (or (= (op e3 ?v_29) e4) (or (or (or (or (or (= ?v_0 ?v_29) (= ?v_2 ?v_29)) (= ?v_3 ?v_29)) (= ?v_4 ?v_29)) (= ?v_5 ?v_29)) (= ?v_6 ?v_29)))) (or (= (op e4 ?v_5) e4) (or (or (or (or (or (= ?v_0 ?v_5) (= ?v_2 ?v_5)) (= ?v_3 ?v_5)) (= ?v_4 ?v_5)) (= ?v_5 ?v_5)) (= ?v_6 ?v_5)))) (or (= (op e5 ?v_30) e4) (or (or (or (or (or (= ?v_0 ?v_30) (= ?v_2 ?v_30)) (= ?v_3 ?v_30)) (= ?v_4 ?v_30)) (= ?v_5 ?v_30)) (= ?v_6 ?v_30))))) (and (and (and (and (and (or (= (op e0 ?v_31) e5) (or (or (or (or (or (= ?v_0 ?v_31) (= ?v_2 ?v_31)) (= ?v_3 ?v_31)) (= ?v_4 ?v_31)) (= ?v_5 ?v_31)) (= ?v_6 ?v_31))) (or (= (op e1 ?v_32) e5) (or (or (or (or (or (= ?v_0 ?v_32) (= ?v_2 ?v_32)) (= ?v_3 ?v_32)) (= ?v_4 ?v_32)) (= ?v_5 ?v_32)) (= ?v_6 ?v_32)))) (or (= (op e2 ?v_33) e5) (or (or (or (or (or (= ?v_0 ?v_33) (= ?v_2 ?v_33)) (= ?v_3 ?v_33)) (= ?v_4 ?v_33)) (= ?v_5 ?v_33)) (= ?v_6 ?v_33)))) (or (= (op e3 ?v_34) e5) (or (or (or (or (or (= ?v_0 ?v_34) (= ?v_2 ?v_34)) (= ?v_3 ?v_34)) (= ?v_4 ?v_34)) (= ?v_5 ?v_34)) (= ?v_6 ?v_34)))) (or (= (op e4 ?v_35) e5) (or (or (or (or (or (= ?v_0 ?v_35) (= ?v_2 ?v_35)) (= ?v_3 ?v_35)) (= ?v_4 ?v_35)) (= ?v_5 ?v_35)) (= ?v_6 ?v_35)))) (or (= (op e5 ?v_6) e5) (or (or (or (or (or (= ?v_0 ?v_6) (= ?v_2 ?v_6)) (= ?v_3 ?v_6)) (= ?v_4 ?v_6)) (= ?v_5 ?v_6)) (= ?v_6 ?v_6))))))) +(assert (let ((?v_0 (op e0 e0)) (?v_1 (op e1 e1)) (?v_2 (op e2 e2)) (?v_3 (op e3 e3)) (?v_4 (op e4 e4)) (?v_5 (op e5 e5))) (and (and (and (and (and (or (= (op e0 ?v_0) e0) (not (= (op ?v_0 ?v_0) e0))) (or (= (op e1 ?v_1) e1) (not (= (op ?v_1 ?v_1) e1)))) (or (= (op e2 ?v_2) e2) (not (= (op ?v_2 ?v_2) e2)))) (or (= (op e3 ?v_3) e3) (not (= (op ?v_3 ?v_3) e3)))) (or (= (op e4 ?v_4) e4) (not (= (op ?v_4 ?v_4) e4)))) (or (= (op e5 ?v_5) e5) (not (= (op ?v_5 ?v_5) e5)))))) +(assert (= unit e0)) +(assert (let ((?v_0 (op e0 e0)) (?v_6 (op e0 e1)) (?v_12 (op e0 e2)) (?v_18 (op e0 e3)) (?v_24 (op e0 e4)) (?v_30 (op e0 e5)) (?v_1 (op e1 e0)) (?v_7 (op e1 e1)) (?v_13 (op e1 e2)) (?v_19 (op e1 e3)) (?v_25 (op e1 e4)) (?v_31 (op e1 e5)) (?v_2 (op e2 e0)) (?v_8 (op e2 e1)) (?v_14 (op e2 e2)) (?v_20 (op e2 e3)) (?v_26 (op e2 e4)) (?v_32 (op e2 e5)) (?v_3 (op e3 e0)) (?v_9 (op e3 e1)) (?v_15 (op e3 e2)) (?v_21 (op e3 e3)) (?v_27 (op e3 e4)) (?v_33 (op e3 e5)) (?v_4 (op e4 e0)) (?v_10 (op e4 e1)) (?v_16 (op e4 e2)) (?v_22 (op e4 e3)) (?v_28 (op e4 e4)) (?v_34 (op e4 e5)) (?v_5 (op e5 e0)) (?v_11 (op e5 e1)) (?v_17 (op e5 e2)) (?v_23 (op e5 e3)) (?v_29 (op e5 e4)) (?v_35 (op e5 e5))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_0 ?v_1)) (not (= ?v_0 ?v_2))) (not (= ?v_0 ?v_3))) (not (= ?v_0 ?v_4))) (not (= ?v_0 ?v_5))) (not (= ?v_1 ?v_2))) (not (= ?v_1 ?v_3))) (not (= ?v_1 ?v_4))) (not (= ?v_1 ?v_5))) (not (= ?v_2 ?v_3))) (not (= ?v_2 ?v_4))) (not (= ?v_2 ?v_5))) (not (= ?v_3 ?v_4))) (not (= ?v_3 ?v_5))) (not (= ?v_4 ?v_5))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_6 ?v_7)) (not (= ?v_6 ?v_8))) (not (= ?v_6 ?v_9))) (not (= ?v_6 ?v_10))) (not (= ?v_6 ?v_11))) (not (= ?v_7 ?v_8))) (not (= ?v_7 ?v_9))) (not (= ?v_7 ?v_10))) (not (= ?v_7 ?v_11))) (not (= ?v_8 ?v_9))) (not (= ?v_8 ?v_10))) (not (= ?v_8 ?v_11))) (not (= ?v_9 ?v_10))) (not (= ?v_9 ?v_11))) (not (= ?v_10 ?v_11)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_12 ?v_13)) (not (= ?v_12 ?v_14))) (not (= ?v_12 ?v_15))) (not (= ?v_12 ?v_16))) (not (= ?v_12 ?v_17))) (not (= ?v_13 ?v_14))) (not (= ?v_13 ?v_15))) (not (= ?v_13 ?v_16))) (not (= ?v_13 ?v_17))) (not (= ?v_14 ?v_15))) (not (= ?v_14 ?v_16))) (not (= ?v_14 ?v_17))) (not (= ?v_15 ?v_16))) (not (= ?v_15 ?v_17))) (not (= ?v_16 ?v_17)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_18 ?v_19)) (not (= ?v_18 ?v_20))) (not (= ?v_18 ?v_21))) (not (= ?v_18 ?v_22))) (not (= ?v_18 ?v_23))) (not (= ?v_19 ?v_20))) (not (= ?v_19 ?v_21))) (not (= ?v_19 ?v_22))) (not (= ?v_19 ?v_23))) (not (= ?v_20 ?v_21))) (not (= ?v_20 ?v_22))) (not (= ?v_20 ?v_23))) (not (= ?v_21 ?v_22))) (not (= ?v_21 ?v_23))) (not (= ?v_22 ?v_23)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_24 ?v_25)) (not (= ?v_24 ?v_26))) (not (= ?v_24 ?v_27))) (not (= ?v_24 ?v_28))) (not (= ?v_24 ?v_29))) (not (= ?v_25 ?v_26))) (not (= ?v_25 ?v_27))) (not (= ?v_25 ?v_28))) (not (= ?v_25 ?v_29))) (not (= ?v_26 ?v_27))) (not (= ?v_26 ?v_28))) (not (= ?v_26 ?v_29))) (not (= ?v_27 ?v_28))) (not (= ?v_27 ?v_29))) (not (= ?v_28 ?v_29)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_30 ?v_31)) (not (= ?v_30 ?v_32))) (not (= ?v_30 ?v_33))) (not (= ?v_30 ?v_34))) (not (= ?v_30 ?v_35))) (not (= ?v_31 ?v_32))) (not (= ?v_31 ?v_33))) (not (= ?v_31 ?v_34))) (not (= ?v_31 ?v_35))) (not (= ?v_32 ?v_33))) (not (= ?v_32 ?v_34))) (not (= ?v_32 ?v_35))) (not (= ?v_33 ?v_34))) (not (= ?v_33 ?v_35))) (not (= ?v_34 ?v_35)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_0 ?v_6)) (not (= ?v_0 ?v_12))) (not (= ?v_0 ?v_18))) (not (= ?v_0 ?v_24))) (not (= ?v_0 ?v_30))) (not (= ?v_6 ?v_12))) (not (= ?v_6 ?v_18))) (not (= ?v_6 ?v_24))) (not (= ?v_6 ?v_30))) (not (= ?v_12 ?v_18))) (not (= ?v_12 ?v_24))) (not (= ?v_12 ?v_30))) (not (= ?v_18 ?v_24))) (not (= ?v_18 ?v_30))) (not (= ?v_24 ?v_30))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_1 ?v_7)) (not (= ?v_1 ?v_13))) (not (= ?v_1 ?v_19))) (not (= ?v_1 ?v_25))) (not (= ?v_1 ?v_31))) (not (= ?v_7 ?v_13))) (not (= ?v_7 ?v_19))) (not (= ?v_7 ?v_25))) (not (= ?v_7 ?v_31))) (not (= ?v_13 ?v_19))) (not (= ?v_13 ?v_25))) (not (= ?v_13 ?v_31))) (not (= ?v_19 ?v_25))) (not (= ?v_19 ?v_31))) (not (= ?v_25 ?v_31)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_2 ?v_8)) (not (= ?v_2 ?v_14))) (not (= ?v_2 ?v_20))) (not (= ?v_2 ?v_26))) (not (= ?v_2 ?v_32))) (not (= ?v_8 ?v_14))) (not (= ?v_8 ?v_20))) (not (= ?v_8 ?v_26))) (not (= ?v_8 ?v_32))) (not (= ?v_14 ?v_20))) (not (= ?v_14 ?v_26))) (not (= ?v_14 ?v_32))) (not (= ?v_20 ?v_26))) (not (= ?v_20 ?v_32))) (not (= ?v_26 ?v_32)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_3 ?v_9)) (not (= ?v_3 ?v_15))) (not (= ?v_3 ?v_21))) (not (= ?v_3 ?v_27))) (not (= ?v_3 ?v_33))) (not (= ?v_9 ?v_15))) (not (= ?v_9 ?v_21))) (not (= ?v_9 ?v_27))) (not (= ?v_9 ?v_33))) (not (= ?v_15 ?v_21))) (not (= ?v_15 ?v_27))) (not (= ?v_15 ?v_33))) (not (= ?v_21 ?v_27))) (not (= ?v_21 ?v_33))) (not (= ?v_27 ?v_33)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_4 ?v_10)) (not (= ?v_4 ?v_16))) (not (= ?v_4 ?v_22))) (not (= ?v_4 ?v_28))) (not (= ?v_4 ?v_34))) (not (= ?v_10 ?v_16))) (not (= ?v_10 ?v_22))) (not (= ?v_10 ?v_28))) (not (= ?v_10 ?v_34))) (not (= ?v_16 ?v_22))) (not (= ?v_16 ?v_28))) (not (= ?v_16 ?v_34))) (not (= ?v_22 ?v_28))) (not (= ?v_22 ?v_34))) (not (= ?v_28 ?v_34)))) (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= ?v_5 ?v_11)) (not (= ?v_5 ?v_17))) (not (= ?v_5 ?v_23))) (not (= ?v_5 ?v_29))) (not (= ?v_5 ?v_35))) (not (= ?v_11 ?v_17))) (not (= ?v_11 ?v_23))) (not (= ?v_11 ?v_29))) (not (= ?v_11 ?v_35))) (not (= ?v_17 ?v_23))) (not (= ?v_17 ?v_29))) (not (= ?v_17 ?v_35))) (not (= ?v_23 ?v_29))) (not (= ?v_23 ?v_35))) (not (= ?v_29 ?v_35))))))) +(assert (and (and (and (and (and (and (and (and (and (and (and (and (and (and (not (= e0 e1)) (not (= e0 e2))) (not (= e0 e3))) (not (= e0 e4))) (not (= e0 e5))) (not (= e1 e2))) (not (= e1 e3))) (not (= e1 e4))) (not (= e1 e5))) (not (= e2 e3))) (not (= e2 e4))) (not (= e2 e5))) (not (= e3 e4))) (not (= e3 e5))) (not (= e4 e5)))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e2 (op e1 e4))) (= e3 (op e4 e1))) (= e4 (op e1 e1))) (= e5 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e2 (op e1 e5))) (= e3 (op e5 e1))) (= e5 (op e1 e1))) (= e4 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e2 (op e1 e3))) (= e4 (op e3 e1))) (= e3 (op e1 e1))) (= e5 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e2 (op e1 e5))) (= e4 (op e5 e1))) (= e5 (op e1 e1))) (= e3 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e2 (op e1 e3))) (= e5 (op e3 e1))) (= e3 (op e1 e1))) (= e4 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e2 (op e1 e4))) (= e5 (op e4 e1))) (= e4 (op e1 e1))) (= e3 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e3 (op e1 e4))) (= e2 (op e4 e1))) (= e4 (op e1 e1))) (= e5 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e3 (op e1 e5))) (= e2 (op e5 e1))) (= e5 (op e1 e1))) (= e4 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e3 (op e1 e2))) (= e4 (op e2 e1))) (= e2 (op e1 e1))) (= e5 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e3 (op e1 e5))) (= e4 (op e5 e1))) (= e5 (op e1 e1))) (= e2 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e3 (op e1 e2))) (= e5 (op e2 e1))) (= e2 (op e1 e1))) (= e4 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e3 (op e1 e4))) (= e5 (op e4 e1))) (= e4 (op e1 e1))) (= e2 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e4 (op e1 e3))) (= e2 (op e3 e1))) (= e3 (op e1 e1))) (= e5 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e4 (op e1 e5))) (= e2 (op e5 e1))) (= e5 (op e1 e1))) (= e3 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e4 (op e1 e2))) (= e3 (op e2 e1))) (= e2 (op e1 e1))) (= e5 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e4 (op e1 e5))) (= e3 (op e5 e1))) (= e5 (op e1 e1))) (= e2 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e4 (op e1 e2))) (= e5 (op e2 e1))) (= e2 (op e1 e1))) (= e3 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e4 (op e1 e3))) (= e5 (op e3 e1))) (= e3 (op e1 e1))) (= e2 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e5 (op e1 e3))) (= e2 (op e3 e1))) (= e3 (op e1 e1))) (= e4 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e5 (op e1 e4))) (= e2 (op e4 e1))) (= e4 (op e1 e1))) (= e3 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e5 (op e1 e2))) (= e3 (op e2 e1))) (= e2 (op e1 e1))) (= e4 (op e5 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e5 (op e1 e4))) (= e3 (op e4 e1))) (= e4 (op e1 e1))) (= e2 (op e5 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e5 (op e1 e2))) (= e4 (op e2 e1))) (= e2 (op e1 e1))) (= e3 (op e5 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e5 (op e1 e3))) (= e4 (op e3 e1))) (= e3 (op e1 e1))) (= e2 (op e5 e4))))) +(assert (not (and (and (and (and (= e2 (op e4 e5)) (= e3 (op e1 e5))) (= e4 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e2 (op e5 e4)) (= e3 (op e1 e4))) (= e5 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e2 (op e3 e5)) (= e4 (op e1 e5))) (= e3 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e2 (op e5 e3)) (= e4 (op e1 e3))) (= e5 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e2 (op e3 e4)) (= e5 (op e1 e4))) (= e3 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e2 (op e4 e3)) (= e5 (op e1 e3))) (= e4 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e3 (op e4 e5)) (= e2 (op e1 e5))) (= e4 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e3 (op e5 e4)) (= e2 (op e1 e4))) (= e5 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e3 (op e2 e5)) (= e4 (op e1 e5))) (= e2 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e3 (op e5 e2)) (= e4 (op e1 e2))) (= e5 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e3 (op e2 e4)) (= e5 (op e1 e4))) (= e2 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e3 (op e4 e2)) (= e5 (op e1 e2))) (= e4 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e4 (op e3 e5)) (= e2 (op e1 e5))) (= e3 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e4 (op e5 e3)) (= e2 (op e1 e3))) (= e5 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e4 (op e2 e5)) (= e3 (op e1 e5))) (= e2 (op e5 e1))) (= e5 (op e1 e1))) (= e0 (op e3 e2))))) +(assert (not (and (and (and (and (= e4 (op e5 e2)) (= e3 (op e1 e2))) (= e5 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e4 (op e2 e3)) (= e5 (op e1 e3))) (= e2 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e4 (op e3 e2)) (= e5 (op e1 e2))) (= e3 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e5 (op e3 e4)) (= e2 (op e1 e4))) (= e3 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e5 (op e4 e3)) (= e2 (op e1 e3))) (= e4 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e5 (op e2 e4)) (= e3 (op e1 e4))) (= e2 (op e4 e1))) (= e4 (op e1 e1))) (= e0 (op e3 e2))))) +(assert (not (and (and (and (and (= e5 (op e4 e2)) (= e3 (op e1 e2))) (= e4 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e5 (op e2 e3)) (= e4 (op e1 e3))) (= e2 (op e3 e1))) (= e3 (op e1 e1))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e5 (op e3 e2)) (= e4 (op e1 e2))) (= e3 (op e2 e1))) (= e2 (op e1 e1))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e1 (op e2 e4))) (= e3 (op e4 e2))) (= e4 (op e2 e2))) (= e5 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e1 (op e2 e5))) (= e3 (op e5 e2))) (= e5 (op e2 e2))) (= e4 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e1 (op e2 e3))) (= e4 (op e3 e2))) (= e3 (op e2 e2))) (= e5 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e1 (op e2 e5))) (= e4 (op e5 e2))) (= e5 (op e2 e2))) (= e3 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e1 (op e2 e3))) (= e5 (op e3 e2))) (= e3 (op e2 e2))) (= e4 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e1 (op e2 e4))) (= e5 (op e4 e2))) (= e4 (op e2 e2))) (= e3 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e3 (op e2 e4))) (= e1 (op e4 e2))) (= e4 (op e2 e2))) (= e5 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e3 (op e2 e5))) (= e1 (op e5 e2))) (= e5 (op e2 e2))) (= e4 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e3 (op e2 e1))) (= e4 (op e1 e2))) (= e1 (op e2 e2))) (= e5 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e3 (op e2 e5))) (= e4 (op e5 e2))) (= e5 (op e2 e2))) (= e1 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e3 (op e2 e1))) (= e5 (op e1 e2))) (= e1 (op e2 e2))) (= e4 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e3 (op e2 e4))) (= e5 (op e4 e2))) (= e4 (op e2 e2))) (= e1 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e4 (op e2 e3))) (= e1 (op e3 e2))) (= e3 (op e2 e2))) (= e5 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e4 (op e2 e5))) (= e1 (op e5 e2))) (= e5 (op e2 e2))) (= e3 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e4 (op e2 e1))) (= e3 (op e1 e2))) (= e1 (op e2 e2))) (= e5 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e4 (op e2 e5))) (= e3 (op e5 e2))) (= e5 (op e2 e2))) (= e1 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e4 (op e2 e1))) (= e5 (op e1 e2))) (= e1 (op e2 e2))) (= e3 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e4 (op e2 e3))) (= e5 (op e3 e2))) (= e3 (op e2 e2))) (= e1 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e5 (op e2 e3))) (= e1 (op e3 e2))) (= e3 (op e2 e2))) (= e4 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e5 (op e2 e4))) (= e1 (op e4 e2))) (= e4 (op e2 e2))) (= e3 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e5 (op e2 e1))) (= e3 (op e1 e2))) (= e1 (op e2 e2))) (= e4 (op e5 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e5 (op e2 e4))) (= e3 (op e4 e2))) (= e4 (op e2 e2))) (= e1 (op e5 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e5 (op e2 e1))) (= e4 (op e1 e2))) (= e1 (op e2 e2))) (= e3 (op e5 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e5 (op e2 e3))) (= e4 (op e3 e2))) (= e3 (op e2 e2))) (= e1 (op e5 e4))))) +(assert (not (and (and (and (and (= e1 (op e4 e5)) (= e3 (op e2 e5))) (= e4 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e1 (op e5 e4)) (= e3 (op e2 e4))) (= e5 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e1 (op e3 e5)) (= e4 (op e2 e5))) (= e3 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e1 (op e5 e3)) (= e4 (op e2 e3))) (= e5 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e1 (op e3 e4)) (= e5 (op e2 e4))) (= e3 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e1 (op e4 e3)) (= e5 (op e2 e3))) (= e4 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e3 (op e4 e5)) (= e1 (op e2 e5))) (= e4 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e3 (op e5 e4)) (= e1 (op e2 e4))) (= e5 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e3 (op e1 e5)) (= e4 (op e2 e5))) (= e1 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e3 (op e5 e1)) (= e4 (op e2 e1))) (= e5 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e3 (op e1 e4)) (= e5 (op e2 e4))) (= e1 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e3 (op e4 e1)) (= e5 (op e2 e1))) (= e4 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e4 (op e3 e5)) (= e1 (op e2 e5))) (= e3 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e4 (op e5 e3)) (= e1 (op e2 e3))) (= e5 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e4 (op e1 e5)) (= e3 (op e2 e5))) (= e1 (op e5 e2))) (= e5 (op e2 e2))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e4 (op e5 e1)) (= e3 (op e2 e1))) (= e5 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e4 (op e1 e3)) (= e5 (op e2 e3))) (= e1 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e4 (op e3 e1)) (= e5 (op e2 e1))) (= e3 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e5 (op e3 e4)) (= e1 (op e2 e4))) (= e3 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e5 (op e4 e3)) (= e1 (op e2 e3))) (= e4 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e5 (op e1 e4)) (= e3 (op e2 e4))) (= e1 (op e4 e2))) (= e4 (op e2 e2))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e5 (op e4 e1)) (= e3 (op e2 e1))) (= e4 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e5 (op e1 e3)) (= e4 (op e2 e3))) (= e1 (op e3 e2))) (= e3 (op e2 e2))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e5 (op e3 e1)) (= e4 (op e2 e1))) (= e3 (op e1 e2))) (= e1 (op e2 e2))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e1 (op e3 e4))) (= e2 (op e4 e3))) (= e4 (op e3 e3))) (= e5 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e1 (op e3 e5))) (= e2 (op e5 e3))) (= e5 (op e3 e3))) (= e4 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e1 (op e3 e2))) (= e4 (op e2 e3))) (= e2 (op e3 e3))) (= e5 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e1 (op e3 e5))) (= e4 (op e5 e3))) (= e5 (op e3 e3))) (= e2 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e1 (op e3 e2))) (= e5 (op e2 e3))) (= e2 (op e3 e3))) (= e4 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e1 (op e3 e4))) (= e5 (op e4 e3))) (= e4 (op e3 e3))) (= e2 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e2 (op e3 e4))) (= e1 (op e4 e3))) (= e4 (op e3 e3))) (= e5 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e2 (op e3 e5))) (= e1 (op e5 e3))) (= e5 (op e3 e3))) (= e4 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e2 (op e3 e1))) (= e4 (op e1 e3))) (= e1 (op e3 e3))) (= e5 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e5)) (= e2 (op e3 e5))) (= e4 (op e5 e3))) (= e5 (op e3 e3))) (= e1 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e2 (op e3 e1))) (= e5 (op e1 e3))) (= e1 (op e3 e3))) (= e4 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e4)) (= e2 (op e3 e4))) (= e5 (op e4 e3))) (= e4 (op e3 e3))) (= e1 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e4 (op e3 e2))) (= e1 (op e2 e3))) (= e2 (op e3 e3))) (= e5 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e4 (op e3 e5))) (= e1 (op e5 e3))) (= e5 (op e3 e3))) (= e2 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e4 (op e3 e1))) (= e2 (op e1 e3))) (= e1 (op e3 e3))) (= e5 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e4 (op e3 e5))) (= e2 (op e5 e3))) (= e5 (op e3 e3))) (= e1 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e4 (op e3 e1))) (= e5 (op e1 e3))) (= e1 (op e3 e3))) (= e2 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e4 (op e3 e2))) (= e5 (op e2 e3))) (= e2 (op e3 e3))) (= e1 (op e4 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e5 (op e3 e2))) (= e1 (op e2 e3))) (= e2 (op e3 e3))) (= e4 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e5 (op e3 e4))) (= e1 (op e4 e3))) (= e4 (op e3 e3))) (= e2 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e5 (op e3 e1))) (= e2 (op e1 e3))) (= e1 (op e3 e3))) (= e4 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e5 (op e3 e4))) (= e2 (op e4 e3))) (= e4 (op e3 e3))) (= e1 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e5 (op e3 e1))) (= e4 (op e1 e3))) (= e1 (op e3 e3))) (= e2 (op e5 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e5 (op e3 e2))) (= e4 (op e2 e3))) (= e2 (op e3 e3))) (= e1 (op e5 e4))))) +(assert (not (and (and (and (and (= e1 (op e4 e5)) (= e2 (op e3 e5))) (= e4 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e1 (op e5 e4)) (= e2 (op e3 e4))) (= e5 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e1 (op e2 e5)) (= e4 (op e3 e5))) (= e2 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e1 (op e5 e2)) (= e4 (op e3 e2))) (= e5 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e1 (op e2 e4)) (= e5 (op e3 e4))) (= e2 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e1 (op e4 e2)) (= e5 (op e3 e2))) (= e4 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e2 (op e4 e5)) (= e1 (op e3 e5))) (= e4 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e2 (op e5 e4)) (= e1 (op e3 e4))) (= e5 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e2 (op e1 e5)) (= e4 (op e3 e5))) (= e1 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e2 (op e5 e1)) (= e4 (op e3 e1))) (= e5 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e4 e5))))) +(assert (not (and (and (and (and (= e2 (op e1 e4)) (= e5 (op e3 e4))) (= e1 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e2 (op e4 e1)) (= e5 (op e3 e1))) (= e4 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e5 e4))))) +(assert (not (and (and (and (and (= e4 (op e2 e5)) (= e1 (op e3 e5))) (= e2 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e4 (op e5 e2)) (= e1 (op e3 e2))) (= e5 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e4 (op e1 e5)) (= e2 (op e3 e5))) (= e1 (op e5 e3))) (= e5 (op e3 e3))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e4 (op e5 e1)) (= e2 (op e3 e1))) (= e5 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e4 (op e1 e2)) (= e5 (op e3 e2))) (= e1 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e4 (op e2 e1)) (= e5 (op e3 e1))) (= e2 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e5 (op e2 e4)) (= e1 (op e3 e4))) (= e2 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e5 (op e4 e2)) (= e1 (op e3 e2))) (= e4 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e5 (op e1 e4)) (= e2 (op e3 e4))) (= e1 (op e4 e3))) (= e4 (op e3 e3))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e5 (op e4 e1)) (= e2 (op e3 e1))) (= e4 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e5 (op e1 e2)) (= e4 (op e3 e2))) (= e1 (op e2 e3))) (= e2 (op e3 e3))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e5 (op e2 e1)) (= e4 (op e3 e1))) (= e2 (op e1 e3))) (= e1 (op e3 e3))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e1 (op e4 e3))) (= e2 (op e3 e4))) (= e3 (op e4 e4))) (= e5 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e1 (op e4 e5))) (= e2 (op e5 e4))) (= e5 (op e4 e4))) (= e3 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e1 (op e4 e2))) (= e3 (op e2 e4))) (= e2 (op e4 e4))) (= e5 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e1 (op e4 e5))) (= e3 (op e5 e4))) (= e5 (op e4 e4))) (= e2 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e1 (op e4 e2))) (= e5 (op e2 e4))) (= e2 (op e4 e4))) (= e3 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e1 (op e4 e3))) (= e5 (op e3 e4))) (= e3 (op e4 e4))) (= e2 (op e1 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e2 (op e4 e3))) (= e1 (op e3 e4))) (= e3 (op e4 e4))) (= e5 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e2 (op e4 e5))) (= e1 (op e5 e4))) (= e5 (op e4 e4))) (= e3 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e2 (op e4 e1))) (= e3 (op e1 e4))) (= e1 (op e4 e4))) (= e5 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e5)) (= e2 (op e4 e5))) (= e3 (op e5 e4))) (= e5 (op e4 e4))) (= e1 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e2 (op e4 e1))) (= e5 (op e1 e4))) (= e1 (op e4 e4))) (= e3 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e3)) (= e2 (op e4 e3))) (= e5 (op e3 e4))) (= e3 (op e4 e4))) (= e1 (op e2 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e3 (op e4 e2))) (= e1 (op e2 e4))) (= e2 (op e4 e4))) (= e5 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e5)) (= e3 (op e4 e5))) (= e1 (op e5 e4))) (= e5 (op e4 e4))) (= e2 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e3 (op e4 e1))) (= e2 (op e1 e4))) (= e1 (op e4 e4))) (= e5 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e5)) (= e3 (op e4 e5))) (= e2 (op e5 e4))) (= e5 (op e4 e4))) (= e1 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e5 e1)) (= e3 (op e4 e1))) (= e5 (op e1 e4))) (= e1 (op e4 e4))) (= e2 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e5 e2)) (= e3 (op e4 e2))) (= e5 (op e2 e4))) (= e2 (op e4 e4))) (= e1 (op e3 e5))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e5 (op e4 e2))) (= e1 (op e2 e4))) (= e2 (op e4 e4))) (= e3 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e5 (op e4 e3))) (= e1 (op e3 e4))) (= e3 (op e4 e4))) (= e2 (op e5 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e5 (op e4 e1))) (= e2 (op e1 e4))) (= e1 (op e4 e4))) (= e3 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e5 (op e4 e3))) (= e2 (op e3 e4))) (= e3 (op e4 e4))) (= e1 (op e5 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e5 (op e4 e1))) (= e3 (op e1 e4))) (= e1 (op e4 e4))) (= e2 (op e5 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e5 (op e4 e2))) (= e3 (op e2 e4))) (= e2 (op e4 e4))) (= e1 (op e5 e3))))) +(assert (not (and (and (and (and (= e1 (op e3 e5)) (= e2 (op e4 e5))) (= e3 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e1 (op e5 e3)) (= e2 (op e4 e3))) (= e5 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e1 (op e2 e5)) (= e3 (op e4 e5))) (= e2 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e3 e2))))) +(assert (not (and (and (and (and (= e1 (op e5 e2)) (= e3 (op e4 e2))) (= e5 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e1 (op e2 e3)) (= e5 (op e4 e3))) (= e2 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e1 (op e3 e2)) (= e5 (op e4 e2))) (= e3 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e2 (op e3 e5)) (= e1 (op e4 e5))) (= e3 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e2 (op e5 e3)) (= e1 (op e4 e3))) (= e5 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e2 (op e1 e5)) (= e3 (op e4 e5))) (= e1 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e2 (op e5 e1)) (= e3 (op e4 e1))) (= e5 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e3 e5))))) +(assert (not (and (and (and (and (= e2 (op e1 e3)) (= e5 (op e4 e3))) (= e1 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e2 (op e3 e1)) (= e5 (op e4 e1))) (= e3 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e5 e3))))) +(assert (not (and (and (and (and (= e3 (op e2 e5)) (= e1 (op e4 e5))) (= e2 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e3 (op e5 e2)) (= e1 (op e4 e2))) (= e5 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e1 e5))))) +(assert (not (and (and (and (and (= e3 (op e1 e5)) (= e2 (op e4 e5))) (= e1 (op e5 e4))) (= e5 (op e4 e4))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e3 (op e5 e1)) (= e2 (op e4 e1))) (= e5 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e2 e5))))) +(assert (not (and (and (and (and (= e3 (op e1 e2)) (= e5 (op e4 e2))) (= e1 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e5 e1))))) +(assert (not (and (and (and (and (= e3 (op e2 e1)) (= e5 (op e4 e1))) (= e2 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e5 e2))))) +(assert (not (and (and (and (and (= e5 (op e2 e3)) (= e1 (op e4 e3))) (= e2 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e5 (op e3 e2)) (= e1 (op e4 e2))) (= e3 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e5 (op e1 e3)) (= e2 (op e4 e3))) (= e1 (op e3 e4))) (= e3 (op e4 e4))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e5 (op e3 e1)) (= e2 (op e4 e1))) (= e3 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e5 (op e1 e2)) (= e3 (op e4 e2))) (= e1 (op e2 e4))) (= e2 (op e4 e4))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e5 (op e2 e1)) (= e3 (op e4 e1))) (= e2 (op e1 e4))) (= e1 (op e4 e4))) (= e0 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e1 (op e5 e3))) (= e2 (op e3 e5))) (= e3 (op e5 e5))) (= e4 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e1 (op e5 e4))) (= e2 (op e4 e5))) (= e4 (op e5 e5))) (= e3 (op e1 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e1 (op e5 e2))) (= e3 (op e2 e5))) (= e2 (op e5 e5))) (= e4 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e1 (op e5 e4))) (= e3 (op e4 e5))) (= e4 (op e5 e5))) (= e2 (op e1 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e1 (op e5 e2))) (= e4 (op e2 e5))) (= e2 (op e5 e5))) (= e3 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e1 (op e5 e3))) (= e4 (op e3 e5))) (= e3 (op e5 e5))) (= e2 (op e1 e4))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e2 (op e5 e3))) (= e1 (op e3 e5))) (= e3 (op e5 e5))) (= e4 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e2 (op e5 e4))) (= e1 (op e4 e5))) (= e4 (op e5 e5))) (= e3 (op e2 e1))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e2 (op e5 e1))) (= e3 (op e1 e5))) (= e1 (op e5 e5))) (= e4 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e4)) (= e2 (op e5 e4))) (= e3 (op e4 e5))) (= e4 (op e5 e5))) (= e1 (op e2 e3))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e2 (op e5 e1))) (= e4 (op e1 e5))) (= e1 (op e5 e5))) (= e3 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e3)) (= e2 (op e5 e3))) (= e4 (op e3 e5))) (= e3 (op e5 e5))) (= e1 (op e2 e4))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e3 (op e5 e2))) (= e1 (op e2 e5))) (= e2 (op e5 e5))) (= e4 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e4)) (= e3 (op e5 e4))) (= e1 (op e4 e5))) (= e4 (op e5 e5))) (= e2 (op e3 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e3 (op e5 e1))) (= e2 (op e1 e5))) (= e1 (op e5 e5))) (= e4 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e4)) (= e3 (op e5 e4))) (= e2 (op e4 e5))) (= e4 (op e5 e5))) (= e1 (op e3 e2))))) +(assert (not (and (and (and (and (= e0 (op e4 e1)) (= e3 (op e5 e1))) (= e4 (op e1 e5))) (= e1 (op e5 e5))) (= e2 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e4 e2)) (= e3 (op e5 e2))) (= e4 (op e2 e5))) (= e2 (op e5 e5))) (= e1 (op e3 e4))))) +(assert (not (and (and (and (and (= e0 (op e1 e2)) (= e4 (op e5 e2))) (= e1 (op e2 e5))) (= e2 (op e5 e5))) (= e3 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e1 e3)) (= e4 (op e5 e3))) (= e1 (op e3 e5))) (= e3 (op e5 e5))) (= e2 (op e4 e1))))) +(assert (not (and (and (and (and (= e0 (op e2 e1)) (= e4 (op e5 e1))) (= e2 (op e1 e5))) (= e1 (op e5 e5))) (= e3 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e2 e3)) (= e4 (op e5 e3))) (= e2 (op e3 e5))) (= e3 (op e5 e5))) (= e1 (op e4 e2))))) +(assert (not (and (and (and (and (= e0 (op e3 e1)) (= e4 (op e5 e1))) (= e3 (op e1 e5))) (= e1 (op e5 e5))) (= e2 (op e4 e3))))) +(assert (not (and (and (and (and (= e0 (op e3 e2)) (= e4 (op e5 e2))) (= e3 (op e2 e5))) (= e2 (op e5 e5))) (= e1 (op e4 e3))))) +(assert (not (and (and (and (and (= e1 (op e3 e4)) (= e2 (op e5 e4))) (= e3 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e1 (op e4 e3)) (= e2 (op e5 e3))) (= e4 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e1 (op e2 e4)) (= e3 (op e5 e4))) (= e2 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e3 e2))))) +(assert (not (and (and (and (and (= e1 (op e4 e2)) (= e3 (op e5 e2))) (= e4 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e1 (op e2 e3)) (= e4 (op e5 e3))) (= e2 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e1 (op e3 e2)) (= e4 (op e5 e2))) (= e3 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e2 (op e3 e4)) (= e1 (op e5 e4))) (= e3 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e2 (op e4 e3)) (= e1 (op e5 e3))) (= e4 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e2 (op e1 e4)) (= e3 (op e5 e4))) (= e1 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e2 (op e4 e1)) (= e3 (op e5 e1))) (= e4 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e3 e4))))) +(assert (not (and (and (and (and (= e2 (op e1 e3)) (= e4 (op e5 e3))) (= e1 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e2 (op e3 e1)) (= e4 (op e5 e1))) (= e3 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e4 e3))))) +(assert (not (and (and (and (and (= e3 (op e2 e4)) (= e1 (op e5 e4))) (= e2 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e3 (op e4 e2)) (= e1 (op e5 e2))) (= e4 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e1 e4))))) +(assert (not (and (and (and (and (= e3 (op e1 e4)) (= e2 (op e5 e4))) (= e1 (op e4 e5))) (= e4 (op e5 e5))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e3 (op e4 e1)) (= e2 (op e5 e1))) (= e4 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e2 e4))))) +(assert (not (and (and (and (and (= e3 (op e1 e2)) (= e4 (op e5 e2))) (= e1 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e4 e1))))) +(assert (not (and (and (and (and (= e3 (op e2 e1)) (= e4 (op e5 e1))) (= e2 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e4 e2))))) +(assert (not (and (and (and (and (= e4 (op e2 e3)) (= e1 (op e5 e3))) (= e2 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e1 e2))))) +(assert (not (and (and (and (and (= e4 (op e3 e2)) (= e1 (op e5 e2))) (= e3 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e1 e3))))) +(assert (not (and (and (and (and (= e4 (op e1 e3)) (= e2 (op e5 e3))) (= e1 (op e3 e5))) (= e3 (op e5 e5))) (= e0 (op e2 e1))))) +(assert (not (and (and (and (and (= e4 (op e3 e1)) (= e2 (op e5 e1))) (= e3 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e2 e3))))) +(assert (not (and (and (and (and (= e4 (op e1 e2)) (= e3 (op e5 e2))) (= e1 (op e2 e5))) (= e2 (op e5 e5))) (= e0 (op e3 e1))))) +(assert (not (and (and (and (and (= e4 (op e2 e1)) (= e3 (op e5 e1))) (= e2 (op e1 e5))) (= e1 (op e5 e5))) (= e0 (op e3 e2))))) +(check-sat) +(exit) diff --git a/tests/unsat/typed_v2l20025.cvc.smt2 b/tests/unsat/typed_v2l20025.cvc.smt2 new file mode 100644 index 00000000..28c6cc1e --- /dev/null +++ b/tests/unsat/typed_v2l20025.cvc.smt2 @@ -0,0 +1,31 @@ +(set-info :smt-lib-version 2.6) +(set-logic QF_DT) +(set-info :source | +Generated by: Andrew Reynolds +Generated on: 2017-04-28 +Generator: Random, converted to v2.6 by CVC4 +Application: Regressions for datatypes decision procedure. +Target solver: CVC3 +Publications: "An Abstract Decision Procedure for Satisfiability in the Theory of Inductive Data Types" by Clark Barrett, Igor Shikanian, and Cesare Tinelli, Journal on Satisfiability, Boolean Modeling and Computation 2007. +|) +(set-info :license "https://creativecommons.org/licenses/by/4.0/") +(set-info :category "random") +(set-info :status unsat) + + +(declare-datatypes ((nat 0)(list 0)(tree 0)) (((succ (pred nat)) (zero)) +((cons (car tree) (cdr list)) (null)) +((node (children list)) (leaf (data nat))) +)) +(declare-fun x1 () nat) +(declare-fun x2 () nat) +(declare-fun x3 () list) +(declare-fun x4 () list) +(declare-fun x5 () tree) +(declare-fun x6 () tree) + +(assert (and ((_ is cons) x4) (= (cons (node x4) x3) (ite ((_ is cons) x4) (cdr x4) null)))) +(check-sat) +(exit) + + diff --git a/tests/unsat/typed_v3l60024.cvc.smt2 b/tests/unsat/typed_v3l60024.cvc.smt2 new file mode 100644 index 00000000..1ea3312b --- /dev/null +++ b/tests/unsat/typed_v3l60024.cvc.smt2 @@ -0,0 +1,34 @@ +(set-info :smt-lib-version 2.6) +(set-logic QF_DT) +(set-info :source | +Generated by: Andrew Reynolds +Generated on: 2017-04-28 +Generator: Random, converted to v2.6 by CVC4 +Application: Regressions for datatypes decision procedure. +Target solver: CVC3 +Publications: "An Abstract Decision Procedure for Satisfiability in the Theory of Inductive Data Types" by Clark Barrett, Igor Shikanian, and Cesare Tinelli, Journal on Satisfiability, Boolean Modeling and Computation 2007. +|) +(set-info :license "https://creativecommons.org/licenses/by/4.0/") +(set-info :category "random") +(set-info :status unsat) + + +(declare-datatypes ((nat 0)(list 0)(tree 0)) (((succ (pred nat)) (zero)) +((cons (car tree) (cdr list)) (null)) +((node (children list)) (leaf (data nat))) +)) +(declare-fun x1 () nat) +(declare-fun x2 () nat) +(declare-fun x3 () nat) +(declare-fun x4 () list) +(declare-fun x5 () list) +(declare-fun x6 () list) +(declare-fun x7 () tree) +(declare-fun x8 () tree) +(declare-fun x9 () tree) + +(assert (and (and (and (and (and (= (ite ((_ is cons) (ite ((_ is node) x9) (children x9) null)) (cdr (ite ((_ is node) x9) (children x9) null)) null) (cons x9 x6)) (= (ite ((_ is leaf) (node x6)) (data (node x6)) zero) (ite ((_ is leaf) (ite ((_ is cons) x5) (car x5) (leaf zero))) (data (ite ((_ is cons) x5) (car x5) (leaf zero))) zero))) (not ((_ is succ) zero))) (not (= x7 x8))) (not ((_ is leaf) x7))) (= (ite ((_ is cons) x6) (cdr x6) null) (ite ((_ is cons) null) (cdr null) null)))) +(check-sat) +(exit) + + diff --git a/tests/unsat/typed_v5l50010.cvc.smt2 b/tests/unsat/typed_v5l50010.cvc.smt2 new file mode 100644 index 00000000..e9c37ef2 --- /dev/null +++ b/tests/unsat/typed_v5l50010.cvc.smt2 @@ -0,0 +1,40 @@ +(set-info :smt-lib-version 2.6) +(set-logic QF_DT) +(set-info :source | +Generated by: Andrew Reynolds +Generated on: 2017-04-28 +Generator: Random, converted to v2.6 by CVC4 +Application: Regressions for datatypes decision procedure. +Target solver: CVC3 +Publications: "An Abstract Decision Procedure for Satisfiability in the Theory of Inductive Data Types" by Clark Barrett, Igor Shikanian, and Cesare Tinelli, Journal on Satisfiability, Boolean Modeling and Computation 2007. +|) +(set-info :license "https://creativecommons.org/licenses/by/4.0/") +(set-info :category "random") +(set-info :status unsat) + + +(declare-datatypes ((nat 0)(list 0)(tree 0)) (((succ (pred nat)) (zero)) +((cons (car tree) (cdr list)) (null)) +((node (children list)) (leaf (data nat))) +)) +(declare-fun x1 () nat) +(declare-fun x2 () nat) +(declare-fun x3 () nat) +(declare-fun x4 () nat) +(declare-fun x5 () nat) +(declare-fun x6 () list) +(declare-fun x7 () list) +(declare-fun x8 () list) +(declare-fun x9 () list) +(declare-fun x10 () list) +(declare-fun x11 () tree) +(declare-fun x12 () tree) +(declare-fun x13 () tree) +(declare-fun x14 () tree) +(declare-fun x15 () tree) + +(assert (and (and (and (and (= (succ x3) (ite ((_ is succ) x3) (pred x3) zero)) (not ((_ is node) x11))) (not ((_ is leaf) x13))) (not (= (ite ((_ is node) x12) (children x12) null) x6))) (= (ite ((_ is node) x14) (children x14) null) x8))) +(check-sat) +(exit) + + From 28173c18520395a23054995d52d7d3d78a07718d Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 25 Aug 2022 20:50:56 -0400 Subject: [PATCH 158/174] feat(term): replace E_app_uncurried with E_app_fold --- src/base/Form.ml | 27 ++++--- src/base/th_data.ml | 2 +- src/core-logic/term.ml | 75 ++++++++++++++----- src/core-logic/term.mli | 8 +- src/core-logic/types_.ml | 6 +- src/core/t_printer.ml | 5 +- src/th-bool-static/Sidekick_th_bool_static.ml | 9 +-- 7 files changed, 88 insertions(+), 44 deletions(-) diff --git a/src/base/Form.ml b/src/base/Form.ml index 59ea3a01..6173d171 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -56,12 +56,16 @@ let view (t : T.t) : T.t view = else B_eq (a, b) | E_const { Const.c_view = T.C_ite; _ }, [ _ty; a; b; c ] -> B_ite (a, b, c) - | E_app_uncurried { c = { Const.c_view = C_and; _ }; args; _ }, _ -> - B_and args - | E_app_uncurried { c = { Const.c_view = C_or; _ }; args; _ }, _ -> B_or args - | E_app_uncurried { c = { Const.c_view = C_imply; _ }; args = [ a; b ]; _ }, _ - -> - B_imply (a, b) + | E_const { Const.c_view = C_imply; _ }, [ a; b ] -> B_imply (a, b) + | E_app_fold { f; args; acc0 }, [] -> + (match T.view f, T.view acc0 with + | ( E_const { Const.c_view = C_and; _ }, + E_const { Const.c_view = T.C_true; _ } ) -> + B_and args + | ( E_const { Const.c_view = C_or; _ }, + E_const { Const.c_view = T.C_false; _ } ) -> + B_or args + | _ -> B_atom t) | _ -> B_atom t let ty2b_ tst = @@ -75,20 +79,19 @@ let c_imply tst : Const.t = Const.make C_imply ops ~ty:(ty2b_ tst) let and_l tst = function | [] -> T.true_ tst | [ x ] -> x - | l -> Term.app_uncurried tst (c_and tst) l ~ty:(Term.bool tst) + | l -> + Term.app_fold tst l ~f:(Term.const tst @@ c_and tst) ~acc0:(T.true_ tst) let or_l tst = function | [] -> T.false_ tst | [ x ] -> x - | l -> Term.app_uncurried tst (c_or tst) l ~ty:(Term.bool tst) + | l -> + Term.app_fold tst l ~f:(Term.const tst @@ c_or tst) ~acc0:(T.false_ tst) let bool = Term.bool_val let and_ tst a b = and_l tst [ a; b ] let or_ tst a b = or_l tst [ a; b ] - -let imply tst a b : Term.t = - Term.app_uncurried tst (c_imply tst) [ a; b ] ~ty:(Term.bool tst) - +let imply tst a b : Term.t = T.app_l tst (T.const tst @@ c_imply tst) [ a; b ] let eq = T.eq let not_ = T.not let ite = T.ite diff --git a/src/base/th_data.ml b/src/base/th_data.ml index 338589bb..1001ce21 100644 --- a/src/base/th_data.ml +++ b/src/base/th_data.ml @@ -34,7 +34,7 @@ let arg = | None, E_pi (_, a, b) -> Ty_other { sub = [ a; b ] } | ( None, ( E_const _ | E_var _ | E_type _ | E_bound_var _ | E_lam _ - | E_app_uncurried _ ) ) -> + | E_app_fold _ ) ) -> Ty_other { sub = [] } ) diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 319eedb7..33884ee3 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -10,7 +10,11 @@ type view = term_view = | E_bound_var of bvar | E_const of const | E_app of term * term - | E_app_uncurried of { c: const; ty: term; args: term list } + | E_app_fold of { + f: term; (** function to fold *) + args: term list; (** Arguments to the fold *) + acc0: term; (** initial accumulator *) + } | E_lam of string * term * term | E_pi of string * term * term @@ -75,9 +79,10 @@ let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty (loop (k + 1) ~depth:(depth + 1) ("" :: names)) bod - | E_app_uncurried { c; args; ty = _ } -> - Fmt.fprintf out "(@[%a" Const.pp c; + | E_app_fold { f; args; acc0 } -> + Fmt.fprintf out "(@[%a" pp' f; List.iter (fun x -> Fmt.fprintf out "@ %a" pp' x) args; + Fmt.fprintf out "@ %a" pp' acc0; Fmt.fprintf out "@])" | E_lam (n, _ty, bod) -> Fmt.fprintf out "(@[\\%s:@[%a@].@ %a@])" n pp' _ty @@ -128,14 +133,15 @@ module Hcons = Hashcons.Make (struct | E_var v1, E_var v2 -> Var.equal v1 v2 | E_bound_var v1, E_bound_var v2 -> Bvar.equal v1 v2 | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 - | E_app_uncurried a1, E_app_uncurried a2 -> - Const.equal a1.c a2.c && List.equal equal a1.args a2.args + | E_app_fold a1, E_app_fold a2 -> + equal a1.f a2.f && equal a1.acc0 a2.acc0 + && List.equal equal a1.args a2.args | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 | E_pi (_, ty1, bod1), E_pi (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 | ( ( E_type _ | E_const _ | E_var _ | E_bound_var _ | E_app _ - | E_app_uncurried _ | E_lam _ | E_pi _ ), + | E_app_fold _ | E_lam _ | E_pi _ ), _ ) -> false @@ -146,8 +152,8 @@ module Hcons = Hashcons.Make (struct | E_var v -> H.combine2 30 (Var.hash v) | E_bound_var v -> H.combine2 40 (Bvar.hash v) | E_app (f, a) -> H.combine3 50 (hash f) (hash a) - | E_app_uncurried a -> - H.combine3 55 (Const.hash a.c) (Hash.list hash a.args) + | E_app_fold a -> + H.combine4 55 (hash a.f) (hash a.acc0) (Hash.list hash a.args) | E_lam (_, ty, bod) -> H.combine3 60 (hash ty) (hash bod) | E_pi (_, ty, bod) -> H.combine3 70 (hash ty) (hash bod) @@ -189,8 +195,9 @@ let iter_shallow ~f (e : term) : unit = | E_app (hd, a) -> f false hd; f false a - | E_app_uncurried { ty; args; _ } -> - f false ty; + | E_app_fold { f = fold_f; args; acc0 } -> + f false fold_f; + f false acc0; List.iter (fun u -> f false u) args | E_lam (_, tyv, bod) | E_pi (_, tyv, bod) -> f false tyv; @@ -218,13 +225,14 @@ let map_shallow_ ~make ~f (e : term) : term = e else make (E_app (f false hd, f false a)) - | E_app_uncurried { args = l; c; ty } -> + | E_app_fold { f = fold_f; args = l; acc0 } -> + let fold_f' = f false fold_f in let l' = List.map (fun u -> f false u) l in - let ty' = f false ty in - if equal ty ty' && CCList.equal equal l l' then + let acc0' = f false acc0 in + if equal fold_f fold_f' && equal acc0 acc0' && CCList.equal equal l l' then e else - make (E_app_uncurried { c; ty = ty'; args = l' }) + make (E_app_fold { f = fold_f'; args = l'; acc0 = acc0' }) | E_lam (n, tyv, bod) -> let tyv' = f false tyv in let bod' = f true bod in @@ -304,8 +312,9 @@ module Make_ = struct | E_type _ | E_const _ | E_var _ -> 0 | E_bound_var v -> v.bv_idx + 1 | E_app (a, b) -> max (db_depth a) (db_depth b) - | E_app_uncurried { args; _ } -> - List.fold_left (fun x u -> max x (db_depth u)) 0 args + | E_app_fold { f; acc0; args } -> + let m = max (db_depth f) (db_depth acc0) in + List.fold_left (fun x u -> max x (db_depth u)) m args | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> max (db_depth ty) (max 0 (db_depth bod - 1)) in @@ -322,7 +331,8 @@ module Make_ = struct | E_var _ -> true | E_type _ | E_bound_var _ | E_const _ -> false | E_app (a, b) -> has_fvars a || has_fvars b - | E_app_uncurried { args; _ } -> List.exists has_fvars args + | E_app_fold { f; acc0; args } -> + has_fvars f || has_fvars acc0 || List.exists has_fvars args | E_lam (_, ty, bod) | E_pi (_, ty, bod) -> has_fvars ty || has_fvars bod let universe_ (e : term) : int = @@ -450,7 +460,30 @@ module Make_ = struct "@[<2>cannot apply %a@ (to %a),@ must have Pi type, but actual type \ is %a@]" pp_debug f pp_debug a pp_debug ty_f) - | E_app_uncurried { ty; _ } -> ty + | E_app_fold { args = []; _ } -> assert false + | E_app_fold { f; args = a0 :: other_args as args; acc0 } -> + Store.check_e_uid store f; + Store.check_e_uid store acc0; + List.iter (Store.check_e_uid store) args; + let ty_result = ty acc0 in + let ty_a0 = ty a0 in + (* check that all arguments have the same type *) + List.iter + (fun a' -> + let ty' = ty a' in + if not (equal ty_a0 ty') then + Error.errorf + "app_fold: arguments %a@ and %a@ have incompatible types" pp_debug + a0 pp_debug a') + other_args; + (* check that [f a0 acc0] has type [ty_result] *) + let app1 = make (E_app (make (E_app (f, a0)), acc0)) in + if not (equal (ty app1) ty_result) then + Error.errorf + "app_fold: single application `%a`@ has type `%a`,@ but should have \ + type %a" + pp_debug app1 pp_debug (ty app1) pp_debug ty_result; + ty_result | E_pi (_, ty, bod) -> (* TODO: check the actual triplets for COC *) (*Fmt.printf "pi %a %a@." pp_debug ty pp_debug bod;*) @@ -501,8 +534,10 @@ module Make_ = struct let app store f a = make_ store (E_app (f, a)) let app_l store f l = List.fold_left (app store) f l - let app_uncurried store c args ~ty : t = - make_ store (E_app_uncurried { c; args; ty }) + let app_fold store ~f ~acc0 args : t = + match args with + | [] -> acc0 + | _ -> make_ store (E_app_fold { f; acc0; args }) type cache = t T_int_tbl.t diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index c3bc06a7..9bd8ec81 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -32,7 +32,11 @@ type view = term_view = | E_bound_var of bvar | E_const of const | E_app of t * t - | E_app_uncurried of { c: const; ty: term; args: term list } + | E_app_fold of { + f: term; (** function to fold *) + args: term list; (** Arguments to the fold *) + acc0: term; (** initial accumulator *) + } | E_lam of string * t * t | E_pi of string * t * t @@ -118,7 +122,7 @@ val bvar_i : store -> int -> ty:t -> t val const : store -> const -> t val app : store -> t -> t -> t val app_l : store -> t -> t list -> t -val app_uncurried : store -> const -> t list -> ty:t -> t +val app_fold : store -> f:t -> acc0:t -> t list -> t val lam : store -> var -> t -> t val pi : store -> var -> t -> t val arrow : store -> t -> t -> t diff --git a/src/core-logic/types_.ml b/src/core-logic/types_.ml index ac2f7e55..112e4153 100644 --- a/src/core-logic/types_.ml +++ b/src/core-logic/types_.ml @@ -16,7 +16,11 @@ type term_view = | E_bound_var of bvar | E_const of const | E_app of term * term - | E_app_uncurried of { c: const; ty: term; args: term list } + | E_app_fold of { + f: term; (** function to fold *) + args: term list; (** Arguments to the fold *) + acc0: term; (** initial accumulator *) + } | E_lam of string * term * term | E_pi of string * term * term diff --git a/src/core/t_printer.ml b/src/core/t_printer.ml index 92b885ff..6edf27b9 100644 --- a/src/core/t_printer.ml +++ b/src/core/t_printer.ml @@ -49,9 +49,10 @@ let expr_pp_with_ ~max_depth ~hooks out (e : term) : unit = | E_app _ -> let f, args = unfold_app e in Fmt.fprintf out "(%a@ %a)" pp' f (Util.pp_list pp') args - | E_app_uncurried { c; args; ty = _ } -> - Fmt.fprintf out "(@[%a" Const.pp c; + | E_app_fold { f; args; acc0 } -> + Fmt.fprintf out "(@[%a" pp' f; List.iter (fun x -> Fmt.fprintf out "@ %a" pp' x) args; + Fmt.fprintf out "@ %a" pp' acc0; Fmt.fprintf out "@])" | E_lam ("", _ty, bod) -> Fmt.fprintf out "(@[\\_:@[%a@].@ %a@])" pp' _ty diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index bb39457e..72b7eaae 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -114,12 +114,9 @@ end = struct None ) | B_imply (a, b) -> - if is_false a || is_true b then - ret (T.true_ tst) - else if is_true a && is_false b then - ret (T.false_ tst) - else - None + (* always rewrite [a => b] to [¬a \/ b] *) + let u = A.mk_bool tst (B_or [ T.not tst a; b ]) in + ret u | B_ite (a, b, c) -> (* directly simplify [a] so that maybe we never will simplify one of the branches *) From e03e5e77a929caa92ac55b1d0472a116cf2a7e29 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 25 Aug 2022 23:03:12 -0400 Subject: [PATCH 159/174] add LRA_term to base --- src/base/Arith_types_.ml | 139 +++++++++++++++++++------------------- src/base/LRA_term.ml | 63 +++++++++++++++++ src/base/LRA_term.mli | 16 +++++ src/base/Sidekick_base.ml | 1 + 4 files changed, 151 insertions(+), 68 deletions(-) create mode 100644 src/base/LRA_term.ml create mode 100644 src/base/LRA_term.mli diff --git a/src/base/Arith_types_.ml b/src/base/Arith_types_.ml index e244d13d..5691be2c 100644 --- a/src/base/Arith_types_.ml +++ b/src/base/Arith_types_.ml @@ -14,6 +14,8 @@ module LRA_pred = struct | Gt -> ">" | Geq -> ">=" + let equal : t -> t -> bool = ( = ) + let hash : t -> int = Hashtbl.hash let pp out p = Fmt.string out (to_string p) end @@ -24,63 +26,61 @@ module LRA_op = struct | Plus -> "+" | Minus -> "-" + let equal : t -> t -> bool = ( = ) + let hash : t -> int = Hashtbl.hash let pp out p = Fmt.string out (to_string p) end module LRA_view = struct - type 'a t = - | Pred of LRA_pred.t * 'a * 'a - | Op of LRA_op.t * 'a * 'a - | Mult of Q.t * 'a - | Const of Q.t - | Var of 'a - | To_real of 'a + include Sidekick_th_lra + + type 'a t = (Q.t, 'a) lra_view let map ~f_c f (l : _ t) : _ t = match l with - | Pred (p, a, b) -> Pred (p, f a, f b) - | Op (p, a, b) -> Op (p, f a, f b) - | Mult (n, a) -> Mult (f_c n, f a) - | Const c -> Const (f_c c) - | Var x -> Var (f x) - | To_real x -> To_real (f x) + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (f_c n, f a) + | LRA_const c -> LRA_const (f_c c) + | LRA_other x -> LRA_other (f x) let iter f l : unit = match l with - | Pred (_, a, b) | Op (_, a, b) -> + | LRA_pred (_, a, b) | LRA_op (_, a, b) -> f a; f b - | Mult (_, x) | Var x | To_real x -> f x - | Const _ -> () + | LRA_mult (_, x) | LRA_other x -> f x + | LRA_const _ -> () let pp ~pp_t out = function - | Pred (p, a, b) -> + | LRA_pred (p, a, b) -> Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | Op (p, a, b) -> + | LRA_op (p, a, b) -> Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x - | Const q -> Q.pp_print out q - | Var x -> pp_t out x - | To_real x -> Fmt.fprintf out "(@[to_real@ %a@])" pp_t x + | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x + | LRA_const q -> Q.pp_print out q + | LRA_other x -> pp_t out x let hash ~sub_hash = function - | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | Mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) - | Const q -> Hash.combine2 84 (hash_q q) - | Var x -> sub_hash x - | To_real x -> Hash.combine2 85 (sub_hash x) + | LRA_pred (p, a, b) -> + Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_op (p, a, b) -> + Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) + | LRA_const q -> Hash.combine2 84 (hash_q q) + | LRA_other x -> sub_hash x let equal ~sub_eq l1 l2 = match l1, l2 with - | Pred (p1, a1, b1), Pred (p2, a2, b2) -> + | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Op (p1, a1, b1), Op (p2, a2, b2) -> + | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Const a1, Const a2 -> Q.equal a1 a2 - | Mult (n1, x1), Mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 - | Var x1, Var x2 | To_real x1, To_real x2 -> sub_eq x1 x2 - | (Pred _ | Op _ | Const _ | Mult _ | Var _ | To_real _), _ -> false + | LRA_const a1, LRA_const a2 -> Q.equal a1 a2 + | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 + | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 + | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> + false end module LIA_pred = LRA_pred @@ -88,61 +88,64 @@ module LIA_op = LRA_op module LIA_view = struct type 'a t = - | Pred of LIA_pred.t * 'a * 'a - | Op of LIA_op.t * 'a * 'a - | Mult of Z.t * 'a - | Const of Z.t - | Var of 'a + | LRA_pred of LIA_pred.t * 'a * 'a + | LRA_op of LIA_op.t * 'a * 'a + | LRA_mult of Z.t * 'a + | LRA_const of Z.t + | LRA_other of 'a let map ~f_c f (l : _ t) : _ t = match l with - | Pred (p, a, b) -> Pred (p, f a, f b) - | Op (p, a, b) -> Op (p, f a, f b) - | Mult (n, a) -> Mult (f_c n, f a) - | Const c -> Const (f_c c) - | Var x -> Var (f x) + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (f_c n, f a) + | LRA_const c -> LRA_const (f_c c) + | LRA_other x -> LRA_other (f x) let iter f l : unit = match l with - | Pred (_, a, b) | Op (_, a, b) -> + | LRA_pred (_, a, b) | LRA_op (_, a, b) -> f a; f b - | Mult (_, x) | Var x -> f x - | Const _ -> () + | LRA_mult (_, x) | LRA_other x -> f x + | LRA_const _ -> () let pp ~pp_t out = function - | Pred (p, a, b) -> + | LRA_pred (p, a, b) -> Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | Op (p, a, b) -> + | LRA_op (p, a, b) -> Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x - | Const n -> Z.pp_print out n - | Var x -> pp_t out x + | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x + | LRA_const n -> Z.pp_print out n + | LRA_other x -> pp_t out x let hash ~sub_hash = function - | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | Mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) - | Const n -> Hash.combine2 84 (hash_z n) - | Var x -> sub_hash x + | LRA_pred (p, a, b) -> + Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_op (p, a, b) -> + Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) + | LRA_const n -> Hash.combine2 84 (hash_z n) + | LRA_other x -> sub_hash x let equal ~sub_eq l1 l2 = match l1, l2 with - | Pred (p1, a1, b1), Pred (p2, a2, b2) -> + | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Op (p1, a1, b1), Op (p2, a2, b2) -> + | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Const a1, Const a2 -> Z.equal a1 a2 - | Mult (n1, x1), Mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 - | Var x1, Var x2 -> sub_eq x1 x2 - | (Pred _ | Op _ | Const _ | Mult _ | Var _), _ -> false + | LRA_const a1, LRA_const a2 -> Z.equal a1 a2 + | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 + | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 + | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> + false (* convert the whole structure to reals *) let to_lra f l : _ LRA_view.t = match l with - | Pred (p, a, b) -> LRA_view.Pred (p, f a, f b) - | Op (op, a, b) -> LRA_view.Op (op, f a, f b) - | Mult (c, x) -> LRA_view.Mult (Q.of_bigint c, f x) - | Const x -> LRA_view.Const (Q.of_bigint x) - | Var v -> LRA_view.Var (f v) + | LRA_pred (p, a, b) -> LRA_view.LRA_pred (p, f a, f b) + | LRA_op (op, a, b) -> LRA_view.LRA_op (op, f a, f b) + | LRA_mult (c, x) -> LRA_view.LRA_mult (Q.of_bigint c, f x) + | LRA_const x -> LRA_view.LRA_const (Q.of_bigint x) + | LRA_other v -> LRA_view.LRA_other (f v) end diff --git a/src/base/LRA_term.ml b/src/base/LRA_term.ml new file mode 100644 index 00000000..eea25db2 --- /dev/null +++ b/src/base/LRA_term.ml @@ -0,0 +1,63 @@ +open Sidekick_core +module Pred = Arith_types_.LRA_pred +module Op = Arith_types_.LRA_op +module View = Arith_types_.LRA_view +module T = Term + +type term = Term.t +type ty = Term.t +type Const.view += Const of Q.t | Pred of Pred.t | Op of Op.t | Mult_by of Q.t + +let ops : Const.ops = + (module struct + let pp out = function + | Const q -> Q.pp_print out q + | Pred p -> Pred.pp out p + | Op o -> Op.pp out o + | Mult_by q -> Fmt.fprintf out "(* %a)" Q.pp_print q + | _ -> assert false + + let equal a b = + match a, b with + | Const a, Const b -> Q.equal a b + | Pred a, Pred b -> Pred.equal a b + | Op a, Op b -> Op.equal a b + | Mult_by a, Mult_by b -> Q.equal a b + | _ -> false + + let hash = function + | Const q -> Sidekick_zarith.Rational.hash q + | Pred p -> Pred.hash p + | Op o -> Op.hash o + | Mult_by q -> Hash.(combine2 135 (Sidekick_zarith.Rational.hash q)) + | _ -> assert false + end) + +let real tst = Ty.real tst + +let const tst q : term = + Term.const tst (Const.make (Const q) ops ~ty:(real tst)) + +let mult_by tst q t : term = + let ty_c = Term.arrow tst (real tst) (real tst) in + let c = Term.const tst (Const.make (Mult_by q) ops ~ty:ty_c) in + Term.app tst c t + +let pred tst p t1 t2 : term = + let ty = Term.(arrow_l tst [ real tst; real tst ] (Term.bool tst)) in + let p = Term.const tst (Const.make (Pred p) ops ~ty) in + Term.app_l tst p [ t1; t2 ] + +let op tst op t1 t2 : term = + let ty = Term.(arrow_l tst [ real tst; real tst ] (real tst)) in + let p = Term.const tst (Const.make (Op op) ops ~ty) in + Term.app_l tst p [ t1; t2 ] + +let view (t : term) : _ View.t = + let f, args = Term.unfold_app t in + match T.view f, args with + | T.E_const { Const.c_view = Const q; _ }, [] -> View.LRA_const q + | T.E_const { Const.c_view = Pred p; _ }, [ a; b ] -> View.LRA_pred (p, a, b) + | T.E_const { Const.c_view = Op op; _ }, [ a; b ] -> View.LRA_op (op, a, b) + | T.E_const { Const.c_view = Mult_by q; _ }, [ a ] -> View.LRA_mult (q, a) + | _ -> View.LRA_other t diff --git a/src/base/LRA_term.mli b/src/base/LRA_term.mli new file mode 100644 index 00000000..396f3b8c --- /dev/null +++ b/src/base/LRA_term.mli @@ -0,0 +1,16 @@ +open Sidekick_core +module Pred = Arith_types_.LRA_pred +module Op = Arith_types_.LRA_op +module View = Arith_types_.LRA_view + +type term = Term.t +type ty = Term.t + +val real : Term.store -> ty +val pred : Term.store -> Pred.t -> term -> term -> term +val mult_by : Term.store -> Q.t -> term -> term +val op : Term.store -> Op.t -> term -> term -> term +val const : Term.store -> Q.t -> term + +val view : term -> term View.t +(** View as LRA *) diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index e13f4026..d0b03630 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -30,6 +30,7 @@ module Statement = Statement module Solver = Solver module Uconst = Uconst module Config = Config +module LRA_term = LRA_term module Th_data = Th_data module Th_bool = Th_bool (* FIXME From e66a27229b94af94512e205e26f73931c1d25ead Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 26 Aug 2022 22:16:45 -0400 Subject: [PATCH 160/174] detail in printing --- src/smtlib/Process.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index fd072a0d..b530f465 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -195,7 +195,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) ); *) let t3 = Sys.time () in - Fmt.printf "@.sat@."; + Fmt.printf "sat@."; Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unsat { unsat_step_id; unsat_core = _ } -> if check then @@ -228,7 +228,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) | _ -> ()); let t3 = Sys.time () in - Fmt.printf "@.unsat@."; + Fmt.printf "unsat@."; Fmt.printf "; (%.3f/%.3f/%.3f)@." (t1 -. start) (t2 -. t1) (t3 -. t2) | Solver.Unknown reas -> Fmt.printf "unknown@."; From f0041f9daee80ec94286a0eacf13688b6e6123b3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Fri, 26 Aug 2022 22:17:02 -0400 Subject: [PATCH 161/174] feat: reinstate LRA theory and terms --- src/base/Form.ml | 4 - src/base/LRA_term.ml | 10 ++ src/base/LRA_term.mli | 3 + src/base/Sidekick_base.ml | 28 +---- src/base/th_lra.ml | 61 +++------- src/main/main.ml | 3 +- src/smtlib/Process.ml | 8 +- src/smtlib/Process.mli | 4 +- src/smtlib/Typecheck.ml | 199 ++++++++++++++++++--------------- src/th-lra/intf.ml | 16 +-- src/th-lra/proof_rules.ml | 3 + src/th-lra/proof_rules.mli | 5 + src/th-lra/sidekick_th_lra.ml | 50 +++++---- src/th-lra/sidekick_th_lra.mli | 26 ++++- 14 files changed, 207 insertions(+), 213 deletions(-) create mode 100644 src/th-lra/proof_rules.ml create mode 100644 src/th-lra/proof_rules.mli diff --git a/src/base/Form.ml b/src/base/Form.ml index 6173d171..2bfa3788 100644 --- a/src/base/Form.ml +++ b/src/base/Form.ml @@ -1,8 +1,6 @@ -open Types_ open Sidekick_core module T = Term -type ty = Term.t type term = Term.t type 'a view = 'a Sidekick_core.Bool_view.t = @@ -42,8 +40,6 @@ let ops : Const.ops = (* ### view *) -exception Not_a_th_term - let view (t : T.t) : T.t view = let hd, args = T.unfold_app t in match T.view hd, args with diff --git a/src/base/LRA_term.ml b/src/base/LRA_term.ml index eea25db2..c7b3c7ec 100644 --- a/src/base/LRA_term.ml +++ b/src/base/LRA_term.ml @@ -34,6 +34,7 @@ let ops : Const.ops = end) let real tst = Ty.real tst +let has_ty_real t = Ty.is_real (T.ty t) let const tst q : term = Term.const tst (Const.make (Const q) ops ~ty:(real tst)) @@ -56,8 +57,17 @@ let op tst op t1 t2 : term = let view (t : term) : _ View.t = let f, args = Term.unfold_app t in match T.view f, args with + | T.E_const { Const.c_view = T.C_eq; _ }, [ _; a; b ] when has_ty_real a -> + View.LRA_pred (Pred.Eq, a, b) | T.E_const { Const.c_view = Const q; _ }, [] -> View.LRA_const q | T.E_const { Const.c_view = Pred p; _ }, [ a; b ] -> View.LRA_pred (p, a, b) | T.E_const { Const.c_view = Op op; _ }, [ a; b ] -> View.LRA_op (op, a, b) | T.E_const { Const.c_view = Mult_by q; _ }, [ a ] -> View.LRA_mult (q, a) | _ -> View.LRA_other t + +let term_of_view store = function + | View.LRA_const q -> const store q + | View.LRA_mult (n, t) -> mult_by store n t + | View.LRA_pred (p, a, b) -> pred store p a b + | View.LRA_op (o, a, b) -> op store o a b + | View.LRA_other x -> x diff --git a/src/base/LRA_term.mli b/src/base/LRA_term.mli index 396f3b8c..a6f7b5d3 100644 --- a/src/base/LRA_term.mli +++ b/src/base/LRA_term.mli @@ -7,6 +7,7 @@ type term = Term.t type ty = Term.t val real : Term.store -> ty +val has_ty_real : term -> bool val pred : Term.store -> Pred.t -> term -> term -> term val mult_by : Term.store -> Q.t -> term -> term val op : Term.store -> Op.t -> term -> term -> term @@ -14,3 +15,5 @@ val const : Term.store -> Q.t -> term val view : term -> term View.t (** View as LRA *) + +val term_of_view : Term.store -> term View.t -> term diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index d0b03630..6ce130f6 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -33,35 +33,11 @@ module Config = Config module LRA_term = LRA_term module Th_data = Th_data module Th_bool = Th_bool -(* FIXME - module Th_lra = Th_lra -*) +module Th_lra = Th_lra let k_th_bool_config = Th_bool.k_config let th_bool = Th_bool.theory let th_bool_dyn : Solver.theory = Th_bool.theory_dyn let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory - -(* FIXME - let th_lra : Solver.theory = Th_lra.theory -*) - -(* TODO - - module Value = Value - module Statement = Statement - module Data = Data - module Select = Select - - module LRA_view = Types_.LRA_view - module LRA_pred = Base_types.LRA_pred - module LRA_op = Base_types.LRA_op - module LIA_view = Base_types.LIA_view - module LIA_pred = Base_types.LIA_pred - module LIA_op = Base_types.LIA_op -*) - -(* -module Proof_quip = Proof_quip -*) +let th_lra : Solver.theory = Th_lra.theory diff --git a/src/base/th_lra.ml b/src/base/th_lra.ml index 29e29d19..933b482e 100644 --- a/src/base/th_lra.ml +++ b/src/base/th_lra.ml @@ -1,48 +1,21 @@ -(* TODO +(** Theory of Linear Rational Arithmetic *) +open Sidekick_core +module T = Term +module Q = Sidekick_zarith.Rational +open LRA_term - (** Theory of Linear Rational Arithmetic *) - module Th_lra = Sidekick_arith_lra.Make (struct - module S = Solver - module T = Term - module Z = Sidekick_zarith.Int - module Q = Sidekick_zarith.Rational +let mk_eq = Form.eq +let mk_bool = T.bool - type term = S.T.Term.t - type ty = S.T.Ty.t +let theory : Solver.theory = + Sidekick_th_lra.theory + (module struct + module Z = Sidekick_zarith.Int + module Q = Sidekick_zarith.Rational - module LRA = Sidekick_arith_lra - - let mk_eq = Form.eq - - let mk_lra store l = - match l with - | LRA.LRA_other x -> x - | LRA.LRA_pred (p, x, y) -> T.lra store (Pred (p, x, y)) - | LRA.LRA_op (op, x, y) -> T.lra store (Op (op, x, y)) - | LRA.LRA_const c -> T.lra store (Const c) - | LRA.LRA_mult (c, x) -> T.lra store (Mult (c, x)) - - let mk_bool = T.bool - - let rec view_as_lra t = - match T.view t with - | T.LRA l -> - let module LRA = Sidekick_arith_lra in - (match l with - | Const c -> LRA.LRA_const c - | Pred (p, a, b) -> LRA.LRA_pred (p, a, b) - | Op (op, a, b) -> LRA.LRA_op (op, a, b) - | Mult (c, x) -> LRA.LRA_mult (c, x) - | To_real x -> view_as_lra x - | Var x -> LRA.LRA_other x) - | T.Eq (a, b) when Ty.equal (T.ty a) (Ty.real ()) -> LRA.LRA_pred (Eq, a, b) - | _ -> LRA.LRA_other t - - let ty_lra _st = Ty.real () - let has_ty_real t = Ty.equal (T.ty t) (Ty.real ()) - let lemma_lra = Proof.lemma_lra - - module Gensym = Gensym - end) -*) + let ty_real = LRA_term.real + let has_ty_real = LRA_term.has_ty_real + let view_as_lra = LRA_term.view + let mk_lra = LRA_term.term_of_view + end : Sidekick_th_lra.ARG) diff --git a/src/main/main.ml b/src/main/main.ml index 769ec595..679e4d8d 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -178,8 +178,7 @@ let main_smt ~config () : _ result = Log.debugf 1 (fun k -> k "(@[main.th-bool.pick@ %S@])" (Sidekick_smt_solver.Theory.name th_bool)); - Sidekick_smt_solver.Theory. - [ th_bool; Process.th_data (* FIXME Process.th_lra *) ] + Sidekick_smt_solver.Theory.[ th_bool; Process.th_data; Process.th_lra ] in Process.Solver.create_default ~proof ~theories tst in diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index b530f465..1dea0d39 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -338,14 +338,10 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model module Th_data = Sidekick_base.Th_data module Th_bool = Sidekick_base.Th_bool -(* FIXME - module Th_lra = Sidekick_base.Th_lra -*) +module Th_lra = Sidekick_base.Th_lra let th_bool = Th_bool.theory let th_bool_dyn : Solver.theory = Th_bool.theory_dyn let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory -(* FIXME - let th_lra : Solver.theory = Th_lra.theory -*) +let th_lra : Solver.theory = Th_lra.theory diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index 25e83add..2046c224 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -7,9 +7,7 @@ val th_bool_dyn : Solver.theory val th_bool_static : Solver.theory val th_bool : Config.t -> Solver.theory val th_data : Solver.theory -(* FIXME - val th_lra : Solver.theory -*) +val th_lra : Solver.theory type 'a or_error = ('a, string) CCResult.t diff --git a/src/smtlib/Typecheck.ml b/src/smtlib/Typecheck.ml index 7322b604..46ef5259 100644 --- a/src/smtlib/Typecheck.ml +++ b/src/smtlib/Typecheck.ml @@ -113,59 +113,84 @@ let string_as_q (s : string) : Q.t option = Some x with _ -> None -(* TODO - let t_as_q t = - match Term.view t with - | T.LRA (Const n) -> Some n - | T.LIA (Const n) -> Some (Q.of_bigint n) - | _ -> None +let t_as_q t = + match LRA_term.view t with + | LRA_term.View.LRA_const n -> Some n + (* + | T.LIA (Const n) -> Some (Q.of_bigint n) + *) + | _ -> None +(* TODO let t_as_z t = match Term.view t with | T.LIA (Const n) -> Some n | _ -> None +*) - let is_real = Ty.is_real +let is_real = Ty.is_real - (* convert [t] to a real term *) - let cast_to_real (ctx : Ctx.t) (t : T.t) : T.t = - let rec conv t = - match T.view t with - | T.LRA _ -> t - | _ when Ty.equal (T.ty t) (Ty.real ()) -> t +(* convert [t] to a real term *) +let cast_to_real (ctx : Ctx.t) (t : T.t) : T.t = + let conv t = + match T.view t with + | _ when Ty.is_real (T.ty t) -> t + (* FIXME | T.LIA (Const n) -> T.lra ctx.tst (Const (Q.of_bigint n)) | T.LIA l -> (* convert the whole structure to reals *) let l = LIA_view.to_lra conv l in T.lra ctx.tst l | T.Ite (a, b, c) -> T.ite ctx.tst a (conv b) (conv c) - | _ -> errorf_ctx ctx "cannot cast term to real@ :term %a" T.pp t - in - conv t + *) + | _ -> errorf_ctx ctx "cannot cast term to real@ :term %a" T.pp t + in + conv t - let conv_arith_op (ctx : Ctx.t) t (op : PA.arith_op) (l : T.t list) : T.t = - let tst = ctx.Ctx.tst in +let conv_arith_op (ctx : Ctx.t) (t : PA.term) (op : PA.arith_op) (l : T.t list) + : T.t = + let tst = ctx.Ctx.tst in - let mk_pred p a b = + let mk_pred p a b = + LRA_term.pred tst p (cast_to_real ctx a) (cast_to_real ctx b) + (* TODO + if is_real a || is_real b then + LRA_term.pred tst p (cast_to_real ctx a) (cast_to_real ctx b) + else + Error.errorf "cannot handle LIA term %a" PA.pp_term t + T.lia tst (Pred (p, a, b)) + *) + and mk_op o a b = + LRA_term.op tst o (cast_to_real ctx a) (cast_to_real ctx b) + (* TODO if is_real a || is_real b then - T.lra tst (Pred (p, cast_to_real ctx a, cast_to_real ctx b)) + LRA_term.op tst o (cast_to_real ctx a) (cast_to_real ctx b) else - T.lia tst (Pred (p, a, b)) - and mk_op o a b = - if is_real a || is_real b then - T.lra tst (Op (o, cast_to_real ctx a, cast_to_real ctx b)) - else - T.lia tst (Op (o, a, b)) - in + Error.errorf "cannot handle LIA term %a" PA.pp_term t + T.lia tst (Op (o, a, b)) + *) + in - match op, l with - | PA.Leq, [ a; b ] -> mk_pred Leq a b - | PA.Lt, [ a; b ] -> mk_pred Lt a b - | PA.Geq, [ a; b ] -> mk_pred Geq a b - | PA.Gt, [ a; b ] -> mk_pred Gt a b - | PA.Add, [ a; b ] -> mk_op Plus a b - | PA.Add, a :: l -> List.fold_left (fun a b -> mk_op Plus a b) a l - | PA.Minus, [ a ] -> + match op, l with + | PA.Leq, [ a; b ] -> mk_pred Leq a b + | PA.Lt, [ a; b ] -> mk_pred Lt a b + | PA.Geq, [ a; b ] -> mk_pred Geq a b + | PA.Gt, [ a; b ] -> mk_pred Gt a b + | PA.Add, [ a; b ] -> mk_op Plus a b + | PA.Add, a :: l -> List.fold_left (fun a b -> mk_op Plus a b) a l + | PA.Minus, [ a ] -> + (match t_as_q a with + | Some q -> LRA_term.const tst (Q.neg q) + | None -> + let zero = + if is_real a then + LRA_term.const tst Q.zero + else + Error.errorf "cannot handle non-rat %a" PA.pp_term t + (* T.lia tst (Const Z.zero) *) + in + mk_op Minus zero a) + (* (match t_as_q a, t_as_z a with | _, Some n -> T.lia tst (Const (Z.neg n)) | Some q, None -> T.lra tst (Const (Q.neg q)) @@ -176,57 +201,52 @@ let string_as_q (s : string) : Q.t option = else T.lia tst (Const Z.zero) in - mk_op Minus zero a) - | PA.Minus, [ a; b ] -> mk_op Minus a b - | PA.Minus, a :: l -> List.fold_left (fun a b -> mk_op Minus a b) a l - | PA.Mult, [ a; b ] when is_real a || is_real b -> - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.mul a b)) - | Some a, _ -> T.lra tst (Mult (a, b)) - | _, Some b -> T.lra tst (Mult (b, a)) - | None, None -> - errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) - | PA.Mult, [ a; b ] -> - (match t_as_z a, t_as_z b with - | Some a, Some b -> T.lia tst (Const (Z.mul a b)) - | Some a, _ -> T.lia tst (Mult (a, b)) - | _, Some b -> T.lia tst (Mult (b, a)) - | None, None -> - errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) - | PA.Div, [ a; b ] when is_real a || is_real b -> - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.div a b)) - | _, Some b -> T.lra tst (Mult (Q.inv b, a)) - | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) - | PA.Div, [ a; b ] -> - (* becomes a real *) - (match t_as_q a, t_as_q b with - | Some a, Some b -> T.lra tst (Const (Q.div a b)) - | _, Some b -> - let a = cast_to_real ctx a in - T.lra tst (Mult (Q.inv b, a)) - | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) - | _ -> errorf_ctx ctx "cannot handle arith construct %a" PA.pp_term t -*) + *) + | PA.Minus, [ a; b ] -> mk_op Minus a b + | PA.Minus, a :: l -> List.fold_left (fun a b -> mk_op Minus a b) a l + | PA.Mult, [ a; b ] -> + (match t_as_q a, t_as_q b with + | Some a, Some b -> LRA_term.const tst (Q.mul a b) + | Some a, _ -> LRA_term.mult_by tst a b + | _, Some b -> LRA_term.mult_by tst b a + | None, None -> + errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) + (* TODO + | PA.Mult, [ _a; _b ] -> + (match t_as_z a, t_as_z b with + | Some a, Some b -> T.lia tst (Const (Z.mul a b)) + | Some a, _ -> T.lia tst (Mult (a, b)) + | _, Some b -> T.lia tst (Mult (b, a)) + | None, None -> + errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t) + errorf_ctx ctx "cannot handle non-linear mult %a" PA.pp_term t + *) + | PA.Div, [ a; b ] -> + (match t_as_q a, t_as_q b with + | Some a, Some b -> LRA_term.const tst (Q.div a b) + | _, Some b -> + let a = cast_to_real ctx a in + LRA_term.mult_by tst (Q.inv b) a + | _, None -> errorf_ctx ctx "cannot handle non-linear div %a" PA.pp_term t) + | _ -> errorf_ctx ctx "cannot handle arith construct %a" PA.pp_term t (* conversion of terms *) let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = let tst = ctx.Ctx.tst in match t with | PA.True -> T.true_ tst - | PA.False -> - T.false_ tst - (* FIXME - | PA.Const s when is_num s -> - (match string_as_z s, ctx.default_num with - | Some n, `Int -> T.lia tst (Const n) - | Some n, `Real -> T.lra tst (Const (Q.of_bigint n)) - | None, _ -> - (match string_as_q s with - | Some n -> T.lra tst (Const n) - | None -> errorf_ctx ctx "expected a number for %a" PA.pp_term t)) - *) + | PA.False -> T.false_ tst + | PA.Const s when is_num s -> + (match string_as_z s, ctx.default_num with + | Some n, `Real -> LRA_term.const tst (Q.of_bigint n) + | Some n, `Int -> + Error.errorf "cannot handle integer constant %a yet" Z.pp_print n + (* TODO T.lia tst (Const n) *) + | None, _ -> + (match string_as_q s with + | Some n -> LRA_term.const tst n + | None -> errorf_ctx ctx "expected a number for %a" PA.pp_term t)) | PA.Const f | PA.App (f, []) -> (* lookup in `let` table, then in type defs *) (match StrTbl.find ctx.Ctx.lets f with @@ -276,12 +296,12 @@ let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = | PA.Eq (a, b) -> let a = conv_term ctx a in let b = conv_term ctx b in - (* FIXME - if is_real a || is_real b then - Form.eq tst (cast_to_real ctx a) (cast_to_real ctx b) - else - *) - Form.eq tst a b + if is_real a || is_real b then + (* Form.eq tst (cast_to_real ctx a) (cast_to_real ctx b) *) + LRA_term.pred tst LRA_term.Pred.Eq (cast_to_real ctx a) + (cast_to_real ctx b) + else + Form.eq tst a b | PA.Imply (a, b) -> let a = conv_term ctx a in let b = conv_term ctx b in @@ -371,12 +391,9 @@ let rec conv_term (ctx : Ctx.t) (t : PA.term) : T.t = in A.match_ lhs cases *) - - (* FIXME - | PA.Arith (op, l) -> - let l = List.map (conv_term ctx) l in - conv_arith_op ctx t op l - *) + | PA.Arith (op, l) -> + let l = List.map (conv_term ctx) l in + conv_arith_op ctx t op l | PA.Cast (t, ty_expect) -> let t = conv_term ctx t in let ty_expect = conv_ty ctx ty_expect in diff --git a/src/th-lra/intf.ml b/src/th-lra/intf.ml index d1cdc516..5e3f5672 100644 --- a/src/th-lra/intf.ml +++ b/src/th-lra/intf.ml @@ -39,21 +39,9 @@ module type ARG = sig val mk_lra : Term.store -> (Q.t, Term.t) lra_view -> Term.t (** Make a Term.t from the given theory view *) - val ty_lra : Term.store -> ty + val ty_real : Term.store -> ty + (** Build the type Q *) val has_ty_real : Term.t -> bool (** Does this term have the type [Real] *) - - val lemma_lra : Lit.t list -> Proof_term.t - - module Gensym : sig - type t - - val create : Term.store -> t - val tst : t -> Term.store - val copy : t -> t - - val fresh_term : t -> pre:string -> ty -> term - (** Make a fresh term of the given type *) - end end diff --git a/src/th-lra/proof_rules.ml b/src/th-lra/proof_rules.ml new file mode 100644 index 00000000..72087162 --- /dev/null +++ b/src/th-lra/proof_rules.ml @@ -0,0 +1,3 @@ +open Sidekick_core + +let lemma_lra lits : Proof_term.t = Proof_term.apply_rule "lra.lemma" ~lits diff --git a/src/th-lra/proof_rules.mli b/src/th-lra/proof_rules.mli new file mode 100644 index 00000000..26a2688a --- /dev/null +++ b/src/th-lra/proof_rules.mli @@ -0,0 +1,5 @@ +open Sidekick_core + +val lemma_lra : Lit.t list -> Proof_term.t +(** List of literals [l1…ln] where [¬l1 /\ … /\ ¬ln] is LRA-unsat *) + diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index ec9f9188..918466d0 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -126,7 +126,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct type state = { tst: Term.store; proof: Proof_trace.t; - gensym: A.Gensym.t; + gensym: Gensym.t; in_model: unit Term.Tbl.t; (* terms to add to model *) encoded_eqs: unit Term.Tbl.t; (* [a=b] gets clause [a = b <=> (a >= b /\ a <= b)] *) @@ -140,6 +140,8 @@ module Make (A : ARG) = (* : S with module A = A *) struct mutable encoded_le: Term.t Comb_map.t; (* [le] -> var encoding [le] *) simplex: SimpSolver.t; mutable last_res: SimpSolver.result option; + n_propagate: int Stat.counter; + n_conflict: int Stat.counter; } let create (si : SI.t) : state = @@ -151,7 +153,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct proof; in_model = Term.Tbl.create 8; st_exprs = ST_exprs.create_and_setup (SI.cc si); - gensym = A.Gensym.create tst; + gensym = Gensym.create tst; simp_preds = Term.Tbl.create 32; simp_defined = Term.Tbl.create 16; encoded_eqs = Term.Tbl.create 8; @@ -159,6 +161,8 @@ module Make (A : ARG) = (* : S with module A = A *) struct encoded_le = Comb_map.empty; simplex = SimpSolver.create ~stat (); last_res = None; + n_propagate = Stat.mk_int stat "th.lra.propagate"; + n_conflict = Stat.mk_int stat "th.lra.conflicts"; } let[@inline] reset_res_ (self : state) : unit = self.last_res <- None @@ -175,7 +179,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct SimpSolver.pop_levels self.simplex n; () - let fresh_term self ~pre ty = A.Gensym.fresh_term self.gensym ~pre ty + let fresh_term self ~pre ty = Gensym.fresh_term self.gensym ~pre ty let fresh_lit (self : state) ~mk_lit ~pre : Lit.t = let t = fresh_term ~pre self (Term.bool self.tst) in @@ -239,7 +243,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct | x -> x (* already encoded that *) | exception Not_found -> (* new variable to represent [le_comb] *) - let proxy = fresh_term self ~pre (A.ty_lra self.tst) in + let proxy = fresh_term self ~pre (A.ty_real self.tst) in (* TODO: define proxy *) self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; Log.debugf 50 (fun k -> @@ -251,7 +255,9 @@ module Make (A : ARG) = (* : S with module A = A *) struct proxy) let add_clause_lra_ ?using (module PA : SI.PREPROCESS_ACTS) lits = - let pr = Proof_trace.add_step PA.proof @@ fun () -> A.lemma_lra lits in + let pr = + Proof_trace.add_step PA.proof @@ fun () -> Proof_rules.lemma_lra lits + in let pr = match using with | None -> pr @@ -281,7 +287,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct (match Comb_map.get le_comb self.encoded_le with | Some x -> x, A.Q.one (* already encoded that *) | None -> - let proxy = fresh_term self ~pre:"_le_comb" (A.ty_lra self.tst) in + let proxy = fresh_term self ~pre:"_le_comb" (A.ty_real self.tst) in self.encoded_le <- Comb_map.add le_comb proxy self.encoded_le; LE_.Comb.iter (fun v _ -> SimpSolver.add_var self.simplex v) le_comb; @@ -400,11 +406,11 @@ module Make (A : ARG) = (* : S with module A = A *) struct (Term.t * Proof_step.id Iter.t) option = let proof_eq t u = Proof_trace.add_step self.proof @@ fun () -> - A.lemma_lra [ Lit.atom self.tst (Term.eq self.tst t u) ] + Proof_rules.lemma_lra [ Lit.atom self.tst (Term.eq self.tst t u) ] in let proof_bool t ~sign:b = let lit = Lit.atom ~sign:b self.tst t in - Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] + Proof_trace.add_step self.proof @@ fun () -> Proof_rules.lemma_lra [ lit ] in match A.view_as_lra t with @@ -462,7 +468,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct | _ -> None (* raise conflict from certificate *) - let fail_with_cert si acts cert : 'a = + let fail_with_cert (self : state) si acts cert : 'a = Profile.with1 "lra.simplex.check-cert" SimpSolver._check_cert cert; let confl = SimpSolver.Unsat_cert.lits cert @@ -470,19 +476,22 @@ module Make (A : ARG) = (* : S with module A = A *) struct |> List.rev_map Lit.neg in let pr = - Proof_trace.add_step (SI.proof si) @@ fun () -> A.lemma_lra confl + Proof_trace.add_step (SI.proof si) @@ fun () -> + Proof_rules.lemma_lra confl in + Stat.incr self.n_conflict; SI.raise_conflict si acts confl pr - let on_propagate_ si acts lit ~reason = + let on_propagate_ self si acts lit ~reason = match lit with | Tag.Lit lit -> (* TODO: more detailed proof certificate *) + Stat.incr self.n_propagate; SI.propagate si acts lit ~reason:(fun () -> let lits = CCList.flat_map (Tag.to_lits si) reason in let pr = Proof_trace.add_step (SI.proof si) @@ fun () -> - A.lemma_lra (lit :: lits) + Proof_rules.lemma_lra (lit :: lits) in CCList.flat_map (Tag.to_lits si) reason, pr) | _ -> () @@ -495,7 +504,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct (SimpSolver.n_rows self.simplex)); let res = Profile.with_ "lra.simplex.solve" @@ fun () -> - SimpSolver.check self.simplex ~on_propagate:(on_propagate_ si acts) + SimpSolver.check self.simplex ~on_propagate:(on_propagate_ self si acts) in Log.debug 5 "(lra.check-simplex.done)"; self.last_res <- Some res; @@ -504,7 +513,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct | SimpSolver.Unsat cert -> Log.debugf 10 (fun k -> k "(@[lra.check.unsat@ :cert %a@])" SimpSolver.Unsat_cert.pp cert); - fail_with_cert si acts cert + fail_with_cert self si acts cert (* TODO: trivial propagations *) @@ -528,7 +537,8 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* [c=0] when [c] is not 0 *) let lit = Lit.atom ~sign:false self.tst @@ Term.eq self.tst t1 t2 in let pr = - Proof_trace.add_step self.proof @@ fun () -> A.lemma_lra [ lit ] + Proof_trace.add_step self.proof @@ fun () -> + Proof_rules.lemma_lra [ lit ] in SI.add_clause_permanent si acts [ lit ] pr ) @@ -537,11 +547,11 @@ module Make (A : ARG) = (* : S with module A = A *) struct try let c1 = SimpSolver.Constraint.geq v le_const in SimpSolver.add_constraint self.simplex c1 tag - ~on_propagate:(on_propagate_ si acts); + ~on_propagate:(on_propagate_ self si acts); let c2 = SimpSolver.Constraint.leq v le_const in SimpSolver.add_constraint self.simplex c2 tag - ~on_propagate:(on_propagate_ si acts) - with SimpSolver.E_unsat cert -> fail_with_cert si acts cert + ~on_propagate:(on_propagate_ self si acts) + with SimpSolver.E_unsat cert -> fail_with_cert self si acts cert ) let add_local_eq (self : state) si acts n1 n2 : unit = @@ -627,12 +637,12 @@ module Make (A : ARG) = (* : S with module A = A *) struct (try SimpSolver.add_var self.simplex v; SimpSolver.add_constraint self.simplex constr (Tag.Lit lit) - ~on_propagate:(on_propagate_ si acts) + ~on_propagate:(on_propagate_ self si acts) with SimpSolver.E_unsat cert -> Log.debugf 10 (fun k -> k "(@[lra.partial-check.unsat@ :cert %a@])" SimpSolver.Unsat_cert.pp cert); - fail_with_cert si acts cert) + fail_with_cert self si acts cert) | None, LRA_pred (Eq, t1, t2) when sign -> add_local_eq_t self si acts t1 t2 ~tag:(Tag.Lit lit) | None, LRA_pred (Neq, t1, t2) when not sign -> diff --git a/src/th-lra/sidekick_th_lra.mli b/src/th-lra/sidekick_th_lra.mli index 11ee0b4c..3f7d897e 100644 --- a/src/th-lra/sidekick_th_lra.mli +++ b/src/th-lra/sidekick_th_lra.mli @@ -1,10 +1,30 @@ (** Linear Rational Arithmetic *) +open Sidekick_core module Intf = Intf +module Predicate = Intf.Predicate +module SMT = Sidekick_smt_solver -include module type of struct - include Intf -end +module type INT = Intf.INT +module type RATIONAL = Intf.RATIONAL + +module S_op = Sidekick_simplex.Op + +type term = Term.t +type ty = Term.t +type pred = Intf.pred = Leq | Geq | Lt | Gt | Eq | Neq +type op = Intf.op = Plus | Minus + +type ('num, 'a) lra_view = ('num, 'a) Intf.lra_view = + | LRA_pred of pred * 'a * 'a + | LRA_op of op * 'a * 'a + | LRA_mult of 'num * 'a + | LRA_const of 'num + | LRA_other of 'a + +val map_view : ('a -> 'b) -> ('c, 'a) lra_view -> ('c, 'b) lra_view + +module type ARG = Intf.ARG (* TODO type state From 5f91d0bd7694a3f7030486a7aa7a034175f11edc Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 12:36:45 -0400 Subject: [PATCH 162/174] fix spurious \r --- src/main/main.ml | 3 +-- src/smtlib/Process.ml | 5 ++--- 2 files changed, 3 insertions(+), 5 deletions(-) diff --git a/src/main/main.ml b/src/main/main.ml index 679e4d8d..a89c47f0 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -33,7 +33,6 @@ let p_progress = ref false let proof_file = ref "" let proof_store_memory = ref false let proof_store_file = ref "" -let reset_line = "\x1b[2K\r" (* Arguments parsing *) let int_arg r arg = @@ -184,7 +183,7 @@ let main_smt ~config () : _ result = in let finally () = - if !p_stat then Format.printf "%s%a@." reset_line Solver.pp_stats solver + if !p_stat then Format.printf "%a@." Solver.pp_stats solver in CCFun.protect ~finally @@ fun () -> (* FIXME: emit an actual proof *) diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 1dea0d39..57f2b3f6 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -152,7 +152,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) Some (mk_progress s) else None - in + and clear_line () = if progress then Printf.printf "%s%!" reset_line in let should_stop = match time, memory with @@ -181,7 +181,6 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) (* ?gc ?restarts ?time ?memory ?progress *) in let t2 = Sys.time () in - Printf.printf "\r"; flush stdout; (match res with | Solver.Sat m -> @@ -234,7 +233,7 @@ let solve ?gc:_ ?restarts:_ ?proof_file ?(pp_model = false) ?(check = false) Fmt.printf "unknown@."; Fmt.printf "; @[:reason %a@]@." Solver.Unknown.pp reas | exception exn -> - Printf.printf "%s%!" reset_line; + clear_line (); raise exn); res From 90f100d9b178533b09614f6239d8c3f4a29ee079 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 15:01:25 -0400 Subject: [PATCH 163/174] helpers to build terms and solvers --- src/base/ID.ml | 3 ++- src/base/ID.mli | 1 + src/base/LRA_term.ml | 10 ++++++++++ src/base/LRA_term.mli | 16 ++++++++++++++-- src/base/Ty.ml | 2 ++ src/base/Ty.mli | 1 + src/base/Uconst.ml | 3 +++ src/base/Uconst.mli | 1 + src/core-logic/term.ml | 1 + src/core-logic/term.mli | 1 + src/core/default_cc_view.ml | 3 ++- src/smt/solver.ml | 9 +++++++++ src/smt/solver.mli | 12 ++++++++++++ 13 files changed, 59 insertions(+), 4 deletions(-) diff --git a/src/base/ID.ml b/src/base/ID.ml index a1e5f808..c3c23053 100644 --- a/src/base/ID.ml +++ b/src/base/ID.ml @@ -16,8 +16,9 @@ let to_string id = id.name let equal a b = a.id = b.id let compare a b = CCInt.compare a.id b.id let hash a = CCHash.int a.id -let pp out a = Format.fprintf out "%s/%d" a.name a.id +let pp_full out a = Format.fprintf out "%s/%d" a.name a.id let pp_name out a = CCFormat.string out a.name +let pp = pp_name let to_string_full a = Printf.sprintf "%s/%d" a.name a.id module AsKey = struct diff --git a/src/base/ID.mli b/src/base/ID.mli index 0e96c3fa..d3929d2c 100644 --- a/src/base/ID.mli +++ b/src/base/ID.mli @@ -40,6 +40,7 @@ val to_string_full : t -> string include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t val pp_name : t CCFormat.printer +val pp_full : t CCFormat.printer module Map : CCMap.S with type key = t module Set : CCSet.S with type elt = t diff --git a/src/base/LRA_term.ml b/src/base/LRA_term.ml index c7b3c7ec..db8c4811 100644 --- a/src/base/LRA_term.ml +++ b/src/base/LRA_term.ml @@ -49,11 +49,21 @@ let pred tst p t1 t2 : term = let p = Term.const tst (Const.make (Pred p) ops ~ty) in Term.app_l tst p [ t1; t2 ] +let leq tst a b = pred tst Pred.Leq a b +let lt tst a b = pred tst Pred.Lt a b +let geq tst a b = pred tst Pred.Geq a b +let gt tst a b = pred tst Pred.Gt a b +let eq tst a b = pred tst Pred.Eq a b +let neq tst a b = pred tst Pred.Neq a b + let op tst op t1 t2 : term = let ty = Term.(arrow_l tst [ real tst; real tst ] (real tst)) in let p = Term.const tst (Const.make (Op op) ops ~ty) in Term.app_l tst p [ t1; t2 ] +let plus tst a b = op tst Op.Plus a b +let minus tst a b = op tst Op.Minus a b + let view (t : term) : _ View.t = let f, args = Term.unfold_app t in match T.view f, args with diff --git a/src/base/LRA_term.mli b/src/base/LRA_term.mli index a6f7b5d3..f4188842 100644 --- a/src/base/LRA_term.mli +++ b/src/base/LRA_term.mli @@ -6,6 +6,7 @@ module View = Arith_types_.LRA_view type term = Term.t type ty = Term.t +val term_of_view : Term.store -> term View.t -> term val real : Term.store -> ty val has_ty_real : term -> bool val pred : Term.store -> Pred.t -> term -> term -> term @@ -13,7 +14,18 @@ val mult_by : Term.store -> Q.t -> term -> term val op : Term.store -> Op.t -> term -> term -> term val const : Term.store -> Q.t -> term +(** {2 Helpers} *) + +val leq : Term.store -> term -> term -> term +val lt : Term.store -> term -> term -> term +val geq : Term.store -> term -> term -> term +val gt : Term.store -> term -> term -> term +val eq : Term.store -> term -> term -> term +val neq : Term.store -> term -> term -> term +val plus : Term.store -> term -> term -> term +val minus : Term.store -> term -> term -> term + +(** {2 View} *) + val view : term -> term View.t (** View as LRA *) - -val term_of_view : Term.store -> term View.t -> term diff --git a/src/base/Ty.ml b/src/base/Ty.ml index 2e2f7cc8..1bd6e2d0 100644 --- a/src/base/Ty.ml +++ b/src/base/Ty.ml @@ -59,6 +59,8 @@ let is_int t = let uninterpreted tst id : t = mk_ty0 tst (Ty_uninterpreted { id; finite = false }) +let uninterpreted_str tst s : t = uninterpreted tst (ID.make s) + let is_uninterpreted (self : t) = match view self with | E_const { Const.c_view = Ty (Ty_uninterpreted _); _ } -> true diff --git a/src/base/Ty.mli b/src/base/Ty.mli index 1ac9ad8e..ccd701a9 100644 --- a/src/base/Ty.mli +++ b/src/base/Ty.mli @@ -13,6 +13,7 @@ val bool : store -> t val real : store -> t val int : store -> t val uninterpreted : store -> ID.t -> t +val uninterpreted_str : store -> string -> t val is_uninterpreted : t -> bool val is_real : t -> bool val is_int : t -> bool diff --git a/src/base/Uconst.ml b/src/base/Uconst.ml index 8a6cd14a..4c09220e 100644 --- a/src/base/Uconst.ml +++ b/src/base/Uconst.ml @@ -39,6 +39,9 @@ let uconst_of_id' tst id args ret = let ty = Term.arrow_l tst args ret in uconst_of_id tst id ty +let uconst_of_str tst name args ret : term = + uconst_of_id' tst (ID.make name) args ret + module As_key = struct type nonrec t = t diff --git a/src/base/Uconst.mli b/src/base/Uconst.mli index ed7faa59..8bd2787d 100644 --- a/src/base/Uconst.mli +++ b/src/base/Uconst.mli @@ -18,6 +18,7 @@ val make : ID.t -> ty -> t val uconst : Term.store -> t -> Term.t val uconst_of_id : Term.store -> ID.t -> ty -> Term.t val uconst_of_id' : Term.store -> ID.t -> ty list -> ty -> Term.t +val uconst_of_str : Term.store -> string -> ty list -> ty -> Term.t module Map : CCMap.S with type key = t module Tbl : CCHashtbl.S with type key = t diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 33884ee3..e77a2cb6 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -168,6 +168,7 @@ module Store = struct (* TODO: use atomic? CCAtomic? *) let n = ref 0 + let size self = Hcons.size self.s_exprs let create ?(size = 256) () : t = (* store id, modulo 2^5 *) diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index 9bd8ec81..b9d2ac67 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -111,6 +111,7 @@ module Store : sig type t = store val create : ?size:int -> unit -> t + val size : t -> int end val type_ : store -> t diff --git a/src/core/default_cc_view.ml b/src/core/default_cc_view.ml index 84e0ad7e..4718ff5a 100644 --- a/src/core/default_cc_view.ml +++ b/src/core/default_cc_view.ml @@ -4,7 +4,8 @@ module View = CC_view let view_as_cc (t : Term.t) : _ CC_view.t = let f, args = Term.unfold_app t in match Term.view f, args with - | _, [ _; t; u ] when T_builtins.is_eq f -> View.Eq (t, u) + | Term.E_const { Const.c_view = T_builtins.C_eq; _ }, [ _; t; u ] -> + View.Eq (t, u) | Term.E_const { Const.c_view = T_builtins.C_ite; _ }, [ _ty; a; b; c ] -> View.If (a, b, c) | Term.E_const { Const.c_view = T_builtins.C_not; _ }, [ a ] -> View.Not a diff --git a/src/smt/solver.ml b/src/smt/solver.ml index d2157216..33b539b5 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -116,6 +116,15 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = (P.add_step self.proof @@ fun () -> Rule_.lemma_true t_true)); self +let default_arg = + (module struct + let view_as_cc = Default_cc_view.view_as_cc + let is_valid_literal _ = true + end : ARG) + +let create_default ?stat ?size ~proof ~theories tst () : t = + create default_arg ?stat ?size ~proof ~theories tst () + let[@inline] solver self = self.solver let[@inline] stats self = self.stat let[@inline] tst self = Solver_internal.tst self.si diff --git a/src/smt/solver.mli b/src/smt/solver.mli index d297cc6a..1d6f53a5 100644 --- a/src/smt/solver.mli +++ b/src/smt/solver.mli @@ -67,6 +67,18 @@ val create : @param theories theories to load from the start. Other theories can be added using {!add_theory}. *) +val create_default : + ?stat:Stat.t -> + ?size:[ `Big | `Tiny | `Small ] -> + (* TODO? ?config:Config.t -> *) + proof:proof_trace -> + theories:Theory.t list -> + Term.store -> + unit -> + t +(** Create a new solver with the default CC view, and where all boolean subterms + are mapped to boolean atoms. *) + val add_theory : t -> Theory.t -> unit (** Add a theory to the solver. This should be called before any call to {!solve} or to {!add_clause} and the likes (otherwise From 40734d507481178948f28fbc2bc1c25f149104b4 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 15:01:33 -0400 Subject: [PATCH 164/174] doc: update guide (temporarily) models still need to be updated. --- doc/guide.md | 243 +++++++++++++++++++++++++-------------------------- 1 file changed, 120 insertions(+), 123 deletions(-) diff --git a/doc/guide.md b/doc/guide.md index 7067c4d8..6b284c0e 100644 --- a/doc/guide.md +++ b/doc/guide.md @@ -38,7 +38,7 @@ OCaml prompt): # #show Sidekick_base;; module Sidekick_base : sig - module Base_types = Sidekick_base__.Base_types + module Types_ = Sidekick_base__.Types_ ... end ``` @@ -75,34 +75,28 @@ We're going to use these libraries: main Solver, along with a few theories. Let us peek into it now: ```ocaml -# #require "sidekick-base.solver";; -# #show Sidekick_base_solver;; -module Sidekick_base_solver : +# #require "sidekick-base";; +# #show Sidekick_base.Solver;; +module Solver = Sidekick_base__.Solver +module Solver = Sidekick_base.Solver +module Solver : sig - module Solver_arg : sig ... end - module Solver : sig ... end - module Th_data : sig ... end - module Th_bool : sig ... end - module Gensym : sig ... end - module Th_lra : sig ... end - val th_bool : Solver.theory - val th_data : Solver.theory - val th_lra : Solver.theory - end + type t = Solver.t +... ``` Let's bring more all these things into scope, and install some printers for legibility: ```ocaml +# open Sidekick_core;; # open Sidekick_base;; -# open Sidekick_base_solver;; +# open Sidekick_smt_solver;; # #install_printer Term.pp;; # #install_printer Lit.pp;; # #install_printer Ty.pp;; -# #install_printer Fun.pp;; +# #install_printer Const.pp;; # #install_printer Model.pp;; -# #install_printer Solver.Model.pp;; ``` ## First steps in solving @@ -117,30 +111,24 @@ All terms in sidekick live in a store, which is necessary for _hashconsing_ in alternative implementations.) ```ocaml -# let tstore = Term.create ();; +# let tstore = Term.Store.create ();; val tstore : Term.store = -# Term.store_size tstore;; -- : int = 2 +# Term.Store.size tstore;; +- : int = 0 ``` -Interesting, there are already two terms that are predefined. -Let's peek at them: +Let's look at some basic terms we can build immediately. ```ocaml -# let all_terms_init = - Term.store_iter tstore |> Iter.to_list |> List.sort Term.compare;; -val all_terms_init : Term.t list = [true; false] - # Term.true_ tstore;; -- : Term.t = true +- : Sidekick_th_lra.ty = true -# (* check it's the same term *) - Term.(equal (true_ tstore) (List.hd all_terms_init));; -- : bool = true +# Term.false_ tstore;; +- : Sidekick_th_lra.ty = false -# Term.(equal (false_ tstore) (List.hd all_terms_init));; -- : bool = false +# Term.eq tstore (Term.true_ tstore) (Term.false_ tstore);; +- : Sidekick_th_lra.ty = (= Bool true false) ``` Cool. Similarly, we need to manipulate types. @@ -151,57 +139,60 @@ In general we'd need to carry around a type store as well. The only predefined type is _bool_, the type of booleans: ```ocaml -# Ty.bool ();; -- : Ty.t = Bool +# Ty.bool tstore;; +- : Sidekick_th_lra.ty = Bool ``` Now we can define new terms and constants. Let's try to define a few boolean constants named "p", "q", "r": ```ocaml -# let p = Term.const_undefined tstore (ID.make "p") @@ Ty.bool();; -val p : Term.t = p -# let q = Term.const_undefined tstore (ID.make "q") @@ Ty.bool();; -val q : Term.t = q -# let r = Term.const_undefined tstore (ID.make "r") @@ Ty.bool();; -val r : Term.t = r +# let p = Uconst.uconst_of_str tstore "p" [] @@ Ty.bool tstore;; +val p : Sidekick_th_lra.ty = p +# let q = Uconst.uconst_of_str tstore "q" [] @@ Ty.bool tstore;; +val q : Sidekick_th_lra.ty = q +# let r = Uconst.uconst_of_str tstore "r" [] @@ Ty.bool tstore;; +val r : Sidekick_th_lra.ty = r # Term.ty p;; -- : Ty.t = Bool +- : Sidekick_th_lra.ty = Bool # Term.equal p q;; - : bool = false # Term.view p;; -- : Term.t Term.view = Sidekick_base.Term.App_fun (p/3, [||]) +- : Term.view = Sidekick_base.Term.E_const p -# Term.store_iter tstore |> Iter.to_list |> List.sort Term.compare;; -- : Term.t list = [true; false; p; q; r] +# Term.equal p p;; +- : bool = true ``` We can now build formulas from these. ```ocaml # let p_eq_q = Term.eq tstore p q;; -val p_eq_q : Term.t = (= p q) +val p_eq_q : Sidekick_th_lra.ty = (= Bool p q) # let p_imp_r = Form.imply tstore p r;; -val p_imp_r : Term.t = (=> p r) +val p_imp_r : Sidekick_th_lra.ty = (=> p r) ``` ### Using a solver. We can create a solver by passing `Solver.create` a term store -and a type store (which in our case is simply `() : unit`). +and a proof trace (here, `Proof_trace.dummy` because we don't care about +proofs). A list of theories can be added initially, or later using `Solver.add_theory`. ```ocaml -# let solver = Solver.create ~theories:[th_bool] ~proof:(Proof.empty) tstore () ();; -val solver : Solver.t = +# let proof = Proof_trace.dummy;; +val proof : Proof_trace.t = +# let solver = Solver.create_default ~theories:[th_bool_static] ~proof tstore ();; +val solver : solver = # Solver.add_theory;; -- : Solver.t -> Solver.theory -> unit = +- : solver -> theory -> unit = ``` Alright, let's do some solving now ⚙️. We're going to assert @@ -211,18 +202,18 @@ We start with `p = q`. ```ocaml # p_eq_q;; -- : Term.t = (= p q) +- : Sidekick_th_lra.ty = (= Bool p q) # Solver.assert_term solver p_eq_q;; - : unit = () # Solver.solve ~assumptions:[] solver;; - : Solver.res = -Sidekick_base_solver.Solver.Sat +Sidekick_smt_solver.Solver.Sat (model - (true := true) - (false := false) - (p := true) + (false := $@c[0]) (q := true) - ((= p q) := true)) + ((= Bool p q) := true) + (true := true) + (p := true)) ``` It is satisfiable, and we got a model where "p" and "q" are both false. @@ -238,8 +229,8 @@ whether the assertions and hypotheses are satisfiable together. ~assumptions:[Solver.mk_lit_t solver p; Solver.mk_lit_t solver q ~sign:false];; - : Solver.res = -Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } +Sidekick_smt_solver.Solver.Unsat + {Sidekick_smt_solver.Solver.unsat_core = ; unsat_step_id = } ``` Here it's unsat, because we asserted "p = q", and then assumed "p" @@ -253,40 +244,40 @@ Note that this doesn't affect satisfiability without assumptions: ```ocaml # Solver.solve ~assumptions:[] solver;; - : Solver.res = -Sidekick_base_solver.Solver.Sat +Sidekick_smt_solver.Solver.Sat (model + (false := $@c[0]) + (q := false) + ((= Bool p q) := true) (true := true) - (false := false) - (p := true) - (q := true) - ((= p q) := true)) + (p := false)) ``` We can therefore add more formulas and see where it leads us. ```ocaml # p_imp_r;; -- : Term.t = (=> p r) +- : Sidekick_th_lra.ty = (=> p r) # Solver.assert_term solver p_imp_r;; - : unit = () # Solver.solve ~assumptions:[] solver;; - : Solver.res = -Sidekick_base_solver.Solver.Sat +Sidekick_smt_solver.Solver.Sat (model - (true := true) - (false := false) - (p := true) - (q := true) + (false := $@c[0]) + (q := false) (r := true) - ((= p q) := true) - ((=> p r) := true)) + ((= Bool p q) := true) + ((or r (not p) false) := true) + (true := true) + (p := false)) ``` Still satisfiable, but now we see `r` in the model, too. And now: ```ocaml # let q_imp_not_r = Form.imply tstore q (Form.not_ tstore r);; -val q_imp_not_r : Term.t = (=> q (not r)) +val q_imp_not_r : Sidekick_th_lra.ty = (=> q (not r)) # Solver.assert_term solver q_imp_not_r;; - : unit = () @@ -295,8 +286,8 @@ val q_imp_not_r : Term.t = (=> q (not r)) # Solver.solve ~assumptions:[] solver;; - : Solver.res = -Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } +Sidekick_smt_solver.Solver.Unsat + {Sidekick_smt_solver.Solver.unsat_core = ; unsat_step_id = } ``` This time we got _unsat_ and there is no way of undoing it. @@ -310,25 +301,25 @@ We can solve linear real arithmetic problems as well. Let's create a new solver and add the theory of reals to it. ```ocaml -# let solver = Solver.create ~theories:[th_bool; th_lra] ~proof:(Proof.empty) tstore () ();; -val solver : Solver.t = +# let solver = Solver.create_default ~theories:[th_bool_static; th_lra] ~proof tstore ();; +val solver : solver = ``` Create a few arithmetic constants. ```ocaml -# let real = Ty.real ();; -val real : Ty.t = Real -# let a = Term.const_undefined tstore (ID.make "a") real;; -val a : Term.t = a -# let b = Term.const_undefined tstore (ID.make "b") real;; -val b : Term.t = b +# let real = Ty.real tstore;; +val real : Sidekick_th_lra.ty = Real +# let a = Uconst.uconst_of_str tstore "a" [] real;; +val a : Sidekick_th_lra.ty = a +# let b = Uconst.uconst_of_str tstore "b" [] real;; +val b : Sidekick_th_lra.ty = b # Term.ty a;; -- : Ty.t = Real +- : Sidekick_th_lra.ty = Real -# let a_leq_b = Term.LRA.(leq tstore a b);; -val a_leq_b : Term.t = (<= a b) +# let a_leq_b = LRA_term.leq tstore a b;; +val a_leq_b : Sidekick_th_lra.ty = (<= a b) ``` We can play with assertions now: @@ -338,31 +329,39 @@ We can play with assertions now: - : unit = () # Solver.solve ~assumptions:[] solver;; - : Solver.res = -Sidekick_base_solver.Solver.Sat +Sidekick_smt_solver.Solver.Sat (model - (true := true) - (false := false) (a := 0) + ((+ a) := $@c[0]) + (0 := 0) + (false := $@c[5]) (b := 0) - ((<= (+ a (* -1 b)) 0) := true) - (_sk_lra__le_comb0 := 0)) + ((+ a ((* -1) b)) := $@c[7]) + ((<= (+ a ((* -1) b))) := $@c[3]) + ((* -1) := $@c[6]) + ((<= (+ a ((* -1) b)) 0) := true) + (((* -1) b) := $@c[1]) + (<= := $@c[2]) + ($_le_comb[0] := 0) + (+ := $@c[4]) + (true := true)) -# let a_geq_1 = Term.LRA.(geq tstore a (const tstore (Q.of_int 1)));; -val a_geq_1 : Term.t = (>= a 1) -# let b_leq_half = Term.LRA.(leq tstore b (const tstore (Q.of_string "1/2")));; -val b_leq_half : Term.t = (<= b 1/2) +# let a_geq_1 = LRA_term.geq tstore a (LRA_term.const tstore (Q.of_int 1));; +val a_geq_1 : Sidekick_th_lra.ty = (>= a 1) +# let b_leq_half = LRA_term.(leq tstore b (LRA_term.const tstore (Q.of_string "1/2")));; +val b_leq_half : Sidekick_th_lra.ty = (<= b 1/2) # let res = Solver.solve solver ~assumptions:[Solver.mk_lit_t solver p; Solver.mk_lit_t solver a_geq_1; Solver.mk_lit_t solver b_leq_half];; val res : Solver.res = - Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } + Sidekick_smt_solver.Solver.Unsat + {Sidekick_smt_solver.Solver.unsat_core = ; unsat_step_id = } # match res with Solver.Unsat {unsat_core=us; _} -> us() |> Iter.to_list | _ -> assert false;; -- : Lit.t list = [(>= a 1); (<= b 1/2)] +- : Proof_trace.lit list = [(>= a 1); (<= b 1/2)] ``` This just showed that `a=1, b=1/2, a>=b` is unsatisfiable. @@ -378,41 +377,39 @@ We can define function symbols, not just constants. Let's also define `u`, an uninterpreted type. ```ocaml -# let u = Ty.atomic_uninterpreted (ID.make "u");; -val u : Ty.t = u/9 +# let u = Ty.uninterpreted_str tstore "u";; +val u : Sidekick_th_lra.ty = u -# let u1 = Term.const_undefined tstore (ID.make "u1") u;; -val u1 : Term.t = u1 -# let u2 = Term.const_undefined tstore (ID.make "u2") u;; -val u2 : Term.t = u2 -# let u3 = Term.const_undefined tstore (ID.make "u3") u;; -val u3 : Term.t = u3 +# let u1 = Uconst.uconst_of_str tstore "u1" [] u;; +val u1 : Sidekick_th_lra.ty = u1 +# let u2 = Uconst.uconst_of_str tstore "u2" [] u;; +val u2 : Sidekick_th_lra.ty = u2 +# let u3 = Uconst.uconst_of_str tstore "u3" [] u;; +val u3 : Sidekick_th_lra.ty = u3 -# let f1 = Fun.mk_undef' (ID.make "f1") [u] u;; -val f1 : Fun.t = f1/13 -# Fun.view f1;; -- : Fun.view = -Sidekick_base.Fun.Fun_undef - {Sidekick_base.Base_types.fun_ty_args = [u/9]; fun_ty_ret = u/9} +# let f1 = Uconst.uconst_of_str tstore "f1" [u] u;; +val f1 : Sidekick_th_lra.ty = f1 +# Term.view f1;; +- : Term.view = Sidekick_base.Term.E_const f1 -# let f1_u1 = Term.app_fun_l tstore f1 [u1];; -val f1_u1 : Term.t = (f1 u1) +# let f1_u1 = Term.app_l tstore f1 [u1];; +val f1_u1 : Sidekick_th_lra.ty = (f1 u1) # Term.ty f1_u1;; -- : Ty.t = u/9 +- : Sidekick_th_lra.ty = u # Term.view f1_u1;; -- : Term.t Term.view = Sidekick_base.Term.App_fun (f1/13, [|u1|]) +- : Term.view = Sidekick_base.Term.E_app (f1, u1) ``` Anyway, Sidekick knows how to reason about functions. ```ocaml -# let solver = Solver.create ~theories:[] ~proof:(Proof.empty) tstore () ();; -val solver : Solver.t = +# let solver = Solver.create_default ~theories:[] ~proof tstore ();; +val solver : solver = # (* helper *) - let appf1 x = Term.app_fun_l tstore f1 x;; -val appf1 : Term.t list -> Term.t = + let appf1 x = Term.app_l tstore f1 x;; +val appf1 : Sidekick_th_lra.ty list -> Sidekick_th_lra.ty = # Solver.assert_term solver (Term.eq tstore u2 (appf1 [u1]));; - : unit = () @@ -427,14 +424,14 @@ val appf1 : Term.t list -> Term.t = # Solver.solve solver ~assumptions:[Solver.mk_lit_t solver ~sign:false (Term.eq tstore u1 (appf1[u1]))];; - : Solver.res = -Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } +Sidekick_smt_solver.Solver.Unsat + {Sidekick_smt_solver.Solver.unsat_core = ; unsat_step_id = } # Solver.solve solver ~assumptions:[Solver.mk_lit_t solver ~sign:false (Term.eq tstore u2 u3)];; - : Solver.res = -Sidekick_base_solver.Solver.Unsat - {Sidekick_base_solver.Solver.unsat_core = ; unsat_step_id = } +Sidekick_smt_solver.Solver.Unsat + {Sidekick_smt_solver.Solver.unsat_core = ; unsat_step_id = } ``` Assuming: `f1(u1)=u2, f1(u2)=u3, f1^2(u1)=u1, f1^3(u1)=u1`, From e3aa43f8172c36cec34a6a91337cb58d51449f26 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 20:39:06 -0400 Subject: [PATCH 165/174] cleanup --- src/base/Arith_types_.ml | 151 ---- src/base/Base_types.ml | 1391 ------------------------------------- src/base/LIA_term.ml | 71 ++ src/base/LRA_term.ml | 88 ++- src/base/LRA_term.mli | 32 +- src/base/Sidekick_base.ml | 3 +- src/main/main.ml | 2 +- src/smt/solver.ml | 25 - 8 files changed, 187 insertions(+), 1576 deletions(-) delete mode 100644 src/base/Arith_types_.ml delete mode 100644 src/base/Base_types.ml create mode 100644 src/base/LIA_term.ml diff --git a/src/base/Arith_types_.ml b/src/base/Arith_types_.ml deleted file mode 100644 index 5691be2c..00000000 --- a/src/base/Arith_types_.ml +++ /dev/null @@ -1,151 +0,0 @@ -open struct - let hash_z = Z.hash - let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) -end - -module LRA_pred = struct - type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq - - let to_string = function - | Lt -> "<" - | Leq -> "<=" - | Neq -> "!=" - | Eq -> "=" - | Gt -> ">" - | Geq -> ">=" - - let equal : t -> t -> bool = ( = ) - let hash : t -> int = Hashtbl.hash - let pp out p = Fmt.string out (to_string p) -end - -module LRA_op = struct - type t = Sidekick_th_lra.op = Plus | Minus - - let to_string = function - | Plus -> "+" - | Minus -> "-" - - let equal : t -> t -> bool = ( = ) - let hash : t -> int = Hashtbl.hash - let pp out p = Fmt.string out (to_string p) -end - -module LRA_view = struct - include Sidekick_th_lra - - type 'a t = (Q.t, 'a) lra_view - - let map ~f_c f (l : _ t) : _ t = - match l with - | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) - | LRA_op (p, a, b) -> LRA_op (p, f a, f b) - | LRA_mult (n, a) -> LRA_mult (f_c n, f a) - | LRA_const c -> LRA_const (f_c c) - | LRA_other x -> LRA_other (f x) - - let iter f l : unit = - match l with - | LRA_pred (_, a, b) | LRA_op (_, a, b) -> - f a; - f b - | LRA_mult (_, x) | LRA_other x -> f x - | LRA_const _ -> () - - let pp ~pp_t out = function - | LRA_pred (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | LRA_op (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x - | LRA_const q -> Q.pp_print out q - | LRA_other x -> pp_t out x - - let hash ~sub_hash = function - | LRA_pred (p, a, b) -> - Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | LRA_op (p, a, b) -> - Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | LRA_mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) - | LRA_const q -> Hash.combine2 84 (hash_q q) - | LRA_other x -> sub_hash x - - let equal ~sub_eq l1 l2 = - match l1, l2 with - | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | LRA_const a1, LRA_const a2 -> Q.equal a1 a2 - | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 - | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 - | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> - false -end - -module LIA_pred = LRA_pred -module LIA_op = LRA_op - -module LIA_view = struct - type 'a t = - | LRA_pred of LIA_pred.t * 'a * 'a - | LRA_op of LIA_op.t * 'a * 'a - | LRA_mult of Z.t * 'a - | LRA_const of Z.t - | LRA_other of 'a - - let map ~f_c f (l : _ t) : _ t = - match l with - | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) - | LRA_op (p, a, b) -> LRA_op (p, f a, f b) - | LRA_mult (n, a) -> LRA_mult (f_c n, f a) - | LRA_const c -> LRA_const (f_c c) - | LRA_other x -> LRA_other (f x) - - let iter f l : unit = - match l with - | LRA_pred (_, a, b) | LRA_op (_, a, b) -> - f a; - f b - | LRA_mult (_, x) | LRA_other x -> f x - | LRA_const _ -> () - - let pp ~pp_t out = function - | LRA_pred (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | LRA_op (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x - | LRA_const n -> Z.pp_print out n - | LRA_other x -> pp_t out x - - let hash ~sub_hash = function - | LRA_pred (p, a, b) -> - Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | LRA_op (p, a, b) -> - Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | LRA_mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) - | LRA_const n -> Hash.combine2 84 (hash_z n) - | LRA_other x -> sub_hash x - - let equal ~sub_eq l1 l2 = - match l1, l2 with - | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | LRA_const a1, LRA_const a2 -> Z.equal a1 a2 - | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 - | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 - | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> - false - - (* convert the whole structure to reals *) - let to_lra f l : _ LRA_view.t = - match l with - | LRA_pred (p, a, b) -> LRA_view.LRA_pred (p, f a, f b) - | LRA_op (op, a, b) -> LRA_view.LRA_op (op, f a, f b) - | LRA_mult (c, x) -> LRA_view.LRA_mult (Q.of_bigint c, f x) - | LRA_const x -> LRA_view.LRA_const (Q.of_bigint x) - | LRA_other v -> LRA_view.LRA_other (f v) -end diff --git a/src/base/Base_types.ml b/src/base/Base_types.ml deleted file mode 100644 index 476a2450..00000000 --- a/src/base/Base_types.ml +++ /dev/null @@ -1,1391 +0,0 @@ -(** Basic type definitions for Sidekick_base *) - -(* - -open Sidekick_core -module CC_view = Sidekick_cc.View -(* FIXME - module Proof_ser = Sidekick_base_proof_trace.Proof_ser - module Storage = Sidekick_base_proof_trace.Storage -*) - -let hash_z = Z.hash -let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) - -module LRA_pred = struct - type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq - - let to_string = function - | Lt -> "<" - | Leq -> "<=" - | Neq -> "!=" - | Eq -> "=" - | Gt -> ">" - | Geq -> ">=" - - let pp out p = Fmt.string out (to_string p) -end - -module LRA_op = struct - type t = Sidekick_th_lra.op = Plus | Minus - - let to_string = function - | Plus -> "+" - | Minus -> "-" - - let pp out p = Fmt.string out (to_string p) -end - -module LRA_view = struct - type 'a t = - | Pred of LRA_pred.t * 'a * 'a - | Op of LRA_op.t * 'a * 'a - | Mult of Q.t * 'a - | Const of Q.t - | Var of 'a - | To_real of 'a - - let map ~f_c f (l : _ t) : _ t = - match l with - | Pred (p, a, b) -> Pred (p, f a, f b) - | Op (p, a, b) -> Op (p, f a, f b) - | Mult (n, a) -> Mult (f_c n, f a) - | Const c -> Const (f_c c) - | Var x -> Var (f x) - | To_real x -> To_real (f x) - - let iter f l : unit = - match l with - | Pred (_, a, b) | Op (_, a, b) -> - f a; - f b - | Mult (_, x) | Var x | To_real x -> f x - | Const _ -> () - - let pp ~pp_t out = function - | Pred (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | Op (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x - | Const q -> Q.pp_print out q - | Var x -> pp_t out x - | To_real x -> Fmt.fprintf out "(@[to_real@ %a@])" pp_t x - - let hash ~sub_hash = function - | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | Mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) - | Const q -> Hash.combine2 84 (hash_q q) - | Var x -> sub_hash x - | To_real x -> Hash.combine2 85 (sub_hash x) - - let equal ~sub_eq l1 l2 = - match l1, l2 with - | Pred (p1, a1, b1), Pred (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Op (p1, a1, b1), Op (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Const a1, Const a2 -> Q.equal a1 a2 - | Mult (n1, x1), Mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 - | Var x1, Var x2 | To_real x1, To_real x2 -> sub_eq x1 x2 - | (Pred _ | Op _ | Const _ | Mult _ | Var _ | To_real _), _ -> false -end - -module LIA_pred = LRA_pred -module LIA_op = LRA_op - -module LIA_view = struct - type 'a t = - | Pred of LIA_pred.t * 'a * 'a - | Op of LIA_op.t * 'a * 'a - | Mult of Z.t * 'a - | Const of Z.t - | Var of 'a - - let map ~f_c f (l : _ t) : _ t = - match l with - | Pred (p, a, b) -> Pred (p, f a, f b) - | Op (p, a, b) -> Op (p, f a, f b) - | Mult (n, a) -> Mult (f_c n, f a) - | Const c -> Const (f_c c) - | Var x -> Var (f x) - - let iter f l : unit = - match l with - | Pred (_, a, b) | Op (_, a, b) -> - f a; - f b - | Mult (_, x) | Var x -> f x - | Const _ -> () - - let pp ~pp_t out = function - | Pred (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_pred.to_string p) pp_t a pp_t b - | Op (p, a, b) -> - Fmt.fprintf out "(@[%s@ %a@ %a@])" (LRA_op.to_string p) pp_t a pp_t b - | Mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x - | Const n -> Z.pp_print out n - | Var x -> pp_t out x - - let hash ~sub_hash = function - | Pred (p, a, b) -> Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) - | Op (p, a, b) -> Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) - | Mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) - | Const n -> Hash.combine2 84 (hash_z n) - | Var x -> sub_hash x - - let equal ~sub_eq l1 l2 = - match l1, l2 with - | Pred (p1, a1, b1), Pred (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Op (p1, a1, b1), Op (p2, a2, b2) -> - p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 - | Const a1, Const a2 -> Z.equal a1 a2 - | Mult (n1, x1), Mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 - | Var x1, Var x2 -> sub_eq x1 x2 - | (Pred _ | Op _ | Const _ | Mult _ | Var _), _ -> false - - (* convert the whole structure to reals *) - let to_lra f l : _ LRA_view.t = - match l with - | Pred (p, a, b) -> LRA_view.Pred (p, f a, f b) - | Op (op, a, b) -> LRA_view.Op (op, f a, f b) - | Mult (c, x) -> LRA_view.Mult (Q.of_bigint c, f x) - | Const x -> LRA_view.Const (Q.of_bigint x) - | Var v -> LRA_view.Var (f v) -end - -type term = Term.t -type ty = Term.t -type value = Term.t - -type fun_view = - | Fun_undef of ty (* simple undefined constant *) - | Fun_select of select - | Fun_cstor of cstor - | Fun_is_a of cstor - | Fun_def of { - pp: 'a. ('a Fmt.printer -> 'a array Fmt.printer) option; - abs: self:term -> term array -> term * bool; (* remove the sign? *) - do_cc: bool; (* participate in congruence closure? *) - relevant: 'a. ID.t -> 'a array -> int -> bool; (* relevant argument? *) - ty: ID.t -> term array -> ty; (* compute type *) - eval: value array -> value; (* evaluate term *) - } - (** Methods on the custom term view whose arguments are ['a]. - Terms must be printable, and provide some additional theory handles. - - - [relevant] must return a subset of [args] (possibly the same set). - The terms it returns will be activated and evaluated whenever possible. - Terms in [args \ relevant args] are considered for - congruence but not for evaluation. -*) - -and ty_view = - | Ty_int - | Ty_real - | Ty_uninterpreted of ID.t - | Ty_data of { data: data } - | Ty_def of { - id: ID.t; - pp: ty Fmt.printer -> ty list Fmt.printer; - default_val: value list -> value; (* default value of this type *) - } - -and data = { - data_id: ID.t; - data_cstors: cstor ID.Map.t lazy_t; - data_as_ty: ty lazy_t; -} - -and cstor = { - cstor_id: ID.t; - cstor_is_a: ID.t; - mutable cstor_arity: int; - cstor_args: select list lazy_t; - cstor_ty_as_data: data; - cstor_ty: ty lazy_t; -} - -and select = { - select_id: ID.t; - select_cstor: cstor; - select_ty: ty lazy_t; - select_i: int; -} - -(* FIXME: just use terms; introduce a Const.view for V_element - (** Semantic values, used for models (and possibly model-constructing calculi) *) - type value_view = - | V_element of { id: ID.t; ty: ty } - (** a named constant, distinct from any other constant *) - | V_cstor of { c: cstor; args: value list } - | V_custom of { - view: value_custom_view; - pp: value_custom_view Fmt.printer; - eq: value_custom_view -> value_custom_view -> bool; - hash: value_custom_view -> int; - } (** Custom value *) - | V_real of Q.t - - and value_custom_view = .. -*) - -type definition = ID.t * ty * term - -type statement = - | Stmt_set_logic of string - | 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_define of definition list - | Stmt_assert of term - | Stmt_assert_clause of term list - | Stmt_check_sat of (bool * term) list - | Stmt_get_model - | Stmt_get_value of term list - | Stmt_exit - -type Const.view += Ty of ty_view - -let ops_ty : Const.ops = - (module struct - let pp out = function - | Ty ty -> - (match ty with - | Ty_real -> Fmt.string out "Real" - | Ty_int -> Fmt.string out "Int" - | Ty_atomic { def = Ty_uninterpreted id; args = []; _ } -> ID.pp out id - | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> - Fmt.fprintf out "(@[%a@ %a@])" ID.pp id (Util.pp_list pp_ty) args - | Ty_atomic { def = Ty_def def; args; _ } -> def.pp pp_ty out args - | Ty_atomic { def = Ty_data d; args = []; _ } -> - ID.pp out d.data.data_id - | Ty_atomic { def = Ty_data d; args; _ } -> - Fmt.fprintf out "(@[%a@ %a@])" ID.pp d.data.data_id - (Util.pp_list pp_ty) args) - | _ -> () - - let equal a b = - match a, b with - | Ty a, Ty b -> - (match a, b with - | Ty_bool, Ty_bool | Ty_int, Ty_int | Ty_real, Ty_real -> true - | Ty_atomic a1, Ty_atomic a2 -> - equal_def a1.def a2.def && CCList.equal equal a1.args a2.args - | (Ty_bool | Ty_atomic _ | Ty_real | Ty_int), _ -> false) - | _ -> false - - let hash t = - match t.ty_view with - | Ty_bool -> Hash.int 1 - | Ty_real -> Hash.int 2 - | Ty_int -> Hash.int 3 - | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> - Hash.combine3 10 (ID.hash id) (Hash.list hash args) - | Ty_atomic { def = Ty_def d; args; _ } -> - Hash.combine3 20 (ID.hash d.id) (Hash.list hash args) - | Ty_atomic { def = Ty_data d; args; _ } -> - Hash.combine3 30 (ID.hash d.data.data_id) (Hash.list hash args) - end) - -(* -let rec eq_value a b = - match a, b with - | V_bool a, V_bool b -> a = b - | V_element e1, V_element e2 -> ID.equal e1.id e2.id && eq_ty e1.ty e2.ty - | V_custom x1, V_custom x2 -> x1.eq x1.view x2.view - | V_cstor x1, V_cstor x2 -> - eq_cstor x1.c x2.c && CCList.equal eq_value x1.args x2.args - | V_real a, V_real b -> Q.equal a b - | (V_bool _ | V_element _ | V_custom _ | V_cstor _ | V_real _), _ -> false - -let rec hash_value a = - match a with - | V_bool a -> Hash.bool a - | V_element e -> ID.hash e.id - | V_custom x -> x.hash x.view - | V_cstor x -> - Hash.combine3 42 (ID.hash x.c.cstor_id) (Hash.list hash_value x.args) - | V_real x -> Hash.combine3 50 (Z.hash @@ Q.num x) (Z.hash @@ Q.den x) - -let rec pp_value out = function - | V_bool b -> Fmt.bool out b - | V_element e -> ID.pp out e.id - | V_custom c -> c.pp out c.view - | V_cstor { c; args = [] } -> ID.pp out c.cstor_id - | V_cstor { c; args } -> - Fmt.fprintf out "(@[%a@ %a@])" ID.pp c.cstor_id (Util.pp_list pp_value) args - | V_real x -> Q.pp_print out x - *) - -let pp_term_view_gen ~pp_id ~pp_t out = function - | Bool true -> Fmt.string out "true" - | Bool false -> Fmt.string out "false" - | App_fun ({ fun_view = Fun_def { pp = Some pp_custom; _ }; _ }, l) -> - pp_custom pp_t out l - | App_fun (c, [||]) -> pp_id out (id_of_fun c) - | App_fun (f, l) -> - Fmt.fprintf out "(@[<1>%a@ %a@])" pp_id (id_of_fun f) (Util.pp_array pp_t) l - | Eq (a, b) -> Fmt.fprintf out "(@[=@ %a@ %a@])" pp_t a pp_t b - | Not u -> Fmt.fprintf out "(@[not@ %a@])" pp_t u - | Ite (a, b, c) -> - Fmt.fprintf out "(@[ite@ %a@ %a@ %a@])" pp_t a pp_t b pp_t c - | LRA l -> LRA_view.pp ~pp_t out l - | LIA l -> - LIA_view.pp ~pp_t out l; - Fmt.string out "/ℤ" - -let pp_term_top ~ids out t = - let rec pp out t = pp_rec out t - (* FIXME Fmt.fprintf out "/%d" t.term_id; *) - and pp_rec out t = pp_term_view_gen ~pp_id ~pp_t:pp_rec out t.term_view - and pp_id = - if ids then - ID.pp - else - ID.pp_name - in - pp out t - -let pp_term = pp_term_top ~ids:false -let pp_term_view = pp_term_view_gen ~pp_id:ID.pp_name ~pp_t:pp_term - -(** Types *) -module Ty : sig - type t = ty - type store = unit - - type view = ty_view = - | Ty_bool - | Ty_real - | Ty_int - | Ty_atomic of { def: ty_def; args: ty list; mutable finite: bool } - - type def = ty_def = - | Ty_uninterpreted of ID.t - | Ty_data of { data: data } - | Ty_def of { - id: ID.t; - pp: ty Fmt.printer -> ty list Fmt.printer; - default_val: value list -> value; (* default value of this type *) - } - - val id : t -> int - val view : t -> view - val bool : store -> t - val real : store -> t - val int : store -> t - val atomic : def -> t list -> t - val id_of_def : def -> ID.t - val atomic_uninterpreted : ID.t -> t - val finite : t -> bool - val set_finite : t -> bool -> unit - val is_bool : t -> bool - val is_uninterpreted : t -> bool - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val pp : t CCFormat.printer - - module Tbl : CCHashtbl.S with type key = t - - module Fun : sig - type t = fun_ty - - val args : t -> ty list - val ret : t -> ty - val arity : t -> int - val unfold : t -> ty list * ty - val mk : ty list -> ty -> t - val pp : t CCFormat.printer - end -end = struct - type t = ty - type store = unit - - type view = ty_view = - | Ty_bool - | Ty_real - | Ty_int - | Ty_atomic of { def: ty_def; args: ty list; mutable finite: bool } - - type def = ty_def = - | Ty_uninterpreted of ID.t - | Ty_data of { data: data } - | Ty_def of { - id: ID.t; - pp: ty Fmt.printer -> ty list Fmt.printer; - default_val: value list -> value; (* default value of this type *) - } - - let[@inline] id t = t.ty_id - let[@inline] view t = t.ty_view - let equal = eq_ty - let[@inline] compare a b = CCInt.compare a.ty_id b.ty_id - let[@inline] hash a = a.ty_id - - let equal_def d1 d2 = - match d1, d2 with - | Ty_uninterpreted id1, Ty_uninterpreted id2 -> ID.equal id1 id2 - | Ty_def d1, Ty_def d2 -> ID.equal d1.id d2.id - | Ty_data d1, Ty_data d2 -> ID.equal d1.data.data_id d2.data.data_id - | (Ty_uninterpreted _ | Ty_def _ | Ty_data _), _ -> false - - module H = Hashcons.Make (struct - type t = ty - - let equal a b = - match a.ty_view, b.ty_view with - | Ty_bool, Ty_bool | Ty_int, Ty_int | Ty_real, Ty_real -> true - | Ty_atomic a1, Ty_atomic a2 -> - equal_def a1.def a2.def && CCList.equal equal a1.args a2.args - | (Ty_bool | Ty_atomic _ | Ty_real | Ty_int), _ -> false - - let hash t = - match t.ty_view with - | Ty_bool -> Hash.int 1 - | Ty_real -> Hash.int 2 - | Ty_int -> Hash.int 3 - | Ty_atomic { def = Ty_uninterpreted id; args; _ } -> - Hash.combine3 10 (ID.hash id) (Hash.list hash args) - | Ty_atomic { def = Ty_def d; args; _ } -> - Hash.combine3 20 (ID.hash d.id) (Hash.list hash args) - | Ty_atomic { def = Ty_data d; args; _ } -> - Hash.combine3 30 (ID.hash d.data.data_id) (Hash.list hash args) - - let set_id ty id = - assert (ty.ty_id < 0); - ty.ty_id <- id - end) - - (* build a type *) - let make_ : ty_view -> t = - let tbl : H.t = H.create ~size:128 () in - fun [@inline] c -> - let ty = { ty_id = -1; ty_view = c } in - H.hashcons tbl ty - - let finite t = - match view t with - | Ty_bool -> true - | Ty_real | Ty_int -> false - | Ty_atomic { finite = f; _ } -> f - - let set_finite t b = - match view t with - | Ty_bool | Ty_real | Ty_int -> assert false - | Ty_atomic r -> r.finite <- b - - let bool () = make_ Ty_bool - let real () = make_ Ty_real - let int () = make_ Ty_int - let atomic def args : t = make_ (Ty_atomic { def; args; finite = true }) - let atomic_uninterpreted id = atomic (Ty_uninterpreted id) [] - - let id_of_def = function - | Ty_uninterpreted id -> id - | Ty_def { id; _ } -> id - | Ty_data { data } -> data.data_id - - let is_bool t = - match t.ty_view with - | Ty_bool -> true - | _ -> false - - let is_uninterpreted t = - match t.ty_view with - | Ty_atomic { def = Ty_uninterpreted _; _ } -> true - | _ -> false - - let pp = pp_ty - - module Tbl = CCHashtbl.Make (struct - type t = ty - - let equal = equal - let hash = hash - end) - - module Fun = struct - type t = fun_ty - - let[@inline] args f = f.fun_ty_args - let[@inline] ret f = f.fun_ty_ret - let[@inline] arity f = List.length @@ args f - let[@inline] mk args ret : t = { fun_ty_args = args; fun_ty_ret = ret } - let[@inline] unfold t = args t, ret t - - let pp out f : unit = - match args f with - | [] -> pp out (ret f) - | args -> - Format.fprintf out "(@[(@[%a@])@ %a@])" (Util.pp_list pp) args pp - (ret f) - end -end - -(** Function symbols *) -module Fun : sig - (** Possible definitions for a function symbol *) - type view = fun_view = - | Fun_undef of fun_ty (* simple undefined constant *) - | Fun_select of select - | Fun_cstor of cstor - | Fun_is_a of cstor - | Fun_def of { - pp: 'a. ('a Fmt.printer -> 'a array Fmt.printer) option; - abs: self:term -> term array -> term * bool; (* remove the sign? *) - do_cc: bool; (* participate in congruence closure? *) - relevant: 'a. ID.t -> 'a array -> int -> bool; - (* relevant argument? *) - ty: ID.t -> term array -> ty; (* compute type *) - eval: value array -> value; (* evaluate term *) - } - (** user defined function symbol. - A good example can be found in {!Form} for boolean connectives. *) - - type t = fun_ = { fun_id: ID.t; fun_view: fun_view } - (** A function symbol *) - - val id : t -> ID.t - val view : t -> view - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - val as_undefined : t -> (t * Ty.Fun.t) option - val as_undefined_exn : t -> t * Ty.Fun.t - val is_undefined : t -> bool - val select : select -> t - val select_idx : cstor -> int -> t - val cstor : cstor -> t - val is_a : cstor -> t - val do_cc : t -> bool - - val mk_undef : ID.t -> Ty.Fun.t -> t - (** Make a new uninterpreted function. *) - - val mk_undef' : ID.t -> Ty.t list -> Ty.t -> t - - val mk_undef_const : ID.t -> Ty.t -> t - (** Make a new uninterpreted constant. *) - - val pp : t CCFormat.printer - - module Map : CCMap.S with type key = t - module Tbl : CCHashtbl.S with type key = t -end = struct - type view = fun_view = - | Fun_undef of fun_ty (* simple undefined constant *) - | Fun_select of select - | Fun_cstor of cstor - | Fun_is_a of cstor - | Fun_def of { - pp: 'a. ('a Fmt.printer -> 'a array Fmt.printer) option; - abs: self:term -> term array -> term * bool; (* remove the sign? *) - do_cc: bool; (* participate in congruence closure? *) - relevant: 'a. ID.t -> 'a array -> int -> bool; - (* relevant argument? *) - ty: ID.t -> term array -> ty; (* compute type *) - eval: value array -> value; (* evaluate term *) - } - - type t = fun_ = { fun_id: ID.t; fun_view: fun_view } - - let[@inline] id t = t.fun_id - let[@inline] view t = t.fun_view - let[@inline] make fun_id fun_view = { fun_id; fun_view } - - let as_undefined (c : t) = - match view c with - | Fun_undef ty -> Some (c, ty) - | Fun_def _ | Fun_cstor _ | Fun_select _ | Fun_is_a _ -> None - - let[@inline] is_undefined c = - match view c with - | Fun_undef _ -> true - | _ -> false - - let as_undefined_exn (c : t) = - match as_undefined c with - | Some tup -> tup - | None -> assert false - - let[@inline] mk_undef id ty = make id (Fun_undef ty) - let[@inline] mk_undef_const id ty = mk_undef id (Ty.Fun.mk [] ty) - - let[@inline] mk_undef' id args ret = - mk_undef id { fun_ty_args = args; fun_ty_ret = ret } - - let is_a c : t = make c.cstor_is_a (Fun_is_a c) - let cstor c : t = make c.cstor_id (Fun_cstor c) - let select sel : t = make sel.select_id (Fun_select sel) - - let select_idx c i : t = - let (lazy l) = c.cstor_args in - match List.nth l i with - | sel -> select sel - | exception Not_found -> - Error.errorf "invalid selector %d for cstor %a" i ID.pp c.cstor_id - - let[@inline] do_cc (c : t) : bool = - match view c with - | Fun_cstor _ | Fun_select _ | Fun_undef _ | Fun_is_a _ -> true - | Fun_def { do_cc; _ } -> do_cc - - let equal a b = ID.equal a.fun_id b.fun_id - let compare a b = ID.compare a.fun_id b.fun_id - let hash t = ID.hash t.fun_id - let pp out a = ID.pp out a.fun_id - - module As_key = struct - type nonrec t = t - - let compare = compare - let equal = equal - let hash = hash - end - - module Map = CCMap.Make (As_key) - module Tbl = CCHashtbl.Make (As_key) -end - -module Term_cell : sig - type 'a view = 'a term_view = - | Bool of bool - | App_fun of fun_ * 'a array - | Eq of 'a * 'a - | Not of 'a - | Ite of 'a * 'a * 'a - | LRA of 'a LRA_view.t - | LIA of 'a LIA_view.t - - type t = term view - - val equal : t -> t -> bool - val hash : t -> int - val true_ : t - val false_ : t - val const : fun_ -> t - val app_fun : fun_ -> term array -> t - val eq : term -> term -> t - val not_ : term -> t - val ite : term -> term -> term -> t - val lra : term LRA_view.t -> t - val lia : term LIA_view.t -> t - - val ty : t -> Ty.t - (** Compute the type of this term cell. Not totally free *) - - val pp : t Fmt.printer - val map : ('a -> 'b) -> 'a view -> 'b view - val iter : ('a -> unit) -> 'a view -> unit - - module type ARG = sig - type t - - val hash : t -> int - val equal : t -> t -> bool - val pp : t Fmt.printer - end - - module Make_eq (X : ARG) : sig - val equal : X.t view -> X.t view -> bool - val hash : X.t view -> int - val pp : X.t view Fmt.printer - end -end = struct - type 'a view = 'a term_view = - | Bool of bool - | App_fun of fun_ * 'a array - | Eq of 'a * 'a - | Not of 'a - | Ite of 'a * 'a * 'a - | LRA of 'a LRA_view.t - | LIA of 'a LIA_view.t - - type t = term view - - module type ARG = sig - type t - - val hash : t -> int - val equal : t -> t -> bool - val pp : t Fmt.printer - end - - module Make_eq (A : ARG) = struct - let sub_hash = A.hash - let sub_eq = A.equal - - let hash (t : A.t view) : int = - match t with - | Bool b -> Hash.bool b - | App_fun (f, l) -> Hash.combine3 4 (Fun.hash f) (Hash.iarray sub_hash l) - | Eq (a, b) -> Hash.combine3 12 (sub_hash a) (sub_hash b) - | Not u -> Hash.combine2 70 (sub_hash u) - | Ite (a, b, c) -> Hash.combine4 80 (sub_hash a) (sub_hash b) (sub_hash c) - | LRA l -> LRA_view.hash ~sub_hash l - | LIA l -> LIA_view.hash ~sub_hash l - - (* equality that relies on physical equality of subterms *) - let equal (a : A.t view) b : bool = - match a, b with - | Bool b1, Bool b2 -> CCBool.equal b1 b2 - | App_fun (f1, a1), App_fun (f2, a2) -> - Fun.equal f1 f2 && CCArray.equal sub_eq a1 a2 - | Eq (a1, b1), Eq (a2, b2) -> sub_eq a1 a2 && sub_eq b1 b2 - | Not a, Not b -> sub_eq a b - | Ite (a1, b1, c1), Ite (a2, b2, c2) -> - sub_eq a1 a2 && sub_eq b1 b2 && sub_eq c1 c2 - | LRA l1, LRA l2 -> LRA_view.equal ~sub_eq l1 l2 - | LIA l1, LIA l2 -> LIA_view.equal ~sub_eq l1 l2 - | (Bool _ | App_fun _ | Eq _ | Not _ | Ite _ | LRA _ | LIA _), _ -> false - - let pp = pp_term_view_gen ~pp_id:ID.pp_name ~pp_t:A.pp - end - [@@inline] - - include Make_eq (struct - type t = term - - let equal (t1 : t) t2 = t1 == t2 - let hash (t : term) : int = CCHash.int t.term_id - let pp = pp_term - end) - - let true_ = Bool true - let false_ = Bool false - let app_fun f a = App_fun (f, a) - let const c = App_fun (c, CCArray.empty) - - let eq a b = - if term_equal_ a b then - Bool true - else ( - (* canonize *) - let a, b = - if a.term_id > b.term_id then - b, a - else - a, b - in - Eq (a, b) - ) - - let not_ t = - match t.term_view with - | Bool b -> Bool (not b) - | Not u -> u.term_view - | _ -> Not t - - let[@inline] ite a b c = Ite (a, b, c) - let[@inline] lra l : t = LRA l - let[@inline] lia l : t = LIA l - - let ty (t : t) : Ty.t = - match t with - | Bool _ | Eq _ | Not _ -> Ty.bool () - | Ite (_, b, _) -> b.term_ty - | App_fun (f, args) -> - (match Fun.view f with - | Fun_undef fty -> - let ty_args, ty_ret = Ty.Fun.unfold fty in - (* check arity *) - if List.length ty_args <> CCArray.length args then - Error.errorf "Term_cell.apply: expected %d args, got %d@ in %a" - (List.length ty_args) (CCArray.length args) pp t; - (* check types *) - List.iteri - (fun i ty_a -> - let a = CCArray.get args i in - if not @@ Ty.equal a.term_ty ty_a then - Error.errorf - "Term_cell.apply: %d-th argument mismatch:@ %a does not have \ - type %a@ in %a" - i pp_term a Ty.pp ty_a pp t) - ty_args; - ty_ret - | Fun_is_a _ -> Ty.bool () - | Fun_def def -> def.ty f.fun_id args - | Fun_select s -> Lazy.force s.select_ty - | Fun_cstor c -> Lazy.force c.cstor_ty) - | LRA l -> - LRA_view.( - (match l with - | Pred _ -> Ty.bool () - | Op _ | Const _ | Mult _ | To_real _ -> Ty.real () - | Var x -> x.term_ty)) - | LIA l -> - LIA_view.( - (match l with - | Pred _ -> Ty.bool () - | Op _ | Const _ | Mult _ -> Ty.int () - | Var x -> x.term_ty)) - - let iter f view = - match view with - | Bool _ -> () - | App_fun (_, a) -> CCArray.iter f a - | Not u -> f u - | Eq (a, b) -> - f a; - f b - | Ite (a, b, c) -> - f a; - f b; - f c - | LRA l -> LRA_view.iter f l - | LIA l -> LIA_view.iter f l - - let map f view = - match view with - | Bool b -> Bool b - | App_fun (fu, a) -> App_fun (fu, CCArray.map f a) - | Not u -> Not (f u) - | Eq (a, b) -> Eq (f a, f b) - | Ite (a, b, c) -> Ite (f a, f b, f c) - | LRA l -> LRA (LRA_view.map ~f_c:CCFun.id f l) - | LIA l -> LIA (LIA_view.map ~f_c:CCFun.id f l) -end - -(** Term creation and manipulation *) -module Term : sig - type t = term = { - mutable term_id: int; - mutable term_ty: ty; - term_view: t term_view; - } - - type 'a view = 'a term_view = - | Bool of bool - | App_fun of fun_ * 'a array - | Eq of 'a * 'a - | Not of 'a - | Ite of 'a * 'a * 'a - | LRA of 'a LRA_view.t - | LIA of 'a LIA_view.t - - val id : t -> int - val view : t -> term view - val ty : t -> Ty.t - val equal : t -> t -> bool - val compare : t -> t -> int - val hash : t -> int - - type store - - val create : ?size:int -> unit -> store - val make : store -> t view -> t - val true_ : store -> t - val false_ : store -> t - val bool : store -> bool -> t - val const : store -> fun_ -> t - val app_fun : store -> fun_ -> t array -> t - val app_fun_l : store -> fun_ -> t list -> t - val eq : store -> t -> t -> t - val not_ : store -> t -> t - val ite : store -> t -> t -> t -> t - - val app_undefined : store -> ID.t -> Ty.Fun.t -> t array -> t - (** [app_undefined store f ty args] is [app store (Fun.mk_undef f ty) args]. - It builds a function symbol and applies it into a term immediately *) - - val const_undefined : store -> ID.t -> Ty.t -> t - (** [const_undefined store f ty] is [const store (Fun.mk_undef_const f ty)]. - It builds a constant function symbol and makes it into a term - immediately. *) - - val select : store -> select -> t -> t - val app_cstor : store -> cstor -> t array -> t - val is_a : store -> cstor -> t -> t - val lra : store -> t LRA_view.t -> t - val lia : store -> t LIA_view.t -> t - - module type ARITH_HELPER = sig - type num - - val plus : store -> t -> t -> t - val minus : store -> t -> t -> t - val mult : store -> num -> t -> t - val const : store -> num -> t - val leq : store -> t -> t -> t - val lt : store -> t -> t -> t - val geq : store -> t -> t -> t - val gt : store -> t -> t -> t - val eq : store -> t -> t -> t - val neq : store -> t -> t -> t - end - - module LRA : ARITH_HELPER with type num := Q.t - module LIA : ARITH_HELPER with type num := Z.t - - val abs : store -> t -> t * bool - (** Obtain unsigned version of [t], + the sign as a boolean *) - - module Iter_dag : sig - type t - type order = Pre | Post - - val create : unit -> t - val iter_dag : ?order:order -> t -> term -> term Iter.t - end - - val iter_dag_with : order:Iter_dag.order -> t -> t Iter.t - val iter_dag : t -> t Iter.t - val map_shallow : store -> (t -> t) -> t -> t - val iter_shallow : store -> (t -> unit) -> t -> unit - val pp : t Fmt.printer - - (** {3 Views} *) - - val is_true : t -> bool - val is_false : t -> bool - val is_const : t -> bool - val cc_view : t -> (fun_, t, t Iter.t) CC_view.t - - (* return [Some] iff the term is an undefined constant *) - val as_fun_undef : t -> (fun_ * Ty.Fun.t) option - val as_bool : t -> bool option - - (** {3 Store} *) - - val store_size : store -> int - val store_iter : store -> term Iter.t - - (** {3 Containers} *) - - module Tbl : CCHashtbl.S with type key = t - module Map : CCMap.S with type key = t - module Set : CCSet.S with type elt = t -end = struct - type t = term = { - mutable term_id: int; - mutable term_ty: ty; - term_view: t term_view; - } - - type 'a view = 'a term_view = - | Bool of bool - | App_fun of fun_ * 'a array - | Eq of 'a * 'a - | Not of 'a - | Ite of 'a * 'a * 'a - | LRA of 'a LRA_view.t - | LIA of 'a LIA_view.t - - let[@inline] id t = t.term_id - let[@inline] ty t = t.term_ty - let[@inline] view t = t.term_view - let equal = term_equal_ - let hash = term_hash_ - let compare a b = CCInt.compare a.term_id b.term_id - - module H = Hashcons.Make (struct - type t = term - - let equal t1 t2 = Term_cell.equal t1.term_view t2.term_view - let hash t = Term_cell.hash t.term_view - - let set_id t id = - assert (t.term_id < 0); - t.term_id <- id - end) - - type store = { tbl: H.t; true_: t lazy_t; false_: t lazy_t } - - let[@inline] make st (c : t term_view) : t = - let t = { term_id = -1; term_ty = Ty.bool (); term_view = c } in - let t' = H.hashcons st.tbl t in - if t == t' then t'.term_ty <- Term_cell.ty c; - t' - - let[@inline] true_ st = Lazy.force st.true_ - let[@inline] false_ st = Lazy.force st.false_ - - let bool st b = - if b then - true_ st - else - false_ st - - let create ?(size = 1024) () : store = - let rec st = - { - tbl = H.create ~size (); - true_ = lazy (make st Term_cell.true_); - false_ = lazy (make st Term_cell.false_); - } - in - ignore (Lazy.force st.true_); - ignore (Lazy.force st.false_); - (* not true *) - st - - let app_fun st f a = - let cell = Term_cell.app_fun f a in - make st cell - - let app_fun_l st f l = app_fun st f (CCArray.of_list l) - let[@inline] const st c = app_fun st c CCArray.empty - let[@inline] eq st a b = make st (Term_cell.eq a b) - let[@inline] not_ st a = make st (Term_cell.not_ a) - let ite st a b c : t = make st (Term_cell.ite a b c) - let select st sel t : t = app_fun st (Fun.select sel) [| t |] - let is_a st c t : t = app_fun st (Fun.is_a c) [| t |] - let app_cstor st c args : t = app_fun st (Fun.cstor c) args - - let[@inline] lra (st : store) (l : t LRA_view.t) : t = - match l with - | Var x -> x (* normalize *) - | _ -> make st (Term_cell.lra l) - - let[@inline] lia (st : store) (l : t LIA_view.t) : t = - match l with - | Var x -> x (* normalize *) - | _ -> make st (Term_cell.lia l) - - module type ARITH_HELPER = sig - type num - - val plus : store -> t -> t -> t - val minus : store -> t -> t -> t - val mult : store -> num -> t -> t - val const : store -> num -> t - val leq : store -> t -> t -> t - val lt : store -> t -> t -> t - val geq : store -> t -> t -> t - val gt : store -> t -> t -> t - val eq : store -> t -> t -> t - val neq : store -> t -> t -> t - end - - module LRA = struct - module V = LRA_view - - let plus st a b : t = lra st (V.Op (Plus, a, b)) - let minus st a b : t = lra st (V.Op (Minus, a, b)) - let mult st a b : t = lra st (V.Mult (a, b)) - let const st q : t = lra st (V.Const q) - let leq st a b : t = lra st (V.Pred (Leq, a, b)) - let lt st a b : t = lra st (V.Pred (Lt, a, b)) - let geq st a b : t = lra st (V.Pred (Geq, a, b)) - let gt st a b : t = lra st (V.Pred (Gt, a, b)) - let eq st a b : t = lra st (V.Pred (Eq, a, b)) - let neq st a b : t = lra st (V.Pred (Neq, a, b)) - end - - module LIA = struct - module V = LIA_view - - let plus st a b : t = lia st (V.Op (Plus, a, b)) - let minus st a b : t = lia st (V.Op (Minus, a, b)) - let mult st a b : t = lia st (V.Mult (a, b)) - let const st q : t = lia st (V.Const q) - let leq st a b : t = lia st (V.Pred (Leq, a, b)) - let lt st a b : t = lia st (V.Pred (Lt, a, b)) - let geq st a b : t = lia st (V.Pred (Geq, a, b)) - let gt st a b : t = lia st (V.Pred (Gt, a, b)) - let eq st a b : t = lia st (V.Pred (Eq, a, b)) - let neq st a b : t = lia st (V.Pred (Neq, a, b)) - end - - let app_undefined store id ty args : t = - app_fun store (Fun.mk_undef id ty) args - - let const_undefined store id ty : t = const store (Fun.mk_undef_const id ty) - - (* might need to tranfer the negation from [t] to [sign] *) - let abs tst t : t * bool = - match view t with - | Bool false -> true_ tst, false - | Not u -> u, false - | App_fun ({ fun_view = Fun_def def; _ }, args) -> - def.abs ~self:t args (* TODO: pass store *) - | LRA (Pred (Neq, a, b)) -> - lra tst (Pred (Eq, a, b)), false (* != is just not eq *) - | LIA (Pred (Neq, a, b)) -> - lia tst (Pred (Eq, a, b)), false (* != is just not eq *) - | _ -> t, true - - let[@inline] is_true t = - match view t with - | Bool true -> true - | _ -> false - - let[@inline] is_false t = - match view t with - | Bool false -> true - | _ -> false - - let[@inline] is_const t = - match view t with - | App_fun (_, [||]) -> true - | _ -> false - - let cc_view (t : t) = - let module C = CC_view in - match view t with - | Bool b -> C.Bool b - | App_fun (f, _) when not (Fun.do_cc f) -> C.Opaque t (* skip *) - | App_fun (f, args) -> C.App_fun (f, CCArray.to_iter args) - | Eq (a, b) -> C.Eq (a, b) - | Not u -> C.Not u - | Ite (a, b, c) -> C.If (a, b, c) - | LRA (Pred (Eq, a, b)) -> - C.Eq (a, b) - (* need congruence closure on this one, for theory combination *) - | LIA (Pred (Eq, a, b)) -> - C.Eq (a, b) - (* need congruence closure on this one, for theory combination *) - | LRA _ | LIA _ -> C.Opaque t - (* no congruence here *) - - module As_key = struct - type t = term - - let compare = compare - let equal = equal - let hash = hash - end - - module Map = CCMap.Make (As_key) - module Set = CCSet.Make (As_key) - module Tbl = CCHashtbl.Make (As_key) - - (* return [Some] iff the term is an undefined constant *) - let as_fun_undef (t : term) : (fun_ * Ty.Fun.t) option = - match view t with - | App_fun (c, [||]) -> Fun.as_undefined c - | _ -> None - - let as_bool t = - match view t with - | Bool b -> Some b - | _ -> None - - let pp = pp_term - let[@inline] iter_shallow _tst f (t : t) : unit = Term_cell.iter f (view t) - - module Iter_dag = struct - type t = unit Tbl.t - type order = Pre | Post - - let create () : t = Tbl.create 16 - - let iter_dag ?(order = Pre) (self : t) t yield = - let rec aux t = - if not @@ Tbl.mem self t then ( - Tbl.add self t (); - - match order with - | Pre -> - yield t; - Term_cell.iter aux (view t) - | Post -> - Term_cell.iter aux (view t); - yield t - ) - in - aux t - end - - let iter_dag_with ~order t yield = - let st = Iter_dag.create () in - Iter_dag.iter_dag ~order st t yield - - let iter_dag t yield = iter_dag_with ~order:Pre t yield - - let map_shallow (tst : store) f (t : t) : t = - match view t with - | Bool _ -> t - | App_fun (hd, a) -> app_fun tst hd (CCArray.map f a) - | Not u -> not_ tst (f u) - | Eq (a, b) -> eq tst (f a) (f b) - | Ite (a, b, c) -> ite tst (f a) (f b) (f c) - | LRA l -> lra tst (LRA_view.map ~f_c:CCFun.id f l) - | LIA l -> lia tst (LIA_view.map ~f_c:CCFun.id f l) - - let store_size tst = H.size tst.tbl - let store_iter tst = H.to_iter tst.tbl -end - -(** Values (used in models) *) -module Value : sig - type t = value = - | V_bool of bool - | V_element of { id: ID.t; ty: ty } - | V_cstor of { c: cstor; args: value list } - | V_custom of { - view: value_custom_view; - pp: value_custom_view Fmt.printer; - eq: value_custom_view -> value_custom_view -> bool; - hash: value_custom_view -> int; - } - | V_real of Q.t - - val true_ : t - val false_ : t - val bool : bool -> t - val real : Q.t -> t - val real_of_string : string -> t - val mk_elt : ID.t -> Ty.t -> t - val is_bool : t -> bool - val is_true : t -> bool - val is_false : t -> bool - val cstor_app : cstor -> t list -> t - val fresh : Term.t -> t - val hash : t -> int - val equal : t -> t -> bool - val pp : t Fmt.printer -end = struct - type t = value = - | V_bool of bool - | V_element of { id: ID.t; ty: ty } - | V_cstor of { c: cstor; args: value list } - | V_custom of { - view: value_custom_view; - pp: value_custom_view Fmt.printer; - eq: value_custom_view -> value_custom_view -> bool; - hash: value_custom_view -> int; - } - | V_real of Q.t - - let true_ = V_bool true - let false_ = V_bool false - - let[@inline] bool v = - if v then - true_ - else - false_ - - let real x = V_real x - let real_of_string x = V_real (Q.of_string x) - let mk_elt id ty : t = V_element { id; ty } - - let[@inline] is_bool = function - | V_bool _ -> true - | _ -> false - - let[@inline] is_true = function - | V_bool true -> true - | _ -> false - - let[@inline] is_false = function - | V_bool false -> true - | _ -> false - - let cstor_app c args : t = V_cstor { c; args } - let equal = eq_value - let hash = hash_value - let pp = pp_value - let fresh (t : term) : t = mk_elt (ID.makef "v_%d" t.term_id) t.term_ty -end - -(** Datatypes *) -module Data = struct - type t = data = { - data_id: ID.t; - data_cstors: cstor ID.Map.t lazy_t; - data_as_ty: ty lazy_t; - } - - let pp out d = ID.pp out d.data_id -end - -(** Datatype selectors. - - A selector is a kind of function that allows to obtain an argument - of a given constructor. *) -module Select = struct - type t = select = { - select_id: ID.t; - select_cstor: cstor; - select_ty: ty lazy_t; - select_i: int; - } - - let ty sel = Lazy.force sel.select_ty -end - -(** Datatype constructors. - - A datatype has one or more constructors, each of which is a special - kind of function symbol. Constructors are injective and pairwise distinct. *) -module Cstor = struct - type t = cstor = { - cstor_id: ID.t; - cstor_is_a: ID.t; - mutable cstor_arity: int; - cstor_args: select list lazy_t; - cstor_ty_as_data: data; - cstor_ty: ty lazy_t; - } - - let id c = c.cstor_id - let ty_args c = Lazy.force c.cstor_args |> Iter.of_list |> Iter.map Select.ty - let equal = eq_cstor - let pp out c = ID.pp out c.cstor_id -end - -(* TODO: check-sat-assuming, get-unsat-assumptions, push, pop *) - -(** Statements. - - A statement is an instruction for the SMT solver to do something, - like asserting that a formula is true, declaring a new constant, - or checking satisfiabilty of the current set of assertions. *) -module Statement = struct - type t = statement = - | Stmt_set_logic of string - | 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_define of definition list - | Stmt_assert of term - | Stmt_assert_clause of term list - | Stmt_check_sat of (bool * term) list - | Stmt_get_model - | Stmt_get_value of term list - | Stmt_exit - - (** Pretty print a statement *) - let pp out = function - | Stmt_set_logic s -> Fmt.fprintf out "(set-logic %s)" s - | Stmt_set_option l -> - Fmt.fprintf out "(@[set-logic@ %a@])" (Util.pp_list Fmt.string) l - | Stmt_set_info (a, b) -> Fmt.fprintf out "(@[set-info@ %s@ %s@])" a b - | Stmt_check_sat [] -> Fmt.string out "(check-sat)" - | Stmt_check_sat l -> - let pp_pair out (b, t) = - if b then - pp_term out t - else - Fmt.fprintf out "(@[not %a@])" pp_term 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_assert t -> Fmt.fprintf out "(@[assert@ %a@])" pp_term t - | Stmt_assert_clause c -> - Fmt.fprintf out "(@[assert-clause@ %a@])" (Util.pp_list pp_term) c - | Stmt_exit -> Fmt.string out "(exit)" - | Stmt_data l -> - Fmt.fprintf out "(@[declare-datatypes@ %a@])" (Util.pp_list Data.pp) l - | Stmt_get_model -> Fmt.string out "(get-model)" - | Stmt_get_value l -> - Fmt.fprintf out "(@[get-value@ (@[%a@])@])" (Util.pp_list pp_term) l - | Stmt_define _ -> assert false - (* TODO *) -end - -*) diff --git a/src/base/LIA_term.ml b/src/base/LIA_term.ml new file mode 100644 index 00000000..213deba1 --- /dev/null +++ b/src/base/LIA_term.ml @@ -0,0 +1,71 @@ +open struct + let hash_z = Z.hash + let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) +end + +module LIA_pred = LRA_term.Pred +module LIA_op = LRA_term.Op + +module LIA_view = struct + type 'a t = + | LRA_pred of LIA_pred.t * 'a * 'a + | LRA_op of LIA_op.t * 'a * 'a + | LRA_mult of Z.t * 'a + | LRA_const of Z.t + | LRA_other of 'a + + let map ~f_c f (l : _ t) : _ t = + match l with + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (f_c n, f a) + | LRA_const c -> LRA_const (f_c c) + | LRA_other x -> LRA_other (f x) + + let iter f l : unit = + match l with + | LRA_pred (_, a, b) | LRA_op (_, a, b) -> + f a; + f b + | LRA_mult (_, x) | LRA_other x -> f x + | LRA_const _ -> () + + let pp ~pp_t out = function + | LRA_pred (p, a, b) -> + Fmt.fprintf out "(@[%a@ %a@ %a@])" LRA_term.Pred.pp p pp_t a pp_t b + | LRA_op (p, a, b) -> + Fmt.fprintf out "(@[%a@ %a@ %a@])" LRA_term.Op.pp p pp_t a pp_t b + | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Z.pp_print n pp_t x + | LRA_const n -> Z.pp_print out n + | LRA_other x -> pp_t out x + + let hash ~sub_hash = function + | LRA_pred (p, a, b) -> + Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_op (p, a, b) -> + Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_mult (n, x) -> Hash.combine3 83 (hash_z n) (sub_hash x) + | LRA_const n -> Hash.combine2 84 (hash_z n) + | LRA_other x -> sub_hash x + + let equal ~sub_eq l1 l2 = + match l1, l2 with + | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | LRA_const a1, LRA_const a2 -> Z.equal a1 a2 + | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Z.equal n1 n2 && sub_eq x1 x2 + | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 + | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> + false + + (* convert the whole structure to reals *) + let to_lra f l : _ LRA_term.View.t = + match l with + | LRA_pred (p, a, b) -> LRA_term.View.LRA_pred (p, f a, f b) + | LRA_op (op, a, b) -> LRA_term.View.LRA_op (op, f a, f b) + | LRA_mult (c, x) -> LRA_term.View.LRA_mult (Q.of_bigint c, f x) + | LRA_const x -> LRA_term.View.LRA_const (Q.of_bigint x) + | LRA_other v -> LRA_term.View.LRA_other (f v) +end diff --git a/src/base/LRA_term.ml b/src/base/LRA_term.ml index db8c4811..0367683c 100644 --- a/src/base/LRA_term.ml +++ b/src/base/LRA_term.ml @@ -1,9 +1,91 @@ open Sidekick_core -module Pred = Arith_types_.LRA_pred -module Op = Arith_types_.LRA_op -module View = Arith_types_.LRA_view module T = Term +open struct + let hash_z = Z.hash + let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) +end + +module Pred = struct + type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq + + let to_string = function + | Lt -> "<" + | Leq -> "<=" + | Neq -> "!=" + | Eq -> "=" + | Gt -> ">" + | Geq -> ">=" + + let equal : t -> t -> bool = ( = ) + let hash : t -> int = Hashtbl.hash + let pp out p = Fmt.string out (to_string p) +end + +module Op = struct + type t = Sidekick_th_lra.op = Plus | Minus + + let to_string = function + | Plus -> "+" + | Minus -> "-" + + let equal : t -> t -> bool = ( = ) + let hash : t -> int = Hashtbl.hash + let pp out p = Fmt.string out (to_string p) +end + +module View = struct + include Sidekick_th_lra + + type 'a t = (Q.t, 'a) lra_view + + let map ~f_c f (l : _ t) : _ t = + match l with + | LRA_pred (p, a, b) -> LRA_pred (p, f a, f b) + | LRA_op (p, a, b) -> LRA_op (p, f a, f b) + | LRA_mult (n, a) -> LRA_mult (f_c n, f a) + | LRA_const c -> LRA_const (f_c c) + | LRA_other x -> LRA_other (f x) + + let iter f l : unit = + match l with + | LRA_pred (_, a, b) | LRA_op (_, a, b) -> + f a; + f b + | LRA_mult (_, x) | LRA_other x -> f x + | LRA_const _ -> () + + let pp ~pp_t out = function + | LRA_pred (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (Pred.to_string p) pp_t a pp_t b + | LRA_op (p, a, b) -> + Fmt.fprintf out "(@[%s@ %a@ %a@])" (Op.to_string p) pp_t a pp_t b + | LRA_mult (n, x) -> Fmt.fprintf out "(@[*@ %a@ %a@])" Q.pp_print n pp_t x + | LRA_const q -> Q.pp_print out q + | LRA_other x -> pp_t out x + + let hash ~sub_hash = function + | LRA_pred (p, a, b) -> + Hash.combine4 81 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_op (p, a, b) -> + Hash.combine4 82 (Hash.poly p) (sub_hash a) (sub_hash b) + | LRA_mult (n, x) -> Hash.combine3 83 (hash_q n) (sub_hash x) + | LRA_const q -> Hash.combine2 84 (hash_q q) + | LRA_other x -> sub_hash x + + let equal ~sub_eq l1 l2 = + match l1, l2 with + | LRA_pred (p1, a1, b1), LRA_pred (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | LRA_op (p1, a1, b1), LRA_op (p2, a2, b2) -> + p1 = p2 && sub_eq a1 a2 && sub_eq b1 b2 + | LRA_const a1, LRA_const a2 -> Q.equal a1 a2 + | LRA_mult (n1, x1), LRA_mult (n2, x2) -> Q.equal n1 n2 && sub_eq x1 x2 + | LRA_other x1, LRA_other x2 -> sub_eq x1 x2 + | (LRA_pred _ | LRA_op _ | LRA_const _ | LRA_mult _ | LRA_other _), _ -> + false +end + type term = Term.t type ty = Term.t type Const.view += Const of Q.t | Pred of Pred.t | Op of Op.t | Mult_by of Q.t diff --git a/src/base/LRA_term.mli b/src/base/LRA_term.mli index f4188842..c80de26b 100644 --- a/src/base/LRA_term.mli +++ b/src/base/LRA_term.mli @@ -1,7 +1,33 @@ open Sidekick_core -module Pred = Arith_types_.LRA_pred -module Op = Arith_types_.LRA_op -module View = Arith_types_.LRA_view + +module Pred : sig + type t = Sidekick_th_lra.Predicate.t = Leq | Geq | Lt | Gt | Eq | Neq + + include Sidekick_sigs.EQ_HASH_PRINT with type t := t +end + +module Op : sig + type t = Sidekick_th_lra.op = Plus | Minus + + include Sidekick_sigs.EQ_HASH_PRINT with type t := t +end + +module View : sig + type ('num, 'a) lra_view = ('num, 'a) Sidekick_th_lra.lra_view = + | LRA_pred of Pred.t * 'a * 'a + | LRA_op of Op.t * 'a * 'a + | LRA_mult of 'num * 'a + | LRA_const of 'num + | LRA_other of 'a + + type 'a t = (Q.t, 'a) Sidekick_th_lra.lra_view + + val map : f_c:(Q.t -> Q.t) -> ('a -> 'b) -> 'a t -> 'b t + val iter : ('a -> unit) -> 'a t -> unit + val pp : pp_t:'a Fmt.printer -> 'a t Fmt.printer + val hash : sub_hash:('a -> int) -> 'a t -> int + val equal : sub_eq:('a -> 'b -> bool) -> 'a t -> 'b t -> bool +end type term = Term.t type ty = Term.t diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index 6ce130f6..66fe4f68 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -6,7 +6,7 @@ It provides a representation of terms, boolean formulas, linear arithmetic expressions, datatypes for the functors in Sidekick. - In addition, it has a notion of {{!Base_types.Statement} Statement}. + In addition, it has a notion of {{!Statement.t} Statement}. Statements are instructions for the SMT solver to do something, such as: define a new constant, declare a new constant, assert a formula as being true, @@ -22,7 +22,6 @@ module Const = Sidekick_core.Const module Ty = Ty module ID = ID module Form = Form -include Arith_types_ module Data_ty = Data_ty module Cstor = Data_ty.Cstor module Select = Data_ty.Select diff --git a/src/main/main.ml b/src/main/main.ml index a89c47f0..94c99e77 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -177,7 +177,7 @@ let main_smt ~config () : _ result = Log.debugf 1 (fun k -> k "(@[main.th-bool.pick@ %S@])" (Sidekick_smt_solver.Theory.name th_bool)); - Sidekick_smt_solver.Theory.[ th_bool; Process.th_data; Process.th_lra ] + [ th_bool; Process.th_data; Process.th_lra ] in Process.Solver.create_default ~proof ~theories tst in diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 33b539b5..3148ab12 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -6,31 +6,6 @@ open struct module Rule_ = Proof_core end -(* TODO - let mk_cc_acts_ (pr : P.t) (a : sat_acts) : CC.actions = - let (module A) = a in - - (module struct - module T = T - module Lit = Lit - - type nonrec lit = lit - type nonrec term = term - type nonrec proof_trace = Proof_trace.t - type nonrec step_id = step_id - - let proof_trace () = pr - let[@inline] raise_conflict lits (pr : step_id) = A.raise_conflict lits pr - - let[@inline] raise_semantic_conflict lits semantic = - raise (Semantic_conflict { lits; semantic }) - - let[@inline] propagate lit ~reason = - let reason = Sidekick_sat.Consequence reason in - A.propagate lit reason - end) -*) - module Sat_solver = Sidekick_sat (** the parametrized SAT Solver *) From 137183f2fe166991c7a70f5d1ad4d259ab21e005 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 20:44:13 -0400 Subject: [PATCH 166/174] small fixes, warnings --- src/base/Data_ty.ml | 1 - src/base/LIA_term.ml | 1 - src/core-logic/term.ml | 2 +- src/util/Event.ml | 3 +-- 4 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/base/Data_ty.ml b/src/base/Data_ty.ml index 408e8dba..29a9d533 100644 --- a/src/base/Data_ty.ml +++ b/src/base/Data_ty.ml @@ -62,7 +62,6 @@ end module Cstor = struct type t = cstor - let id c = c.cstor_id let hash c = ID.hash c.cstor_id let ty_args c = Lazy.force c.cstor_args |> List.map Select.ty diff --git a/src/base/LIA_term.ml b/src/base/LIA_term.ml index 213deba1..8042c06c 100644 --- a/src/base/LIA_term.ml +++ b/src/base/LIA_term.ml @@ -1,6 +1,5 @@ open struct let hash_z = Z.hash - let[@inline] hash_q q = CCHash.combine2 (hash_z (Q.num q)) (hash_z (Q.den q)) end module LIA_pred = LRA_term.Pred diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index e77a2cb6..689f06c7 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -135,7 +135,7 @@ module Hcons = Hashcons.Make (struct | E_app (f1, a1), E_app (f2, a2) -> equal f1 f2 && equal a1 a2 | E_app_fold a1, E_app_fold a2 -> equal a1.f a2.f && equal a1.acc0 a2.acc0 - && List.equal equal a1.args a2.args + && CCList.equal equal a1.args a2.args | E_lam (_, ty1, bod1), E_lam (_, ty2, bod2) -> equal ty1 ty2 && equal bod1 bod2 | E_pi (_, ty1, bod1), E_pi (_, ty2, bod2) -> diff --git a/src/util/Event.ml b/src/util/Event.ml index cad1fe52..f22f5988 100644 --- a/src/util/Event.ml +++ b/src/util/Event.ml @@ -7,8 +7,7 @@ module Emitter = struct type nonrec ('a, 'b) t = ('a, 'b) t let emit (self : (_, unit) t) x = - if not (Vec.is_empty self.h) then - (Vec.iter [@inlined]) self.h ~f:(fun h -> h x) + if not (Vec.is_empty self.h) then Vec.iter self.h ~f:(fun h -> h x) let emit_collect (self : _ t) x : _ list = if Vec.is_empty self.h then From df287e4ef7f626176b11178ae7cc0213a249eec1 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 20:44:30 -0400 Subject: [PATCH 167/174] update doc/guide --- doc/guide.md | 56 ++++++++++++++++++++++++++-------------------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/doc/guide.md b/doc/guide.md index 6b284c0e..71c44f7e 100644 --- a/doc/guide.md +++ b/doc/guide.md @@ -122,13 +122,13 @@ Let's look at some basic terms we can build immediately. ```ocaml # Term.true_ tstore;; -- : Sidekick_th_lra.ty = true +- : Term.term = true # Term.false_ tstore;; -- : Sidekick_th_lra.ty = false +- : Term.term = false # Term.eq tstore (Term.true_ tstore) (Term.false_ tstore);; -- : Sidekick_th_lra.ty = (= Bool true false) +- : Term.term = (= Bool true false) ``` Cool. Similarly, we need to manipulate types. @@ -140,7 +140,7 @@ The only predefined type is _bool_, the type of booleans: ```ocaml # Ty.bool tstore;; -- : Sidekick_th_lra.ty = Bool +- : Term.term = Bool ``` Now we can define new terms and constants. Let's try to define @@ -148,14 +148,14 @@ a few boolean constants named "p", "q", "r": ```ocaml # let p = Uconst.uconst_of_str tstore "p" [] @@ Ty.bool tstore;; -val p : Sidekick_th_lra.ty = p +val p : Term.term = p # let q = Uconst.uconst_of_str tstore "q" [] @@ Ty.bool tstore;; -val q : Sidekick_th_lra.ty = q +val q : Term.term = q # let r = Uconst.uconst_of_str tstore "r" [] @@ Ty.bool tstore;; -val r : Sidekick_th_lra.ty = r +val r : Term.term = r # Term.ty p;; -- : Sidekick_th_lra.ty = Bool +- : Term.term = Bool # Term.equal p q;; - : bool = false @@ -171,10 +171,10 @@ We can now build formulas from these. ```ocaml # let p_eq_q = Term.eq tstore p q;; -val p_eq_q : Sidekick_th_lra.ty = (= Bool p q) +val p_eq_q : Term.term = (= Bool p q) # let p_imp_r = Form.imply tstore p r;; -val p_imp_r : Sidekick_th_lra.ty = (=> p r) +val p_imp_r : Term.term = (=> p r) ``` ### Using a solver. @@ -202,7 +202,7 @@ We start with `p = q`. ```ocaml # p_eq_q;; -- : Sidekick_th_lra.ty = (= Bool p q) +- : Term.term = (= Bool p q) # Solver.assert_term solver p_eq_q;; - : unit = () # Solver.solve ~assumptions:[] solver;; @@ -257,7 +257,7 @@ We can therefore add more formulas and see where it leads us. ```ocaml # p_imp_r;; -- : Sidekick_th_lra.ty = (=> p r) +- : Term.term = (=> p r) # Solver.assert_term solver p_imp_r;; - : unit = () # Solver.solve ~assumptions:[] solver;; @@ -277,7 +277,7 @@ Still satisfiable, but now we see `r` in the model, too. And now: ```ocaml # let q_imp_not_r = Form.imply tstore q (Form.not_ tstore r);; -val q_imp_not_r : Sidekick_th_lra.ty = (=> q (not r)) +val q_imp_not_r : Term.term = (=> q (not r)) # Solver.assert_term solver q_imp_not_r;; - : unit = () @@ -309,17 +309,17 @@ Create a few arithmetic constants. ```ocaml # let real = Ty.real tstore;; -val real : Sidekick_th_lra.ty = Real +val real : Term.term = Real # let a = Uconst.uconst_of_str tstore "a" [] real;; -val a : Sidekick_th_lra.ty = a +val a : Term.term = a # let b = Uconst.uconst_of_str tstore "b" [] real;; -val b : Sidekick_th_lra.ty = b +val b : Term.term = b # Term.ty a;; -- : Sidekick_th_lra.ty = Real +- : Term.term = Real # let a_leq_b = LRA_term.leq tstore a b;; -val a_leq_b : Sidekick_th_lra.ty = (<= a b) +val a_leq_b : Term.term = (<= a b) ``` We can play with assertions now: @@ -348,9 +348,9 @@ Sidekick_smt_solver.Solver.Sat # let a_geq_1 = LRA_term.geq tstore a (LRA_term.const tstore (Q.of_int 1));; -val a_geq_1 : Sidekick_th_lra.ty = (>= a 1) +val a_geq_1 : Term.term = (>= a 1) # let b_leq_half = LRA_term.(leq tstore b (LRA_term.const tstore (Q.of_string "1/2")));; -val b_leq_half : Sidekick_th_lra.ty = (<= b 1/2) +val b_leq_half : Term.term = (<= b 1/2) # let res = Solver.solve solver ~assumptions:[Solver.mk_lit_t solver p; @@ -378,25 +378,25 @@ an uninterpreted type. ```ocaml # let u = Ty.uninterpreted_str tstore "u";; -val u : Sidekick_th_lra.ty = u +val u : Term.term = u # let u1 = Uconst.uconst_of_str tstore "u1" [] u;; -val u1 : Sidekick_th_lra.ty = u1 +val u1 : Term.term = u1 # let u2 = Uconst.uconst_of_str tstore "u2" [] u;; -val u2 : Sidekick_th_lra.ty = u2 +val u2 : Term.term = u2 # let u3 = Uconst.uconst_of_str tstore "u3" [] u;; -val u3 : Sidekick_th_lra.ty = u3 +val u3 : Term.term = u3 # let f1 = Uconst.uconst_of_str tstore "f1" [u] u;; -val f1 : Sidekick_th_lra.ty = f1 +val f1 : Term.term = f1 # Term.view f1;; - : Term.view = Sidekick_base.Term.E_const f1 # let f1_u1 = Term.app_l tstore f1 [u1];; -val f1_u1 : Sidekick_th_lra.ty = (f1 u1) +val f1_u1 : Term.term = (f1 u1) # Term.ty f1_u1;; -- : Sidekick_th_lra.ty = u +- : Term.term = u # Term.view f1_u1;; - : Term.view = Sidekick_base.Term.E_app (f1, u1) ``` @@ -409,7 +409,7 @@ val solver : solver = # (* helper *) let appf1 x = Term.app_l tstore f1 x;; -val appf1 : Sidekick_th_lra.ty list -> Sidekick_th_lra.ty = +val appf1 : Term.term list -> Term.term = # Solver.assert_term solver (Term.eq tstore u2 (appf1 [u1]));; - : unit = () From 2a0feed32c79c06610e69f9c4dcc9aa3e65863db Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 20:48:32 -0400 Subject: [PATCH 168/174] format --- src/smt/registry.ml | 55 ++++++++++++++++++++++---------------------- src/smt/registry.mli | 16 ++++++------- 2 files changed, 35 insertions(+), 36 deletions(-) diff --git a/src/smt/registry.ml b/src/smt/registry.ml index f2450d1b..1a66b948 100644 --- a/src/smt/registry.ml +++ b/src/smt/registry.ml @@ -1,37 +1,38 @@ +(* registry keys *) +module type KEY = sig + type elt - (* registry keys *) - module type KEY = sig - type elt + val id : int - val id : int + exception E of elt +end - exception E of elt - end +type 'a key = (module KEY with type elt = 'a) +type t = { tbl: exn Util.Int_tbl.t } [@@unboxed] - type 'a key = (module KEY with type elt = 'a) - type t = { tbl: exn Util.Int_tbl.t } [@@unboxed] +let create () : t = { tbl = Util.Int_tbl.create 8 } - let create () : t = { tbl = Util.Int_tbl.create 8 } - let n_ = ref 0 +(* TODO: use atomic *) +let n_ = ref 0 - let create_key (type a) () : a key = - let id = !n_ in - incr n_; - let module K = struct - type elt = a +let create_key (type a) () : a key = + let id = !n_ in + incr n_; + let module K = struct + type elt = a - exception E of a + exception E of a - let id = id - end in - (module K) + let id = id + end in + (module K) - let get (type a) (self : t) (k : a key) : _ option = - let (module K : KEY with type elt = a) = k in - match Util.Int_tbl.get self.tbl K.id with - | Some (K.E x) -> Some x - | _ -> None +let get (type a) (self : t) (k : a key) : _ option = + let (module K : KEY with type elt = a) = k in + match Util.Int_tbl.get self.tbl K.id with + | Some (K.E x) -> Some x + | _ -> None - let set (type a) (self : t) (k : a key) (v : a) : unit = - let (module K) = k in - Util.Int_tbl.replace self.tbl K.id (K.E v) +let set (type a) (self : t) (k : a key) (v : a) : unit = + let (module K) = k in + Util.Int_tbl.replace self.tbl K.id (K.E v) diff --git a/src/smt/registry.mli b/src/smt/registry.mli index 0e41bcac..5e41d5bb 100644 --- a/src/smt/registry.mli +++ b/src/smt/registry.mli @@ -1,14 +1,12 @@ - - (** Registry to extract values *) - type t - type 'a key +type t +type 'a key - val create_key : unit -> 'a key - (** Call this statically, typically at program initialization, for +val create_key : unit -> 'a key +(** Call this statically, typically at program initialization, for each distinct key. *) - val create : unit -> t - val get : t -> 'a key -> 'a option - val set : t -> 'a key -> 'a -> unit +val create : unit -> t +val get : t -> 'a key -> 'a option +val set : t -> 'a key -> 'a -> unit From ccb3753668950a8b10dbb7f0e53bfebf92d775f3 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 21:38:20 -0400 Subject: [PATCH 169/174] wip(smt): theory combination --- src/core-logic/term.ml | 10 ++++ src/core-logic/term.mli | 2 + src/smt/solver_internal.ml | 87 ++++++++---------------------- src/smt/solver_internal.mli | 18 +++---- src/smt/th_combination.ml | 62 ++++++++++++++++++++++ src/smt/th_combination.mli | 17 ++++++ src/th-lra/sidekick_th_lra.ml | 99 +++++++++++++++++++---------------- 7 files changed, 174 insertions(+), 121 deletions(-) create mode 100644 src/smt/th_combination.ml create mode 100644 src/smt/th_combination.mli diff --git a/src/core-logic/term.ml b/src/core-logic/term.ml index 689f06c7..fd2cff21 100644 --- a/src/core-logic/term.ml +++ b/src/core-logic/term.ml @@ -55,6 +55,16 @@ let unfold_app (e : term) : term * term list = in aux [] e +let[@inline] is_const e = + match e.view with + | E_const _ -> true + | _ -> false + +let[@inline] is_app e = + match e.view with + | E_app _ -> true + | _ -> false + (* debug printer *) let expr_pp_with_ ~pp_ids ~max_depth out (e : term) : unit = let rec loop k ~depth names out e = diff --git a/src/core-logic/term.mli b/src/core-logic/term.mli index b9d2ac67..adcdff02 100644 --- a/src/core-logic/term.mli +++ b/src/core-logic/term.mli @@ -53,6 +53,8 @@ include WITH_SET_MAP_TBL with type t := t val view : t -> view val unfold_app : t -> t * t list +val is_app : t -> bool +val is_const : t -> bool val iter_dag : ?seen:unit Tbl.t -> iter_ty:bool -> f:(t -> unit) -> t -> unit (** [iter_dag t ~f] calls [f] once on each subterm of [t], [t] included. diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 77ce6b6e..d7e20f3f 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -21,6 +21,7 @@ module type PREPROCESS_ACTS = sig val mk_lit : ?sign:bool -> term -> lit val add_clause : lit list -> step_id -> unit val add_lit : ?default_pol:bool -> lit -> unit + val add_term_needing_combination : term -> unit end type preprocess_actions = (module PREPROCESS_ACTS) @@ -39,10 +40,9 @@ type t = { proof: proof_trace; (** proof logger *) registry: Registry.t; on_progress: (unit, unit) Event.Emitter.t; + th_comb: Th_combination.t; mutable on_partial_check: (t -> theory_actions -> lit Iter.t -> unit) list; mutable on_final_check: (t -> theory_actions -> lit Iter.t -> unit) list; - mutable on_th_combination: - (t -> theory_actions -> (term * value) Iter.t) list; mutable preprocess: preprocess_hook list; mutable model_ask: model_ask_hook list; mutable model_complete: model_completion_hook list; @@ -82,11 +82,11 @@ let add_simplifier (self : t) f : unit = Simplify.add_hook self.simp f let[@inline] has_delayed_actions self = not (Queue.is_empty self.delayed_actions) -let on_th_combination self f = - self.on_th_combination <- f :: self.on_th_combination - let on_preprocess self f = self.preprocess <- f :: self.preprocess +let add_term_needing_combination self t = + Th_combination.add_term_needing_combination self.th_comb t + let on_model ?ask ?complete self = Option.iter (fun f -> self.model_ask <- f :: self.model_ask) ask; Option.iter @@ -130,6 +130,9 @@ let preprocess_term_ (self : t) (t0 : term) : unit = let mk_lit ?sign t : Lit.t = Lit.atom ?sign self.tst t let add_lit ?default_pol lit : unit = delayed_add_lit self ?default_pol lit let add_clause c pr : unit = delayed_add_clause self ~keep:true c pr + + let add_term_needing_combination t = + Th_combination.add_term_needing_combination self.th_comb t end in let acts = (module A : PREPROCESS_ACTS) in @@ -397,33 +400,12 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = (* do theory combination using the congruence closure. Each theory can merge classes, *) -let check_th_combination_ (self : t) (_acts : theory_actions) lits : - (Model.t, th_combination_conflict) result = - (* FIXME - - (* enter model mode, disabling most of congruence closure *) - CC.with_model_mode cc @@ fun () -> - let set_val (t, v) : unit = - Log.debugf 50 (fun k -> - k "(@[solver.th-comb.cc-set-term-value@ %a@ :val %a@])" Term.pp_debug t - Term.pp_debug v); - CC.set_model_value cc t v - in - - (* obtain assignments from the hook, and communicate them to the CC *) - let add_th_values f : unit = - let vals = f self acts in - Iter.iter set_val vals - in - try - List.iter add_th_values self.on_th_combination; - CC.check cc; - let m = mk_model_ self in - Ok m - with Semantic_conflict c -> Error c - *) - let m = mk_model_ self lits in - Ok m +let check_th_combination_ (self : t) (acts : theory_actions) _lits : unit = + let lits_to_decide = Th_combination.pop_new_lits self.th_comb in + if lits_to_decide <> [] then ( + let (module A) = acts in + List.iter (fun lit -> A.add_lit ~default_pol:false lit) lits_to_decide + ) (* call congruence closure, perform the actions it scheduled *) let check_cc_with_acts_ (self : t) (acts : theory_actions) = @@ -471,40 +453,13 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) (* do actual theory combination if nothing changed by pure "final check" *) if not new_work then ( - match check_th_combination_ self acts lits with - | Ok m -> self.last_model <- Some m - | Error { lits; semantic } -> - (* bad model, we add a clause to remove it *) - Log.debugf 5 (fun k -> - k - "(@[solver.th-comb.conflict@ :lits (@[%a@])@ :same-val \ - (@[%a@])@])" - (Util.pp_list Lit.pp) lits - (Util.pp_list - @@ Fmt.Dump.(triple bool Term.pp_debug Term.pp_debug)) - semantic); + check_th_combination_ self acts lits; - let c1 = List.rev_map Lit.neg lits in - let c2 = - semantic - |> List.rev_map (fun (sign, t, u) -> - let eqn = Term.eq self.tst t u in - let lit = Lit.atom ~sign:(not sign) self.tst eqn in - (* make sure to consider the new lit *) - add_lit self acts lit; - lit) - in - - let c = List.rev_append c1 c2 in - let pr = - Proof_trace.add_step self.proof @@ fun () -> Proof_core.lemma_cc c - in - - Log.debugf 20 (fun k -> - k "(@[solver.th-comb.add-semantic-conflict-clause@ %a@])" - (Util.pp_list Lit.pp) c); - (* will add a delayed action *) - add_clause_temp self acts c pr + (* if theory combination didn't add new clauses, compute a model *) + if not (has_delayed_actions self) then ( + let m = mk_model_ self lits in + self.last_model <- Some m + ) ); Perform_delayed_th.top self acts @@ -585,6 +540,7 @@ let create (module A : ARG) ~stat ~proof (tst : Term.store) () : t = stat; simp = Simplify.create tst ~proof; last_model = None; + th_comb = Th_combination.create ~stat tst; on_progress = Event.Emitter.create (); preprocess = []; model_ask = []; @@ -598,7 +554,6 @@ let create (module A : ARG) ~stat ~proof (tst : Term.store) () : t = count_conflict = Stat.mk_int stat "smt.solver.th-conflicts"; on_partial_check = []; on_final_check = []; - on_th_combination = []; level = 0; complete = true; } diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index c9c03255..a28db9e5 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -73,6 +73,10 @@ module type PREPROCESS_ACTS = sig val add_lit : ?default_pol:bool -> lit -> unit (** Ensure the literal will be decided/handled by the SAT solver. *) + + val add_term_needing_combination : term -> unit + (** Declare this term as being a foreign variable in the theory, + which means it needs to go through theory combination. *) end type preprocess_actions = (module PREPROCESS_ACTS) @@ -98,6 +102,10 @@ val preprocess_clause_array : t -> lit array -> step_id -> lit array * step_id val simplify_and_preproc_lit : t -> lit -> lit * step_id option (** Simplify literal then preprocess it *) +val add_term_needing_combination : t -> term -> unit +(** Declare this term as being a foreign variable in the theory, + which means it needs to go through theory combination. *) + (** {3 hooks for the theory} *) val raise_conflict : t -> theory_actions -> lit list -> step_id -> 'a @@ -216,16 +224,6 @@ val on_final_check : t -> (t -> theory_actions -> lit Iter.t -> unit) -> unit is given the whole trail. *) -val on_th_combination : - t -> (t -> theory_actions -> (term * value) Iter.t) -> unit -(** Add a hook called during theory combination. - The hook must return an iterator of pairs [(t, v)] - which mean that term [t] has value [v] in the model. - - Terms with the same value (according to {!Term.equal}) will be - merged in the CC; if two terms with different values are merged, - we get a semantic conflict and must pick another model. *) - val declare_pb_is_incomplete : t -> unit (** Declare that, in some theory, the problem is outside the logic fragment that is decidable (e.g. if we meet proper NIA formulas). diff --git a/src/smt/th_combination.ml b/src/smt/th_combination.ml new file mode 100644 index 00000000..e051a0ea --- /dev/null +++ b/src/smt/th_combination.ml @@ -0,0 +1,62 @@ +open Sidekick_core +module T = Term + +type t = { + tst: Term.store; + processed: T.Set.t T.Tbl.t; (** type -> set of terms *) + unprocessed: T.t Vec.t; + new_lits: Lit.t Vec.t; + n_terms: int Stat.counter; + n_lits: int Stat.counter; +} + +let create ?(stat = Stat.global) tst : t = + { + tst; + processed = T.Tbl.create 8; + unprocessed = Vec.create (); + new_lits = Vec.create (); + n_terms = Stat.mk_int stat "smt.thcomb.terms"; + n_lits = Stat.mk_int stat "smt.thcomb.intf-lits"; + } + +let processed_ (self : t) t : bool = + let ty = T.ty t in + match T.Tbl.find_opt self.processed ty with + | None -> false + | Some set -> T.Set.mem t set + +let add_term_needing_combination (self : t) (t : T.t) : unit = + if not (processed_ self t) then ( + Log.debugf 50 (fun k -> k "(@[th.comb.add-term-needing-comb@ %a@])" T.pp t); + Vec.push self.unprocessed t + ) + +let pop_new_lits (self : t) : Lit.t list = + (* first, process new terms, if any *) + while not (Vec.is_empty self.unprocessed) do + let t = Vec.pop_exn self.unprocessed in + let ty = T.ty t in + let set_for_ty = + try T.Tbl.find self.processed ty with Not_found -> T.Set.empty + in + if not (T.Set.mem t set_for_ty) then ( + Stat.incr self.n_terms; + + (* now create [t=u] for each [u] in [set_for_ty] *) + T.Set.iter + (fun u -> + let lit = Lit.make_eq self.tst t u in + Stat.incr self.n_lits; + Vec.push self.new_lits lit) + set_for_ty; + + (* add [t] to the set of processed terms *) + let new_set_for_ty = T.Set.add t set_for_ty in + T.Tbl.replace self.processed ty new_set_for_ty + ) + done; + + let lits = Vec.to_list self.new_lits in + Vec.clear self.new_lits; + lits diff --git a/src/smt/th_combination.mli b/src/smt/th_combination.mli new file mode 100644 index 00000000..5a782e3e --- /dev/null +++ b/src/smt/th_combination.mli @@ -0,0 +1,17 @@ +(** Delayed Theory Combination *) + +open Sidekick_core + +type t + +val create : ?stat:Stat.t -> Term.store -> t + +val add_term_needing_combination : t -> Term.t -> unit +(** [add_term_needing_combination self t] means that [t] occurs as a foreign + variable in another term, so it is important that its theory, and the + theory in which it occurs, agree on it being equal to other + foreign terms. *) + +val pop_new_lits : t -> Lit.t list +(** Get the new literals that the solver needs to decide, so that the + SMT solver gives each theory the same partition of interface equalities. *) diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index 918466d0..f9b4b3d6 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -130,8 +130,6 @@ module Make (A : ARG) = (* : S with module A = A *) struct in_model: unit Term.Tbl.t; (* terms to add to model *) encoded_eqs: unit Term.Tbl.t; (* [a=b] gets clause [a = b <=> (a >= b /\ a <= b)] *) - needs_th_combination: unit Term.Tbl.t; - (* terms that require theory combination *) simp_preds: (Term.t * S_op.t * A.Q.t) Term.Tbl.t; (* term -> its simplex meaning *) simp_defined: LE.t Term.Tbl.t; @@ -157,7 +155,6 @@ module Make (A : ARG) = (* : S with module A = A *) struct simp_preds = Term.Tbl.create 32; simp_defined = Term.Tbl.create 16; encoded_eqs = Term.Tbl.create 8; - needs_th_combination = Term.Tbl.create 8; encoded_le = Comb_map.empty; simplex = SimpSolver.create ~stat (); last_res = None; @@ -275,6 +272,11 @@ module Make (A : ARG) = (* : S with module A = A *) struct | Geq -> S_op.Geq | Gt -> S_op.Gt + (* add [t] to the theory combination system if it's not just a constant + of type Real *) + let add_lra_var_to_th_combination (si : SI.t) (t : term) : unit = + if not (Term.is_const t) then SI.add_term_needing_combination si t + (* TODO: refactor that and {!var_encoding_comb} *) (* turn a linear expression into a single constant and a coeff. This might define a side variable in the simplex. *) @@ -300,17 +302,20 @@ module Make (A : ARG) = (* : S with module A = A *) struct proxy, A.Q.one) (* look for subterms of type Real, for they will need theory combination *) - let on_subterm (self : state) (t : Term.t) : unit = + let on_subterm (_self : state) (si : SI.t) (t : Term.t) : unit = Log.debugf 50 (fun k -> k "(@[lra.cc-on-subterm@ %a@])" Term.pp_debug t); match A.view_as_lra t with - | LRA_other _ when not (A.has_ty_real t) -> () + | LRA_other _ when not (A.has_ty_real t) -> + (* for a non-LRA term [f args], if any of [args] is in LRA, + it needs theory combination *) + let _, args = Term.unfold_app t in + List.iter + (fun arg -> + if A.has_ty_real arg then SI.add_term_needing_combination si arg) + args | LRA_pred _ | LRA_const _ -> () | LRA_op _ | LRA_other _ | LRA_mult _ -> - if not (Term.Tbl.mem self.needs_th_combination t) then ( - Log.debugf 5 (fun k -> - k "(@[lra.needs-th-combination@ %a@])" Term.pp_debug t); - Term.Tbl.add self.needs_th_combination t () - ) + SI.add_term_needing_combination si t (* preprocess linear expressions away *) let preproc_lra (self : state) si (module PA : SI.PREPROCESS_ACTS) @@ -323,7 +328,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct Log.debugf 50 (fun k -> k "(@[lra.declare-term-to-cc@ %a@])" Term.pp_debug t); ignore (CC.add_term (SI.cc si) t : E_node.t); - if sub then on_subterm self t + if sub then on_subterm self si t in match A.view_as_lra t with @@ -369,7 +374,11 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* obtain a single variable for the linear combination *) let v, c_v = le_comb_to_singleton_ self le_comb in declare_term_to_cc ~sub:false v; - LE_.Comb.iter (fun v _ -> declare_term_to_cc ~sub:true v) le_comb; + LE_.Comb.iter + (fun v _ -> + declare_term_to_cc ~sub:true v; + add_lra_var_to_th_combination si v) + le_comb; (* turn into simplex constraint. For example, [c . v <= const] becomes a direct simplex constraint [v <= const/c] @@ -568,41 +577,42 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* evaluate a linear expression *) let eval_le_in_subst_ subst (le : LE.t) = LE.eval (eval_in_subst_ subst) le - (* FIXME: rename, this is more "provide_model_to_cc" *) - let do_th_combination (self : state) _si _acts : _ Iter.t = - Log.debug 1 "(lra.do-th-combinations)"; - let model = - match self.last_res with - | Some (SimpSolver.Sat m) -> m - | _ -> assert false - in + (* FIXME: rework into model creation + let do_th_combination (self : state) _si _acts : _ Iter.t = + Log.debug 1 "(lra.do-th-combinations)"; + let model = + match self.last_res with + | Some (SimpSolver.Sat m) -> m + | _ -> assert false + in - let vals = Subst.to_iter model |> Term.Tbl.of_iter in + let vals = Subst.to_iter model |> Term.Tbl.of_iter in - (* also include terms that occur under function symbols, if they're - not in the model already *) - Term.Tbl.iter - (fun t () -> - if not (Term.Tbl.mem vals t) then ( - let v = eval_in_subst_ model t in - Term.Tbl.add vals t v - )) - self.needs_th_combination; + (* also include terms that occur under function symbols, if they're + not in the model already *) + Term.Tbl.iter + (fun t () -> + if not (Term.Tbl.mem vals t) then ( + let v = eval_in_subst_ model t in + Term.Tbl.add vals t v + )) + self.needs_th_combination; - (* also consider subterms that are linear expressions, - and evaluate them using the value of each variable - in that linear expression. For example a term [a + 2b] - is evaluated as [eval(a) + 2 × eval(b)]. *) - Term.Tbl.iter - (fun t le -> - if not (Term.Tbl.mem vals t) then ( - let v = eval_le_in_subst_ model le in - Term.Tbl.add vals t v - )) - self.simp_defined; + (* also consider subterms that are linear expressions, + and evaluate them using the value of each variable + in that linear expression. For example a term [a + 2b] + is evaluated as [eval(a) + 2 × eval(b)]. *) + Term.Tbl.iter + (fun t le -> + if not (Term.Tbl.mem vals t) then ( + let v = eval_le_in_subst_ model le in + Term.Tbl.add vals t v + )) + self.simp_defined; - (* return whole model *) - Term.Tbl.to_iter vals |> Iter.map (fun (t, v) -> t, t_const self v) + (* return whole model *) + Term.Tbl.to_iter vals |> Iter.map (fun (t, v) -> t, t_const self v) + *) (* partial checks is where we add literals from the trail to the simplex. *) @@ -714,7 +724,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct SI.on_partial_check si (partial_check_ st); SI.on_model si ~ask:(model_ask_ st) ~complete:(model_complete_ st); SI.on_cc_is_subterm si (fun (_, _, t) -> - on_subterm st t; + on_subterm st si t; []); SI.on_cc_pre_merge si (fun (_cc, n1, n2, expl) -> match as_const_ (E_node.term n1), as_const_ (E_node.term n2) with @@ -725,7 +735,6 @@ module Make (A : ARG) = (* : S with module A = A *) struct E_node.pp n2); Error (CC.Handler_action.Conflict expl) | _ -> Ok []); - SI.on_th_combination si (do_th_combination st); st let theory = From 5feb5d8e73601905e080725a97a57b51238720c5 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 22:51:16 -0400 Subject: [PATCH 170/174] refactor: new API for combination, with theories claiming terms interface variables are terms claimed by >= 2 theories. Theories now have a unique ID attributed at their creation. --- src/base/Sidekick_base.ml | 2 ++ src/base/th_uf.ml | 24 ++++++++++++++ src/main/main.ml | 2 +- src/smt/Sidekick_smt_solver.ml | 1 + src/smt/solver.ml | 9 ++++-- src/smt/solver.mli | 2 +- src/smt/solver_internal.ml | 8 +---- src/smt/solver_internal.mli | 10 ++---- src/smt/th_combination.ml | 25 ++++++++++++++- src/smt/th_combination.mli | 16 +++++++--- src/smt/theory.ml | 2 +- src/smt/theory_id.ml | 12 +++++++ src/smt/theory_id.mli | 10 ++++++ src/smtlib/Process.ml | 7 ++-- src/smtlib/Process.mli | 1 + src/th-bool-dyn/Sidekick_th_bool_dyn.ml | 2 +- src/th-bool-static/Sidekick_th_bool_static.ml | 2 +- src/th-cstor/Sidekick_th_cstor.ml | 2 +- src/th-data/Sidekick_th_data.ml | 9 +++++- src/th-lra/sidekick_th_lra.ml | 32 ++++++------------- 20 files changed, 122 insertions(+), 56 deletions(-) create mode 100644 src/base/th_uf.ml create mode 100644 src/smt/theory_id.ml create mode 100644 src/smt/theory_id.mli diff --git a/src/base/Sidekick_base.ml b/src/base/Sidekick_base.ml index 66fe4f68..1411d4c2 100644 --- a/src/base/Sidekick_base.ml +++ b/src/base/Sidekick_base.ml @@ -33,6 +33,7 @@ module LRA_term = LRA_term module Th_data = Th_data module Th_bool = Th_bool module Th_lra = Th_lra +module Th_uf = Th_uf let k_th_bool_config = Th_bool.k_config let th_bool = Th_bool.theory @@ -40,3 +41,4 @@ let th_bool_dyn : Solver.theory = Th_bool.theory_dyn let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory let th_lra : Solver.theory = Th_lra.theory +let th_uf : Solver.theory = Th_uf.theory diff --git a/src/base/th_uf.ml b/src/base/th_uf.ml new file mode 100644 index 00000000..efb40ee9 --- /dev/null +++ b/src/base/th_uf.ml @@ -0,0 +1,24 @@ +(** Theory of uninterpreted functions *) + +open Sidekick_core +open Sidekick_smt_solver + +open struct + module SI = Solver_internal + + let on_is_subterm ~th_id (solver : SI.t) (_, _, t) : _ list = + let f, args = Term.unfold_app t in + (match Term.view f, args with + | Term.E_const { Const.c_view = Uconst.Uconst _; _ }, _ :: _ -> + SI.claim_term solver ~th_id t + | _ -> ()); + + [] +end + +let theory : Theory.t = + Theory.make ~name:"uf" + ~create_and_setup:(fun ~id:th_id solver -> + SI.on_cc_is_subterm solver (on_is_subterm ~th_id solver); + ()) + () diff --git a/src/main/main.ml b/src/main/main.ml index 94c99e77..625897a5 100644 --- a/src/main/main.ml +++ b/src/main/main.ml @@ -177,7 +177,7 @@ let main_smt ~config () : _ result = Log.debugf 1 (fun k -> k "(@[main.th-bool.pick@ %S@])" (Sidekick_smt_solver.Theory.name th_bool)); - [ th_bool; Process.th_data; Process.th_lra ] + [ th_bool; Process.th_uf; Process.th_data; Process.th_lra ] in Process.Solver.create_default ~proof ~theories tst in diff --git a/src/smt/Sidekick_smt_solver.ml b/src/smt/Sidekick_smt_solver.ml index a93e20c1..9eb84fdc 100644 --- a/src/smt/Sidekick_smt_solver.ml +++ b/src/smt/Sidekick_smt_solver.ml @@ -13,6 +13,7 @@ module Registry = Registry module Solver_internal = Solver_internal module Solver = Solver module Theory = Theory +module Theory_id = Theory_id type theory = Theory.t type solver = Solver.t diff --git a/src/smt/solver.ml b/src/smt/solver.ml index 3148ab12..5d65eadf 100644 --- a/src/smt/solver.ml +++ b/src/smt/solver.ml @@ -40,6 +40,7 @@ type t = { mutable last_res: res option; stat: Stat.t; proof: P.t; + theory_id_gen: Theory_id.state; n_clause_input: int Stat.counter; n_clause_internal: int Stat.counter; n_solve: int Stat.counter; (* config: Config.t *) @@ -53,8 +54,11 @@ let mk_theory = Theory.make let add_theory_p (type a) (self : t) (th : a Theory.p) : a = let (module Th) = th in - Log.debugf 2 (fun k -> k "(@[smt-solver.add-theory@ :name %S@])" Th.name); - let st = Th.create_and_setup self.si in + let th_id = Theory_id.fresh self.theory_id_gen in + Log.debugf 2 (fun k -> + k "(@[smt-solver.add-theory@ :id %a@ :name %S@])" Theory_id.pp th_id + Th.name); + let st = Th.create_and_setup ~id:th_id self.si in (* add push/pop to the internal solver *) Solver_internal.add_theory_state self.si ~st ~push_level:Th.push_level ~pop_levels:Th.pop_levels; @@ -77,6 +81,7 @@ let create arg ?(stat = Stat.global) ?size ~proof ~theories tst () : t = last_res = None; solver = Sat_solver.create ~proof ?size ~stat (SI.to_sat_plugin si); stat; + theory_id_gen = Theory_id.create (); n_clause_input = Stat.mk_int stat "smt.solver.add-clause.input"; n_clause_internal = Stat.mk_int stat "smt.solver.add-clause.internal"; n_solve = Stat.mk_int stat "smt.solver.solve"; diff --git a/src/smt/solver.mli b/src/smt/solver.mli index 1d6f53a5..dd08c07e 100644 --- a/src/smt/solver.mli +++ b/src/smt/solver.mli @@ -18,7 +18,7 @@ type theory = Theory.t val mk_theory : name:string -> - create_and_setup:(Solver_internal.t -> 'th) -> + create_and_setup:(id:Theory_id.t -> Solver_internal.t -> 'th) -> ?push_level:('th -> unit) -> ?pop_levels:('th -> int -> unit) -> unit -> diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index d7e20f3f..362206b3 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -21,7 +21,6 @@ module type PREPROCESS_ACTS = sig val mk_lit : ?sign:bool -> term -> lit val add_clause : lit list -> step_id -> unit val add_lit : ?default_pol:bool -> lit -> unit - val add_term_needing_combination : term -> unit end type preprocess_actions = (module PREPROCESS_ACTS) @@ -83,9 +82,7 @@ let[@inline] has_delayed_actions self = not (Queue.is_empty self.delayed_actions) let on_preprocess self f = self.preprocess <- f :: self.preprocess - -let add_term_needing_combination self t = - Th_combination.add_term_needing_combination self.th_comb t +let claim_term self ~th_id t = Th_combination.claim_term self.th_comb ~th_id t let on_model ?ask ?complete self = Option.iter (fun f -> self.model_ask <- f :: self.model_ask) ask; @@ -130,9 +127,6 @@ let preprocess_term_ (self : t) (t0 : term) : unit = let mk_lit ?sign t : Lit.t = Lit.atom ?sign self.tst t let add_lit ?default_pol lit : unit = delayed_add_lit self ?default_pol lit let add_clause c pr : unit = delayed_add_clause self ~keep:true c pr - - let add_term_needing_combination t = - Th_combination.add_term_needing_combination self.th_comb t end in let acts = (module A : PREPROCESS_ACTS) in diff --git a/src/smt/solver_internal.mli b/src/smt/solver_internal.mli index a28db9e5..aee6ec58 100644 --- a/src/smt/solver_internal.mli +++ b/src/smt/solver_internal.mli @@ -73,10 +73,6 @@ module type PREPROCESS_ACTS = sig val add_lit : ?default_pol:bool -> lit -> unit (** Ensure the literal will be decided/handled by the SAT solver. *) - - val add_term_needing_combination : term -> unit - (** Declare this term as being a foreign variable in the theory, - which means it needs to go through theory combination. *) end type preprocess_actions = (module PREPROCESS_ACTS) @@ -102,9 +98,9 @@ val preprocess_clause_array : t -> lit array -> step_id -> lit array * step_id val simplify_and_preproc_lit : t -> lit -> lit * step_id option (** Simplify literal then preprocess it *) -val add_term_needing_combination : t -> term -> unit -(** Declare this term as being a foreign variable in the theory, - which means it needs to go through theory combination. *) +val claim_term : t -> th_id:Theory_id.t -> term -> unit +(** Claim a term, for a theory that might decide or merge it with another + term. This is useful for theory combination. *) (** {3 hooks for the theory} *) diff --git a/src/smt/th_combination.ml b/src/smt/th_combination.ml index e051a0ea..d01456b2 100644 --- a/src/smt/th_combination.ml +++ b/src/smt/th_combination.ml @@ -6,6 +6,7 @@ type t = { processed: T.Set.t T.Tbl.t; (** type -> set of terms *) unprocessed: T.t Vec.t; new_lits: Lit.t Vec.t; + claims: Theory_id.Set.t T.Tbl.t; (** term -> theories claiming it *) n_terms: int Stat.counter; n_lits: int Stat.counter; } @@ -15,6 +16,7 @@ let create ?(stat = Stat.global) tst : t = tst; processed = T.Tbl.create 8; unprocessed = Vec.create (); + claims = T.Tbl.create 8; new_lits = Vec.create (); n_terms = Stat.mk_int stat "smt.thcomb.terms"; n_lits = Stat.mk_int stat "smt.thcomb.intf-lits"; @@ -28,10 +30,31 @@ let processed_ (self : t) t : bool = let add_term_needing_combination (self : t) (t : T.t) : unit = if not (processed_ self t) then ( - Log.debugf 50 (fun k -> k "(@[th.comb.add-term-needing-comb@ %a@])" T.pp t); + Log.debugf 50 (fun k -> + k "(@[th.comb.add-term-needing-comb@ `%a`@ :ty `%a`@])" T.pp t T.pp + (T.ty t)); Vec.push self.unprocessed t ) +let claim_term (self : t) ~th_id (t : T.t) : unit = + (* booleans don't need theory combination *) + if T.is_bool (T.ty t) then + () + else ( + Log.debugf 50 (fun k -> + k "(@[th.comb.claim :th-id %a@ `%a`@])" Theory_id.pp th_id T.pp t); + let set = + try T.Tbl.find self.claims t with Not_found -> Theory_id.Set.empty + in + let set' = Theory_id.Set.add th_id set in + if Theory_id.Set.(not (equal set set')) then ( + T.Tbl.replace self.claims t set'; + (* first time we have 2 theories, means we need combination *) + if Theory_id.Set.cardinal set' = 2 then + add_term_needing_combination self t + ) + ) + let pop_new_lits (self : t) : Lit.t list = (* first, process new terms, if any *) while not (Vec.is_empty self.unprocessed) do diff --git a/src/smt/th_combination.mli b/src/smt/th_combination.mli index 5a782e3e..50e7905b 100644 --- a/src/smt/th_combination.mli +++ b/src/smt/th_combination.mli @@ -6,11 +6,17 @@ type t val create : ?stat:Stat.t -> Term.store -> t -val add_term_needing_combination : t -> Term.t -> unit -(** [add_term_needing_combination self t] means that [t] occurs as a foreign - variable in another term, so it is important that its theory, and the - theory in which it occurs, agree on it being equal to other - foreign terms. *) +val claim_term : t -> th_id:Theory_id.t -> Term.t -> unit +(** [claim_term self ~th_id t] means that theory with ID [th_id] + claims the term [t]. + + This means it might assert [t = u] or [t ≠ u] for some other term [u], + or it might assign a value to [t] in the model in case of a SAT answer. + That means it has to agree with other theories on what [t] is equal to. + + If a term is claimed by several theories, it will be eligible for theory + combination. +*) val pop_new_lits : t -> Lit.t list (** Get the new literals that the solver needs to decide, so that the diff --git a/src/smt/theory.ml b/src/smt/theory.ml index 72410afe..da4887f1 100644 --- a/src/smt/theory.ml +++ b/src/smt/theory.ml @@ -19,7 +19,7 @@ module type S = sig type t val name : string - val create_and_setup : Solver_internal.t -> t + val create_and_setup : id:Theory_id.t -> Solver_internal.t -> t val push_level : t -> unit val pop_levels : t -> int -> unit end diff --git a/src/smt/theory_id.ml b/src/smt/theory_id.ml new file mode 100644 index 00000000..9f6f2bc1 --- /dev/null +++ b/src/smt/theory_id.ml @@ -0,0 +1,12 @@ +include CCInt + +type state = int ref + +let create () = ref 1 + +let fresh (self : state) = + let n = !self in + incr self; + n + +module Set = Util.Int_set diff --git a/src/smt/theory_id.mli b/src/smt/theory_id.mli new file mode 100644 index 00000000..21869dd4 --- /dev/null +++ b/src/smt/theory_id.mli @@ -0,0 +1,10 @@ +type t = private int + +include Sidekick_sigs.EQ_ORD_HASH_PRINT with type t := t + +type state + +val create : unit -> state +val fresh : state -> t + +module Set : CCSet.S with type elt = t diff --git a/src/smtlib/Process.ml b/src/smtlib/Process.ml index 57f2b3f6..787335cb 100644 --- a/src/smtlib/Process.ml +++ b/src/smtlib/Process.ml @@ -60,7 +60,7 @@ module Check_cc = struct let theory = Solver.mk_theory ~name:"cc-check" - ~create_and_setup:(fun si -> + ~create_and_setup:(fun ~id:_ si -> let n_calls = Stat.mk_int (SI.stats si) "check-cc.call" in SI.on_cc_conflict si (fun { cc; th; c } -> if not th then ( @@ -335,12 +335,11 @@ let process_stmt ?gc ?restarts ?(pp_cnf = false) ?proof_file ?pp_model | Statement.Stmt_data _ -> E.return () | Statement.Stmt_define _ -> Error.errorf "cannot deal with definitions yet" -module Th_data = Sidekick_base.Th_data -module Th_bool = Sidekick_base.Th_bool -module Th_lra = Sidekick_base.Th_lra +open Sidekick_base let th_bool = Th_bool.theory let th_bool_dyn : Solver.theory = Th_bool.theory_dyn let th_bool_static : Solver.theory = Th_bool.theory_static let th_data : Solver.theory = Th_data.theory let th_lra : Solver.theory = Th_lra.theory +let th_uf = Th_uf.theory diff --git a/src/smtlib/Process.mli b/src/smtlib/Process.mli index 2046c224..54bcb71c 100644 --- a/src/smtlib/Process.mli +++ b/src/smtlib/Process.mli @@ -8,6 +8,7 @@ val th_bool_static : Solver.theory val th_bool : Config.t -> Solver.theory val th_data : Solver.theory val th_lra : Solver.theory +val th_uf : Solver.theory type 'a or_error = ('a, string) CCResult.t diff --git a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml index 43c388fc..0d9c6436 100644 --- a/src/th-bool-dyn/Sidekick_th_bool_dyn.ml +++ b/src/th-bool-dyn/Sidekick_th_bool_dyn.ml @@ -352,7 +352,7 @@ end = struct let final_check (self : state) solver acts (lits : Lit.t Iter.t) = check_ ~final:true self solver acts lits - let create_and_setup (solver : SI.t) : state = + let create_and_setup ~id:_ (solver : SI.t) : state = let tst = SI.tst solver in let stat = SI.stats solver in let self = diff --git a/src/th-bool-static/Sidekick_th_bool_static.ml b/src/th-bool-static/Sidekick_th_bool_static.ml index 72b7eaae..8b4415b7 100644 --- a/src/th-bool-static/Sidekick_th_bool_static.ml +++ b/src/th-bool-static/Sidekick_th_bool_static.ml @@ -287,7 +287,7 @@ end = struct | B_atom _ -> ()); () - let create_and_setup si = + let create_and_setup ~id:_ si = Log.debug 2 "(th-bool.setup)"; let st = create ~stat:(SI.stats si) (SI.tst si) in SI.add_simplifier si (simplify st); diff --git a/src/th-cstor/Sidekick_th_cstor.ml b/src/th-cstor/Sidekick_th_cstor.ml index 52fa1d4d..6708ab35 100644 --- a/src/th-cstor/Sidekick_th_cstor.ml +++ b/src/th-cstor/Sidekick_th_cstor.ml @@ -80,7 +80,7 @@ end = struct let pop_levels ((module P) : t) n = P.pop_levels n let n_levels ((module P) : t) = P.n_levels () - let create_and_setup (si : SI.t) : t = + let create_and_setup ~id:_ (si : SI.t) : t = Log.debug 1 "(setup :th-cstor)"; let self = ST.create_and_setup ~size:32 (SI.cc si) in self diff --git a/src/th-data/Sidekick_th_data.ml b/src/th-data/Sidekick_th_data.ml index b44fdd3e..805efc78 100644 --- a/src/th-data/Sidekick_th_data.ml +++ b/src/th-data/Sidekick_th_data.ml @@ -296,6 +296,7 @@ end = struct module N_tbl = Backtrackable_tbl.Make (E_node) type t = { + th_id: Sidekick_smt_solver.Theory_id.t; tst: Term.store; proof: Proof_trace.t; cstors: ST_cstors.t; (* repr -> cstor for the class *) @@ -463,6 +464,10 @@ end = struct []) | T_cstor _ | T_other _ -> [] + let on_is_subterm (self : t) (si : SI.t) (_cc, _repr, t) : _ list = + if is_data_ty (Term.ty t) then SI.claim_term si ~th_id:self.th_id t; + [] + let cstors_of_ty (ty : ty) : A.Cstor.t list = match A.as_datatype ty with | Ty_data { cstors } -> cstors @@ -783,9 +788,10 @@ end = struct Some (c, args)) | None -> None - let create_and_setup (solver : SI.t) : t = + let create_and_setup ~id:th_id (solver : SI.t) : t = let self = { + th_id; tst = SI.tst solver; proof = SI.proof solver; cstors = ST_cstors.create_and_setup ~size:32 (SI.cc solver); @@ -801,6 +807,7 @@ end = struct Log.debugf 1 (fun k -> k "(setup :%s)" name); SI.on_preprocess solver (preprocess self); SI.on_cc_new_term solver (on_new_term self); + SI.on_cc_is_subterm solver (on_is_subterm self solver); (* note: this needs to happen before we modify the plugin data *) SI.on_cc_pre_merge solver (on_pre_merge self); SI.on_partial_check solver (on_partial_check self); diff --git a/src/th-lra/sidekick_th_lra.ml b/src/th-lra/sidekick_th_lra.ml index f9b4b3d6..c684a874 100644 --- a/src/th-lra/sidekick_th_lra.ml +++ b/src/th-lra/sidekick_th_lra.ml @@ -124,6 +124,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct module ST_exprs = Sidekick_cc.Plugin.Make (Monoid_exprs) type state = { + th_id: Sidekick_smt_solver.Theory_id.t; tst: Term.store; proof: Proof_trace.t; gensym: Gensym.t; @@ -142,11 +143,12 @@ module Make (A : ARG) = (* : S with module A = A *) struct n_conflict: int Stat.counter; } - let create (si : SI.t) : state = + let create ~th_id (si : SI.t) : state = let stat = SI.stats si in let proof = SI.proof si in let tst = SI.tst si in { + th_id; tst; proof; in_model = Term.Tbl.create 8; @@ -272,11 +274,6 @@ module Make (A : ARG) = (* : S with module A = A *) struct | Geq -> S_op.Geq | Gt -> S_op.Gt - (* add [t] to the theory combination system if it's not just a constant - of type Real *) - let add_lra_var_to_th_combination (si : SI.t) (t : term) : unit = - if not (Term.is_const t) then SI.add_term_needing_combination si t - (* TODO: refactor that and {!var_encoding_comb} *) (* turn a linear expression into a single constant and a coeff. This might define a side variable in the simplex. *) @@ -302,20 +299,13 @@ module Make (A : ARG) = (* : S with module A = A *) struct proxy, A.Q.one) (* look for subterms of type Real, for they will need theory combination *) - let on_subterm (_self : state) (si : SI.t) (t : Term.t) : unit = + let on_subterm (self : state) (si : SI.t) (t : Term.t) : unit = Log.debugf 50 (fun k -> k "(@[lra.cc-on-subterm@ %a@])" Term.pp_debug t); match A.view_as_lra t with - | LRA_other _ when not (A.has_ty_real t) -> - (* for a non-LRA term [f args], if any of [args] is in LRA, - it needs theory combination *) - let _, args = Term.unfold_app t in - List.iter - (fun arg -> - if A.has_ty_real arg then SI.add_term_needing_combination si arg) - args + | LRA_other _ when not (A.has_ty_real t) -> () | LRA_pred _ | LRA_const _ -> () | LRA_op _ | LRA_other _ | LRA_mult _ -> - SI.add_term_needing_combination si t + SI.claim_term si ~th_id:self.th_id t (* preprocess linear expressions away *) let preproc_lra (self : state) si (module PA : SI.PREPROCESS_ACTS) @@ -374,11 +364,7 @@ module Make (A : ARG) = (* : S with module A = A *) struct (* obtain a single variable for the linear combination *) let v, c_v = le_comb_to_singleton_ self le_comb in declare_term_to_cc ~sub:false v; - LE_.Comb.iter - (fun v _ -> - declare_term_to_cc ~sub:true v; - add_lra_var_to_th_combination si v) - le_comb; + LE_.Comb.iter (fun v _ -> declare_term_to_cc ~sub:true v) le_comb; (* turn into simplex constraint. For example, [c . v <= const] becomes a direct simplex constraint [v <= const/c] @@ -714,9 +700,9 @@ module Make (A : ARG) = (* : S with module A = A *) struct let k_state = SMT.Registry.create_key () - let create_and_setup si = + let create_and_setup ~id si = Log.debug 2 "(th-lra.setup)"; - let st = create si in + let st = create ~th_id:id si in SMT.Registry.set (SI.registry si) k_state st; SI.add_simplifier si (simplify st); SI.on_preprocess si (preproc_lra st); From 01d0668fc6ed861564d471c3b6b0ba063e48e899 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 23:08:58 -0400 Subject: [PATCH 171/174] fix(sat): check for new atoms in termination check in final_check --- src/sat/solver.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/sat/solver.ml b/src/sat/solver.ml index c751536e..5fc1110b 100644 --- a/src/sat/solver.ml +++ b/src/sat/solver.ml @@ -1734,7 +1734,7 @@ let solve_ ~on_progress (self : t) : unit = if self.elt_head = AVec.size self.trail && has_no_delayed_actions self - && self.next_decisions = [] + && self.next_decisions = [] && H.is_empty self.order then (* nothing more to do, that means the plugin is satisfied with the trail *) From 4c904053911911549501bb4b65d1803bc59ebf5f Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 23:09:29 -0400 Subject: [PATCH 172/174] refactor a bit --- src/smt/solver_internal.ml | 15 +++++---------- src/smt/th_combination.ml | 12 +++++------- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/src/smt/solver_internal.ml b/src/smt/solver_internal.ml index 362206b3..2596b227 100644 --- a/src/smt/solver_internal.ml +++ b/src/smt/solver_internal.ml @@ -392,15 +392,6 @@ let mk_model_ (self : t) (lits : lit Iter.t) : Model.t = compute_fixpoint (); MB.to_model model -(* do theory combination using the congruence closure. Each theory - can merge classes, *) -let check_th_combination_ (self : t) (acts : theory_actions) _lits : unit = - let lits_to_decide = Th_combination.pop_new_lits self.th_comb in - if lits_to_decide <> [] then ( - let (module A) = acts in - List.iter (fun lit -> A.add_lit ~default_pol:false lit) lits_to_decide - ) - (* call congruence closure, perform the actions it scheduled *) let check_cc_with_acts_ (self : t) (acts : theory_actions) = let (module A) = acts in @@ -447,7 +438,11 @@ let assert_lits_ ~final (self : t) (acts : theory_actions) (lits : Lit.t Iter.t) (* do actual theory combination if nothing changed by pure "final check" *) if not new_work then ( - check_th_combination_ self acts lits; + let new_intf_eqns = Th_combination.pop_new_lits self.th_comb in + if new_intf_eqns <> [] then ( + let (module A) = acts in + List.iter (fun lit -> A.add_lit ~default_pol:false lit) new_intf_eqns + ); (* if theory combination didn't add new clauses, compute a model *) if not (has_delayed_actions self) then ( diff --git a/src/smt/th_combination.ml b/src/smt/th_combination.ml index d01456b2..e8b9d33d 100644 --- a/src/smt/th_combination.ml +++ b/src/smt/th_combination.ml @@ -5,7 +5,6 @@ type t = { tst: Term.store; processed: T.Set.t T.Tbl.t; (** type -> set of terms *) unprocessed: T.t Vec.t; - new_lits: Lit.t Vec.t; claims: Theory_id.Set.t T.Tbl.t; (** term -> theories claiming it *) n_terms: int Stat.counter; n_lits: int Stat.counter; @@ -17,7 +16,6 @@ let create ?(stat = Stat.global) tst : t = processed = T.Tbl.create 8; unprocessed = Vec.create (); claims = T.Tbl.create 8; - new_lits = Vec.create (); n_terms = Stat.mk_int stat "smt.thcomb.terms"; n_lits = Stat.mk_int stat "smt.thcomb.intf-lits"; } @@ -56,6 +54,8 @@ let claim_term (self : t) ~th_id (t : T.t) : unit = ) let pop_new_lits (self : t) : Lit.t list = + let lits = ref [] in + (* first, process new terms, if any *) while not (Vec.is_empty self.unprocessed) do let t = Vec.pop_exn self.unprocessed in @@ -66,12 +66,12 @@ let pop_new_lits (self : t) : Lit.t list = if not (T.Set.mem t set_for_ty) then ( Stat.incr self.n_terms; - (* now create [t=u] for each [u] in [set_for_ty] *) + (* now create [t=u] for each [u] in [set_for_ty], and add it to [lits] *) T.Set.iter (fun u -> let lit = Lit.make_eq self.tst t u in Stat.incr self.n_lits; - Vec.push self.new_lits lit) + lits := lit :: !lits) set_for_ty; (* add [t] to the set of processed terms *) @@ -80,6 +80,4 @@ let pop_new_lits (self : t) : Lit.t list = ) done; - let lits = Vec.to_list self.new_lits in - Vec.clear self.new_lits; - lits + !lits From 28ad97d2b71956e76a8a67b96ffed364a62c8aec Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sat, 27 Aug 2022 23:42:19 -0400 Subject: [PATCH 173/174] fix: typecheck issue --- src/smtlib/Typecheck.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/smtlib/Typecheck.ml b/src/smtlib/Typecheck.ml index 46ef5259..61b157f0 100644 --- a/src/smtlib/Typecheck.ml +++ b/src/smtlib/Typecheck.ml @@ -128,13 +128,13 @@ let t_as_q t = | _ -> None *) -let is_real = Ty.is_real +let is_real t = Ty.is_real (T.ty t) (* convert [t] to a real term *) let cast_to_real (ctx : Ctx.t) (t : T.t) : T.t = let conv t = match T.view t with - | _ when Ty.is_real (T.ty t) -> t + | _ when is_real t -> t (* FIXME | T.LIA (Const n) -> T.lra ctx.tst (Const (Q.of_bigint n)) | T.LIA l -> From 83a4ae46c180b0ba73ec92fa707b43509a5aa798 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Sun, 28 Aug 2022 00:20:06 -0400 Subject: [PATCH 174/174] fix: use standard = even for LRA terms the LRA_view is only useful for views, but we build =/neq using builtin = --- src/base/LRA_term.ml | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/base/LRA_term.ml b/src/base/LRA_term.ml index 0367683c..423abfc7 100644 --- a/src/base/LRA_term.ml +++ b/src/base/LRA_term.ml @@ -12,8 +12,8 @@ module Pred = struct let to_string = function | Lt -> "<" | Leq -> "<=" - | Neq -> "!=" - | Eq -> "=" + | Neq -> "!=_LRA" + | Eq -> "=_LRA" | Gt -> ">" | Geq -> ">=" @@ -127,9 +127,13 @@ let mult_by tst q t : term = Term.app tst c t let pred tst p t1 t2 : term = - let ty = Term.(arrow_l tst [ real tst; real tst ] (Term.bool tst)) in - let p = Term.const tst (Const.make (Pred p) ops ~ty) in - Term.app_l tst p [ t1; t2 ] + match p with + | Pred.Eq -> T.eq tst t1 t2 + | Pred.Neq -> T.not tst (T.eq tst t1 t2) + | _ -> + let ty = Term.(arrow_l tst [ real tst; real tst ] (Term.bool tst)) in + let p = Term.const tst (Const.make (Pred p) ops ~ty) in + Term.app_l tst p [ t1; t2 ] let leq tst a b = pred tst Pred.Leq a b let lt tst a b = pred tst Pred.Lt a b @@ -151,6 +155,13 @@ let view (t : term) : _ View.t = match T.view f, args with | T.E_const { Const.c_view = T.C_eq; _ }, [ _; a; b ] when has_ty_real a -> View.LRA_pred (Pred.Eq, a, b) + | T.E_const { Const.c_view = T.C_not; _ }, [ u ] -> + (* might be not-eq *) + let f, args = Term.unfold_app u in + (match T.view f, args with + | T.E_const { Const.c_view = T.C_eq; _ }, [ _; a; b ] when has_ty_real a -> + View.LRA_pred (Pred.Neq, a, b) + | _ -> View.LRA_other t) | T.E_const { Const.c_view = Const q; _ }, [] -> View.LRA_const q | T.E_const { Const.c_view = Pred p; _ }, [ a; b ] -> View.LRA_pred (p, a, b) | T.E_const { Const.c_view = Op op; _ }, [ a; b ] -> View.LRA_op (op, a, b)