moved 'SMT2' (SMT-LIB-2-based SMT module) into Isabelle
authorblanchet
Thu Mar 13 13:18:13 2014 +0100 (2014-03-13)
changeset 56078624faeda77b5
parent 56077 d397030fb27e
child 56079 175ac95720d4
moved 'SMT2' (SMT-LIB-2-based SMT module) into Isabelle
src/HOL/Real.thy
src/HOL/SMT.thy
src/HOL/SMT2.thy
src/HOL/Sledgehammer.thy
src/HOL/Tools/SMT2/smt2_builtin.ML
src/HOL/Tools/SMT2/smt2_config.ML
src/HOL/Tools/SMT2/smt2_datatypes.ML
src/HOL/Tools/SMT2/smt2_failure.ML
src/HOL/Tools/SMT2/smt2_normalize.ML
src/HOL/Tools/SMT2/smt2_real.ML
src/HOL/Tools/SMT2/smt2_setup_solvers.ML
src/HOL/Tools/SMT2/smt2_solver.ML
src/HOL/Tools/SMT2/smt2_translate.ML
src/HOL/Tools/SMT2/smt2_utils.ML
src/HOL/Tools/SMT2/smtlib2.ML
src/HOL/Tools/SMT2/smtlib2_interface.ML
src/HOL/Tools/SMT2/z3_new_interface.ML
src/HOL/Tools/SMT2/z3_new_isar.ML
src/HOL/Tools/SMT2/z3_new_proof.ML
src/HOL/Tools/SMT2/z3_new_proof_literals.ML
src/HOL/Tools/SMT2/z3_new_proof_methods.ML
src/HOL/Tools/SMT2/z3_new_proof_replay.ML
src/HOL/Tools/SMT2/z3_new_proof_rules.ML
src/HOL/Tools/SMT2/z3_new_proof_tools.ML
src/HOL/Tools/SMT2/z3_new_real.ML
src/HOL/Word/Tools/smt2_word.ML
src/HOL/Word/Word.thy
     1.1 --- a/src/HOL/Real.thy	Thu Mar 13 08:56:08 2014 +0100
     1.2 +++ b/src/HOL/Real.thy	Thu Mar 13 13:18:13 2014 +0100
     1.3 @@ -2197,7 +2197,20 @@
     1.4      times_real_inst.times_real uminus_real_inst.uminus_real
     1.5      zero_real_inst.zero_real
     1.6  
     1.7 +
     1.8 +subsection {* Setup for SMT *}
     1.9 +
    1.10  ML_file "Tools/SMT/smt_real.ML"
    1.11  setup SMT_Real.setup
    1.12 +ML_file "Tools/SMT2/smt2_real.ML"
    1.13 +ML_file "Tools/SMT2/z3_new_real.ML"
    1.14 +
    1.15 +lemma [z3_new_rule]:
    1.16 +  "0 + (x::real) = x"
    1.17 +  "x + 0 = x"
    1.18 +  "0 * x = 0"
    1.19 +  "1 * x = x"
    1.20 +  "x + y = y + x"
    1.21 +  by auto
    1.22  
    1.23  end
     2.1 --- a/src/HOL/SMT.thy	Thu Mar 13 08:56:08 2014 +0100
     2.2 +++ b/src/HOL/SMT.thy	Thu Mar 13 13:18:13 2014 +0100
     2.3 @@ -31,14 +31,13 @@
     2.4  quantifier block.
     2.5  *}
     2.6  
     2.7 -datatype pattern = Pattern
     2.8 +typedecl pattern
     2.9  
    2.10 -definition pat :: "'a \<Rightarrow> pattern" where "pat _ = Pattern"
    2.11 -definition nopat :: "'a \<Rightarrow> pattern" where "nopat _ = Pattern"
    2.12 +consts
    2.13 +  pat :: "'a \<Rightarrow> pattern"
    2.14 +  nopat :: "'a \<Rightarrow> pattern"
    2.15  
    2.16 -definition trigger :: "pattern list list \<Rightarrow> bool \<Rightarrow> bool"
    2.17 -where "trigger _ P = P"
    2.18 -
    2.19 +definition trigger :: "pattern list list \<Rightarrow> bool \<Rightarrow> bool" where "trigger _ P = P"
    2.20  
    2.21  
    2.22  subsection {* Quantifier weights *}
    2.23 @@ -67,7 +66,6 @@
    2.24  *}
    2.25  
    2.26  
    2.27 -
    2.28  subsection {* Higher-order encoding *}
    2.29  
    2.30  text {*
    2.31 @@ -88,7 +86,6 @@
    2.32    fun_upd_upd fun_app_def
    2.33  
    2.34  
    2.35 -
    2.36  subsection {* First-order logic *}
    2.37  
    2.38  text {*
    2.39 @@ -107,7 +104,6 @@
    2.40  definition term_false where "term_false = False"
    2.41  
    2.42  
    2.43 -
    2.44  subsection {* Integer division and modulo for Z3 *}
    2.45  
    2.46  definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
    2.47 @@ -117,7 +113,6 @@
    2.48    "z3mod k l = (if 0 \<le> l then k mod l else k mod (-l))"
    2.49  
    2.50  
    2.51 -
    2.52  subsection {* Setup *}
    2.53  
    2.54  ML_file "Tools/SMT/smt_builtin.ML"
    2.55 @@ -426,7 +421,7 @@
    2.56  
    2.57  
    2.58  hide_type (open) pattern
    2.59 -hide_const Pattern fun_app term_true term_false z3div z3mod
    2.60 +hide_const fun_app term_true term_false z3div z3mod
    2.61  hide_const (open) trigger pat nopat weight
    2.62  
    2.63  end
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/SMT2.thy	Thu Mar 13 13:18:13 2014 +0100
     3.3 @@ -0,0 +1,398 @@
     3.4 +(*  Title:      HOL/SMT2.thy
     3.5 +    Author:     Sascha Boehme, TU Muenchen
     3.6 +*)
     3.7 +
     3.8 +header {* Bindings to Satisfiability Modulo Theories (SMT) solvers based on SMT-LIB 2 *}
     3.9 +
    3.10 +theory SMT2
    3.11 +imports Record
    3.12 +keywords "smt2_status" :: diag
    3.13 +begin
    3.14 +
    3.15 +ML_file "Tools/SMT2/smt2_utils.ML"
    3.16 +ML_file "Tools/SMT2/smt2_failure.ML"
    3.17 +ML_file "Tools/SMT2/smt2_config.ML"
    3.18 +
    3.19 +
    3.20 +subsection {* Triggers for quantifier instantiation *}
    3.21 +
    3.22 +text {*
    3.23 +Some SMT solvers support patterns as a quantifier instantiation
    3.24 +heuristics.  Patterns may either be positive terms (tagged by "pat")
    3.25 +triggering quantifier instantiations -- when the solver finds a
    3.26 +term matching a positive pattern, it instantiates the corresponding
    3.27 +quantifier accordingly -- or negative terms (tagged by "nopat")
    3.28 +inhibiting quantifier instantiations.  A list of patterns
    3.29 +of the same kind is called a multipattern, and all patterns in a
    3.30 +multipattern are considered conjunctively for quantifier instantiation.
    3.31 +A list of multipatterns is called a trigger, and their multipatterns
    3.32 +act disjunctively during quantifier instantiation.  Each multipattern
    3.33 +should mention at least all quantified variables of the preceding
    3.34 +quantifier block.
    3.35 +*}
    3.36 +
    3.37 +typedecl pattern
    3.38 +
    3.39 +consts
    3.40 +  pat :: "'a \<Rightarrow> pattern"
    3.41 +  nopat :: "'a \<Rightarrow> pattern"
    3.42 +
    3.43 +definition trigger :: "pattern list list \<Rightarrow> bool \<Rightarrow> bool" where "trigger _ P = P"
    3.44 +
    3.45 +
    3.46 +subsection {* Quantifier weights *}
    3.47 +
    3.48 +text {*
    3.49 +Weight annotations to quantifiers influence the priority of quantifier
    3.50 +instantiations.  They should be handled with care for solvers, which support
    3.51 +them, because incorrect choices of weights might render a problem unsolvable.
    3.52 +*}
    3.53 +
    3.54 +definition weight :: "int \<Rightarrow> bool \<Rightarrow> bool" where "weight _ P = P"
    3.55 +
    3.56 +text {*
    3.57 +Weights must be non-negative.  The value @{text 0} is equivalent to providing
    3.58 +no weight at all.
    3.59 +
    3.60 +Weights should only be used at quantifiers and only inside triggers (if the
    3.61 +quantifier has triggers).  Valid usages of weights are as follows:
    3.62 +
    3.63 +\begin{itemize}
    3.64 +\item
    3.65 +@{term "\<forall>x. trigger [[pat (P x)]] (weight 2 (P x))"}
    3.66 +\item
    3.67 +@{term "\<forall>x. weight 3 (P x)"}
    3.68 +\end{itemize}
    3.69 +*}
    3.70 +
    3.71 +
    3.72 +subsection {* Higher-order encoding *}
    3.73 +
    3.74 +text {*
    3.75 +Application is made explicit for constants occurring with varying
    3.76 +numbers of arguments.  This is achieved by the introduction of the
    3.77 +following constant.
    3.78 +*}
    3.79 +
    3.80 +definition fun_app :: "'a \<Rightarrow> 'a" where "fun_app f = f"
    3.81 +
    3.82 +text {*
    3.83 +Some solvers support a theory of arrays which can be used to encode
    3.84 +higher-order functions.  The following set of lemmas specifies the
    3.85 +properties of such (extensional) arrays.
    3.86 +*}
    3.87 +
    3.88 +lemmas array_rules = ext fun_upd_apply fun_upd_same fun_upd_other  fun_upd_upd fun_app_def
    3.89 +
    3.90 +
    3.91 +subsection {* Integer division and modulo for Z3 *}
    3.92 +
    3.93 +definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
    3.94 +  "z3div k l = (if 0 \<le> l then k div l else -(k div (-l)))"
    3.95 +
    3.96 +definition z3mod :: "int \<Rightarrow> int \<Rightarrow> int" where
    3.97 +  "z3mod k l = (if 0 \<le> l then k mod l else k mod (-l))"
    3.98 +
    3.99 +
   3.100 +subsection {* Setup *}
   3.101 +
   3.102 +ML_file "Tools/SMT2/smt2_builtin.ML"
   3.103 +ML_file "Tools/SMT2/smt2_datatypes.ML"
   3.104 +ML_file "Tools/SMT2/smt2_normalize.ML"
   3.105 +ML_file "Tools/SMT2/smt2_translate.ML"
   3.106 +ML_file "Tools/SMT2/smt2_solver.ML"
   3.107 +ML_file "Tools/SMT2/smtlib2.ML"
   3.108 +ML_file "Tools/SMT2/smtlib2_interface.ML"
   3.109 +ML_file "Tools/SMT2/z3_new_interface.ML"
   3.110 +ML_file "Tools/SMT2/z3_new_proof.ML"
   3.111 +ML_file "Tools/SMT2/z3_new_proof_tools.ML"
   3.112 +ML_file "Tools/SMT2/z3_new_proof_literals.ML"
   3.113 +ML_file "Tools/SMT2/z3_new_proof_rules.ML"
   3.114 +ML_file "Tools/SMT2/z3_new_proof_methods.ML"
   3.115 +ML_file "Tools/SMT2/z3_new_proof_replay.ML"
   3.116 +ML_file "Tools/SMT2/z3_new_isar.ML"
   3.117 +ML_file "Tools/SMT2/smt2_setup_solvers.ML"
   3.118 +
   3.119 +method_setup smt2 = {*
   3.120 +  Scan.optional Attrib.thms [] >>
   3.121 +    (fn thms => fn ctxt =>
   3.122 +      METHOD (fn facts => HEADGOAL (SMT2_Solver.smt2_tac ctxt (thms @ facts))))
   3.123 +*} "apply an SMT solver to the current goal (based on SMT-LIB 2)"
   3.124 +
   3.125 +
   3.126 +subsection {* Configuration *}
   3.127 +
   3.128 +text {*
   3.129 +The current configuration can be printed by the command
   3.130 +@{text smt2_status}, which shows the values of most options.
   3.131 +*}
   3.132 +
   3.133 +
   3.134 +
   3.135 +subsection {* General configuration options *}
   3.136 +
   3.137 +text {*
   3.138 +The option @{text smt2_solver} can be used to change the target SMT
   3.139 +solver.  The possible values can be obtained from the @{text smt2_status}
   3.140 +command.
   3.141 +
   3.142 +Due to licensing restrictions, Yices and Z3 are not installed/enabled
   3.143 +by default.  Z3 is free for non-commercial applications and can be enabled
   3.144 +by setting Isabelle system option @{text z3_non_commercial} to @{text yes}.
   3.145 +*}
   3.146 +
   3.147 +declare [[ smt2_solver = z3_new ]]
   3.148 +
   3.149 +text {*
   3.150 +Since SMT solvers are potentially non-terminating, there is a timeout
   3.151 +(given in seconds) to restrict their runtime.  A value greater than
   3.152 +120 (seconds) is in most cases not advisable.
   3.153 +*}
   3.154 +
   3.155 +declare [[ smt2_timeout = 20 ]]
   3.156 +
   3.157 +text {*
   3.158 +SMT solvers apply randomized heuristics.  In case a problem is not
   3.159 +solvable by an SMT solver, changing the following option might help.
   3.160 +*}
   3.161 +
   3.162 +declare [[ smt2_random_seed = 1 ]]
   3.163 +
   3.164 +text {*
   3.165 +In general, the binding to SMT solvers runs as an oracle, i.e, the SMT
   3.166 +solvers are fully trusted without additional checks.  The following
   3.167 +option can cause the SMT solver to run in proof-producing mode, giving
   3.168 +a checkable certificate.  This is currently only implemented for Z3.
   3.169 +*}
   3.170 +
   3.171 +declare [[ smt2_oracle = false ]]
   3.172 +
   3.173 +text {*
   3.174 +Each SMT solver provides several commandline options to tweak its
   3.175 +behaviour.  They can be passed to the solver by setting the following
   3.176 +options.
   3.177 +*}
   3.178 +
   3.179 +(* declare [[ cvc3_options = "" ]] TODO *)
   3.180 +(* declare [[ yices_options = "" ]] TODO *)
   3.181 +(* declare [[ z3_options = "" ]] TODO *)
   3.182 +
   3.183 +text {*
   3.184 +The SMT method provides an inference mechanism to detect simple triggers
   3.185 +in quantified formulas, which might increase the number of problems
   3.186 +solvable by SMT solvers (note: triggers guide quantifier instantiations
   3.187 +in the SMT solver).  To turn it on, set the following option.
   3.188 +*}
   3.189 +
   3.190 +declare [[ smt2_infer_triggers = false ]]
   3.191 +
   3.192 +text {*
   3.193 +Enable the following option to use built-in support for div/mod, datatypes,
   3.194 +and records in Z3.  Currently, this is implemented only in oracle mode.
   3.195 +*}
   3.196 +
   3.197 +declare [[ z3_new_extensions = false ]]
   3.198 +
   3.199 +text {*
   3.200 +The SMT method monomorphizes the given facts, that is, it tries to
   3.201 +instantiate all schematic type variables with fixed types occurring
   3.202 +in the problem.  This is a (possibly nonterminating) fixed-point
   3.203 +construction whose cycles are limited by the following option.
   3.204 +*}
   3.205 +
   3.206 +declare [[ monomorph_max_rounds = 5 ]]
   3.207 +
   3.208 +text {*
   3.209 +In addition, the number of generated monomorphic instances is limited
   3.210 +by the following option.
   3.211 +*}
   3.212 +
   3.213 +declare [[ monomorph_max_new_instances = 500 ]]
   3.214 +
   3.215 +
   3.216 +
   3.217 +subsection {* Certificates *}
   3.218 +
   3.219 +text {*
   3.220 +By setting the option @{text smt2_certificates} to the name of a file,
   3.221 +all following applications of an SMT solver a cached in that file.
   3.222 +Any further application of the same SMT solver (using the very same
   3.223 +configuration) re-uses the cached certificate instead of invoking the
   3.224 +solver.  An empty string disables caching certificates.
   3.225 +
   3.226 +The filename should be given as an explicit path.  It is good
   3.227 +practice to use the name of the current theory (with ending
   3.228 +@{text ".certs"} instead of @{text ".thy"}) as the certificates file.
   3.229 +Certificate files should be used at most once in a certain theory context,
   3.230 +to avoid race conditions with other concurrent accesses.
   3.231 +*}
   3.232 +
   3.233 +declare [[ smt2_certificates = "" ]]
   3.234 +
   3.235 +text {*
   3.236 +The option @{text smt2_read_only_certificates} controls whether only
   3.237 +stored certificates are should be used or invocation of an SMT solver
   3.238 +is allowed.  When set to @{text true}, no SMT solver will ever be
   3.239 +invoked and only the existing certificates found in the configured
   3.240 +cache are used;  when set to @{text false} and there is no cached
   3.241 +certificate for some proposition, then the configured SMT solver is
   3.242 +invoked.
   3.243 +*}
   3.244 +
   3.245 +declare [[ smt2_read_only_certificates = false ]]
   3.246 +
   3.247 +
   3.248 +
   3.249 +subsection {* Tracing *}
   3.250 +
   3.251 +text {*
   3.252 +The SMT method, when applied, traces important information.  To
   3.253 +make it entirely silent, set the following option to @{text false}.
   3.254 +*}
   3.255 +
   3.256 +declare [[ smt2_verbose = true ]]
   3.257 +
   3.258 +text {*
   3.259 +For tracing the generated problem file given to the SMT solver as
   3.260 +well as the returned result of the solver, the option
   3.261 +@{text smt2_trace} should be set to @{text true}.
   3.262 +*}
   3.263 +
   3.264 +declare [[ smt2_trace = false ]]
   3.265 +
   3.266 +text {*
   3.267 +From the set of assumptions given to the SMT solver, those assumptions
   3.268 +used in the proof are traced when the following option is set to
   3.269 +@{term true}.  This only works for Z3 when it runs in non-oracle mode
   3.270 +(see options @{text smt2_solver} and @{text smt2_oracle} above).
   3.271 +*}
   3.272 +
   3.273 +declare [[ smt2_trace_used_facts = false ]]
   3.274 +
   3.275 +
   3.276 +subsection {* Schematic rules for Z3 proof reconstruction *}
   3.277 +
   3.278 +text {*
   3.279 +Several prof rules of Z3 are not very well documented.  There are two
   3.280 +lemma groups which can turn failing Z3 proof reconstruction attempts
   3.281 +into succeeding ones: the facts in @{text z3_rule} are tried prior to
   3.282 +any implemented reconstruction procedure for all uncertain Z3 proof
   3.283 +rules;  the facts in @{text z3_simp} are only fed to invocations of
   3.284 +the simplifier when reconstructing theory-specific proof steps.
   3.285 +*}
   3.286 +
   3.287 +lemmas [z3_new_rule] =
   3.288 +  refl eq_commute conj_commute disj_commute simp_thms nnf_simps
   3.289 +  ring_distribs field_simps times_divide_eq_right times_divide_eq_left
   3.290 +  if_True if_False not_not
   3.291 +
   3.292 +lemma [z3_new_rule]:
   3.293 +  "(P \<and> Q) = (\<not>(\<not>P \<or> \<not>Q))"
   3.294 +  "(P \<and> Q) = (\<not>(\<not>Q \<or> \<not>P))"
   3.295 +  "(\<not>P \<and> Q) = (\<not>(P \<or> \<not>Q))"
   3.296 +  "(\<not>P \<and> Q) = (\<not>(\<not>Q \<or> P))"
   3.297 +  "(P \<and> \<not>Q) = (\<not>(\<not>P \<or> Q))"
   3.298 +  "(P \<and> \<not>Q) = (\<not>(Q \<or> \<not>P))"
   3.299 +  "(\<not>P \<and> \<not>Q) = (\<not>(P \<or> Q))"
   3.300 +  "(\<not>P \<and> \<not>Q) = (\<not>(Q \<or> P))"
   3.301 +  by auto
   3.302 +
   3.303 +lemma [z3_new_rule]:
   3.304 +  "(P \<longrightarrow> Q) = (Q \<or> \<not>P)"
   3.305 +  "(\<not>P \<longrightarrow> Q) = (P \<or> Q)"
   3.306 +  "(\<not>P \<longrightarrow> Q) = (Q \<or> P)"
   3.307 +  "(True \<longrightarrow> P) = P"
   3.308 +  "(P \<longrightarrow> True) = True"
   3.309 +  "(False \<longrightarrow> P) = True"
   3.310 +  "(P \<longrightarrow> P) = True"
   3.311 +  by auto
   3.312 +
   3.313 +lemma [z3_new_rule]:
   3.314 +  "((P = Q) \<longrightarrow> R) = (R | (Q = (\<not>P)))"
   3.315 +  by auto
   3.316 +
   3.317 +lemma [z3_new_rule]:
   3.318 +  "(\<not>True) = False"
   3.319 +  "(\<not>False) = True"
   3.320 +  "(x = x) = True"
   3.321 +  "(P = True) = P"
   3.322 +  "(True = P) = P"
   3.323 +  "(P = False) = (\<not>P)"
   3.324 +  "(False = P) = (\<not>P)"
   3.325 +  "((\<not>P) = P) = False"
   3.326 +  "(P = (\<not>P)) = False"
   3.327 +  "((\<not>P) = (\<not>Q)) = (P = Q)"
   3.328 +  "\<not>(P = (\<not>Q)) = (P = Q)"
   3.329 +  "\<not>((\<not>P) = Q) = (P = Q)"
   3.330 +  "(P \<noteq> Q) = (Q = (\<not>P))"
   3.331 +  "(P = Q) = ((\<not>P \<or> Q) \<and> (P \<or> \<not>Q))"
   3.332 +  "(P \<noteq> Q) = ((\<not>P \<or> \<not>Q) \<and> (P \<or> Q))"
   3.333 +  by auto
   3.334 +
   3.335 +lemma [z3_new_rule]:
   3.336 +  "(if P then P else \<not>P) = True"
   3.337 +  "(if \<not>P then \<not>P else P) = True"
   3.338 +  "(if P then True else False) = P"
   3.339 +  "(if P then False else True) = (\<not>P)"
   3.340 +  "(if P then Q else True) = ((\<not>P) \<or> Q)"
   3.341 +  "(if P then Q else True) = (Q \<or> (\<not>P))"
   3.342 +  "(if P then Q else \<not>Q) = (P = Q)"
   3.343 +  "(if P then Q else \<not>Q) = (Q = P)"
   3.344 +  "(if P then \<not>Q else Q) = (P = (\<not>Q))"
   3.345 +  "(if P then \<not>Q else Q) = ((\<not>Q) = P)"
   3.346 +  "(if \<not>P then x else y) = (if P then y else x)"
   3.347 +  "(if P then (if Q then x else y) else x) = (if P \<and> (\<not>Q) then y else x)"
   3.348 +  "(if P then (if Q then x else y) else x) = (if (\<not>Q) \<and> P then y else x)"
   3.349 +  "(if P then (if Q then x else y) else y) = (if P \<and> Q then x else y)"
   3.350 +  "(if P then (if Q then x else y) else y) = (if Q \<and> P then x else y)"
   3.351 +  "(if P then x else if P then y else z) = (if P then x else z)"
   3.352 +  "(if P then x else if Q then x else y) = (if P \<or> Q then x else y)"
   3.353 +  "(if P then x else if Q then x else y) = (if Q \<or> P then x else y)"
   3.354 +  "(if P then x = y else x = z) = (x = (if P then y else z))"
   3.355 +  "(if P then x = y else y = z) = (y = (if P then x else z))"
   3.356 +  "(if P then x = y else z = y) = (y = (if P then x else z))"
   3.357 +  by auto
   3.358 +
   3.359 +lemma [z3_new_rule]:
   3.360 +  "0 + (x::int) = x"
   3.361 +  "x + 0 = x"
   3.362 +  "x + x = 2 * x"
   3.363 +  "0 * x = 0"
   3.364 +  "1 * x = x"
   3.365 +  "x + y = y + x"
   3.366 +  by auto
   3.367 +
   3.368 +lemma [z3_new_rule]:  (* for def-axiom *)
   3.369 +  "P = Q \<or> P \<or> Q"
   3.370 +  "P = Q \<or> \<not>P \<or> \<not>Q"
   3.371 +  "(\<not>P) = Q \<or> \<not>P \<or> Q"
   3.372 +  "(\<not>P) = Q \<or> P \<or> \<not>Q"
   3.373 +  "P = (\<not>Q) \<or> \<not>P \<or> Q"
   3.374 +  "P = (\<not>Q) \<or> P \<or> \<not>Q"
   3.375 +  "P \<noteq> Q \<or> P \<or> \<not>Q"
   3.376 +  "P \<noteq> Q \<or> \<not>P \<or> Q"
   3.377 +  "P \<noteq> (\<not>Q) \<or> P \<or> Q"
   3.378 +  "(\<not>P) \<noteq> Q \<or> P \<or> Q"
   3.379 +  "P \<or> Q \<or> P \<noteq> (\<not>Q)"
   3.380 +  "P \<or> Q \<or> (\<not>P) \<noteq> Q"
   3.381 +  "P \<or> \<not>Q \<or> P \<noteq> Q"
   3.382 +  "\<not>P \<or> Q \<or> P \<noteq> Q"
   3.383 +  "P \<or> y = (if P then x else y)"
   3.384 +  "P \<or> (if P then x else y) = y"
   3.385 +  "\<not>P \<or> x = (if P then x else y)"
   3.386 +  "\<not>P \<or>  (if P then x else y) = x"
   3.387 +  "P \<or> R \<or> \<not>(if P then Q else R)"
   3.388 +  "\<not>P \<or> Q \<or> \<not>(if P then Q else R)"
   3.389 +  "\<not>(if P then Q else R) \<or> \<not>P \<or> Q"
   3.390 +  "\<not>(if P then Q else R) \<or> P \<or> R"
   3.391 +  "(if P then Q else R) \<or> \<not>P \<or> \<not>Q"
   3.392 +  "(if P then Q else R) \<or> P \<or> \<not>R"
   3.393 +  "(if P then \<not>Q else R) \<or> \<not>P \<or> Q"
   3.394 +  "(if P then Q else \<not>R) \<or> P \<or> R"
   3.395 +  by auto
   3.396 +
   3.397 +hide_type (open) pattern
   3.398 +hide_const fun_app z3div z3mod
   3.399 +hide_const (open) trigger pat nopat weight
   3.400 +
   3.401 +end
     4.1 --- a/src/HOL/Sledgehammer.thy	Thu Mar 13 08:56:08 2014 +0100
     4.2 +++ b/src/HOL/Sledgehammer.thy	Thu Mar 13 13:18:13 2014 +0100
     4.3 @@ -7,7 +7,7 @@
     4.4  header {* Sledgehammer: Isabelle--ATP Linkup *}
     4.5  
     4.6  theory Sledgehammer
     4.7 -imports ATP SMT
     4.8 +imports ATP SMT SMT2
     4.9  keywords "sledgehammer" :: diag and "sledgehammer_params" :: thy_decl
    4.10  begin
    4.11  
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Tools/SMT2/smt2_builtin.ML	Thu Mar 13 13:18:13 2014 +0100
     5.3 @@ -0,0 +1,231 @@
     5.4 +(*  Title:      HOL/Tools/SMT2/smt2_builtin.ML
     5.5 +    Author:     Sascha Boehme, TU Muenchen
     5.6 +
     5.7 +Tables of types and terms directly supported by SMT solvers.
     5.8 +*)
     5.9 +
    5.10 +signature SMT2_BUILTIN =
    5.11 +sig
    5.12 +  (*for experiments*)
    5.13 +  val filter_builtins: (typ -> bool) -> Proof.context -> Proof.context
    5.14 +
    5.15 +  (*built-in types*)
    5.16 +  val add_builtin_typ: SMT2_Utils.class ->
    5.17 +    typ * (typ -> string option) * (typ -> int -> string option) ->
    5.18 +    Context.generic -> Context.generic
    5.19 +  val add_builtin_typ_ext: typ * (typ -> bool) -> Context.generic ->
    5.20 +    Context.generic
    5.21 +  val dest_builtin_typ: Proof.context -> typ -> string option
    5.22 +  val is_builtin_typ_ext: Proof.context -> typ -> bool
    5.23 +
    5.24 +  (*built-in numbers*)
    5.25 +  val dest_builtin_num: Proof.context -> term -> (string * typ) option
    5.26 +  val is_builtin_num: Proof.context -> term -> bool
    5.27 +  val is_builtin_num_ext: Proof.context -> term -> bool
    5.28 +
    5.29 +  (*built-in functions*)
    5.30 +  type 'a bfun = Proof.context -> typ -> term list -> 'a
    5.31 +  type bfunr = string * int * term list * (term list -> term)
    5.32 +  val add_builtin_fun: SMT2_Utils.class ->
    5.33 +    (string * typ) * bfunr option bfun -> Context.generic -> Context.generic
    5.34 +  val add_builtin_fun': SMT2_Utils.class -> term * string -> Context.generic ->
    5.35 +    Context.generic
    5.36 +  val add_builtin_fun_ext: (string * typ) * term list bfun ->
    5.37 +    Context.generic -> Context.generic
    5.38 +  val add_builtin_fun_ext': string * typ -> Context.generic -> Context.generic
    5.39 +  val add_builtin_fun_ext'': string -> Context.generic -> Context.generic
    5.40 +  val dest_builtin_fun: Proof.context -> string * typ -> term list ->
    5.41 +    bfunr option
    5.42 +  val dest_builtin_eq: Proof.context -> term -> term -> bfunr option
    5.43 +  val dest_builtin_pred: Proof.context -> string * typ -> term list ->
    5.44 +    bfunr option
    5.45 +  val dest_builtin_conn: Proof.context -> string * typ -> term list ->
    5.46 +    bfunr option
    5.47 +  val dest_builtin: Proof.context -> string * typ -> term list -> bfunr option
    5.48 +  val dest_builtin_ext: Proof.context -> string * typ -> term list ->
    5.49 +    term list option
    5.50 +  val is_builtin_fun: Proof.context -> string * typ -> term list -> bool
    5.51 +  val is_builtin_fun_ext: Proof.context -> string * typ -> term list -> bool
    5.52 +end
    5.53 +
    5.54 +structure SMT2_Builtin: SMT2_BUILTIN =
    5.55 +struct
    5.56 +
    5.57 +
    5.58 +(* built-in tables *)
    5.59 +
    5.60 +datatype ('a, 'b) kind = Ext of 'a | Int of 'b
    5.61 +
    5.62 +type ('a, 'b) ttab = ((typ * ('a, 'b) kind) Ord_List.T) SMT2_Utils.dict 
    5.63 +
    5.64 +fun typ_ord ((T, _), (U, _)) =
    5.65 +  let
    5.66 +    fun tord (TVar _, Type _) = GREATER
    5.67 +      | tord (Type _, TVar _) = LESS
    5.68 +      | tord (Type (n, Ts), Type (m, Us)) =
    5.69 +          if n = m then list_ord tord (Ts, Us)
    5.70 +          else Term_Ord.typ_ord (T, U)
    5.71 +      | tord TU = Term_Ord.typ_ord TU
    5.72 +  in tord (T, U) end
    5.73 +
    5.74 +fun insert_ttab cs T f =
    5.75 +  SMT2_Utils.dict_map_default (cs, [])
    5.76 +    (Ord_List.insert typ_ord (perhaps (try Logic.varifyT_global) T, f))
    5.77 +
    5.78 +fun merge_ttab ttabp =
    5.79 +  SMT2_Utils.dict_merge (Ord_List.merge typ_ord) ttabp
    5.80 +
    5.81 +fun lookup_ttab ctxt ttab T =
    5.82 +  let fun match (U, _) = Sign.typ_instance (Proof_Context.theory_of ctxt) (T, U)
    5.83 +  in
    5.84 +    get_first (find_first match)
    5.85 +      (SMT2_Utils.dict_lookup ttab (SMT2_Config.solver_class_of ctxt))
    5.86 +  end
    5.87 +
    5.88 +type ('a, 'b) btab = ('a, 'b) ttab Symtab.table
    5.89 +
    5.90 +fun insert_btab cs n T f =
    5.91 +  Symtab.map_default (n, []) (insert_ttab cs T f)
    5.92 +
    5.93 +fun merge_btab btabp = Symtab.join (K merge_ttab) btabp
    5.94 +
    5.95 +fun lookup_btab ctxt btab (n, T) =
    5.96 +  (case Symtab.lookup btab n of
    5.97 +    NONE => NONE
    5.98 +  | SOME ttab => lookup_ttab ctxt ttab T)
    5.99 +
   5.100 +type 'a bfun = Proof.context -> typ -> term list -> 'a
   5.101 +
   5.102 +type bfunr = string * int * term list * (term list -> term)
   5.103 +
   5.104 +structure Builtins = Generic_Data
   5.105 +(
   5.106 +  type T =
   5.107 +    (typ -> bool, (typ -> string option) * (typ -> int -> string option)) ttab *
   5.108 +    (term list bfun, bfunr option bfun) btab
   5.109 +  val empty = ([], Symtab.empty)
   5.110 +  val extend = I
   5.111 +  fun merge ((t1, b1), (t2, b2)) = (merge_ttab (t1, t2), merge_btab (b1, b2))
   5.112 +)
   5.113 +
   5.114 +fun filter_ttab keep_T = map (apsnd (filter (keep_T o fst)))
   5.115 +
   5.116 +fun filter_builtins keep_T =
   5.117 +  Context.proof_map (Builtins.map (fn (ttab, btab) =>
   5.118 +    (filter_ttab keep_T ttab, Symtab.map (K (filter_ttab keep_T)) btab)))
   5.119 +
   5.120 +
   5.121 +(* built-in types *)
   5.122 +
   5.123 +fun add_builtin_typ cs (T, f, g) =
   5.124 +  Builtins.map (apfst (insert_ttab cs T (Int (f, g))))
   5.125 +
   5.126 +fun add_builtin_typ_ext (T, f) =
   5.127 +  Builtins.map (apfst (insert_ttab SMT2_Utils.basicC T (Ext f)))
   5.128 +
   5.129 +fun lookup_builtin_typ ctxt =
   5.130 +  lookup_ttab ctxt (fst (Builtins.get (Context.Proof ctxt)))
   5.131 +
   5.132 +fun dest_builtin_typ ctxt T =
   5.133 +  (case lookup_builtin_typ ctxt T of
   5.134 +    SOME (_, Int (f, _)) => f T
   5.135 +  | _ => NONE) 
   5.136 +
   5.137 +fun is_builtin_typ_ext ctxt T =
   5.138 +  (case lookup_builtin_typ ctxt T of
   5.139 +    SOME (_, Int (f, _)) => is_some (f T)
   5.140 +  | SOME (_, Ext f) => f T
   5.141 +  | NONE => false)
   5.142 +
   5.143 +
   5.144 +(* built-in numbers *)
   5.145 +
   5.146 +fun dest_builtin_num ctxt t =
   5.147 +  (case try HOLogic.dest_number t of
   5.148 +    NONE => NONE
   5.149 +  | SOME (T, i) =>
   5.150 +      if i < 0 then NONE else
   5.151 +        (case lookup_builtin_typ ctxt T of
   5.152 +          SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
   5.153 +        | _ => NONE))
   5.154 +
   5.155 +val is_builtin_num = is_some oo dest_builtin_num
   5.156 +
   5.157 +fun is_builtin_num_ext ctxt t =
   5.158 +  (case try HOLogic.dest_number t of
   5.159 +    NONE => false
   5.160 +  | SOME (T, _) => is_builtin_typ_ext ctxt T)
   5.161 +
   5.162 +
   5.163 +(* built-in functions *)
   5.164 +
   5.165 +fun add_builtin_fun cs ((n, T), f) =
   5.166 +  Builtins.map (apsnd (insert_btab cs n T (Int f)))
   5.167 +
   5.168 +fun add_builtin_fun' cs (t, n) =
   5.169 +  let
   5.170 +    val c as (m, T) = Term.dest_Const t
   5.171 +    fun app U ts = Term.list_comb (Const (m, U), ts)
   5.172 +    fun bfun _ U ts = SOME (n, length (Term.binder_types T), ts, app U)
   5.173 +  in add_builtin_fun cs (c, bfun) end
   5.174 +
   5.175 +fun add_builtin_fun_ext ((n, T), f) =
   5.176 +  Builtins.map (apsnd (insert_btab SMT2_Utils.basicC n T (Ext f)))
   5.177 +
   5.178 +fun add_builtin_fun_ext' c = add_builtin_fun_ext (c, fn _ => fn _ => I)
   5.179 +
   5.180 +fun add_builtin_fun_ext'' n context =
   5.181 +  let val thy = Context.theory_of context
   5.182 +  in add_builtin_fun_ext' (n, Sign.the_const_type thy n) context end
   5.183 +
   5.184 +fun lookup_builtin_fun ctxt =
   5.185 +  lookup_btab ctxt (snd (Builtins.get (Context.Proof ctxt)))
   5.186 +
   5.187 +fun dest_builtin_fun ctxt (c as (_, T)) ts =
   5.188 +  (case lookup_builtin_fun ctxt c of
   5.189 +    SOME (_, Int f) => f ctxt T ts
   5.190 +  | _ => NONE)
   5.191 +
   5.192 +fun dest_builtin_eq ctxt t u =
   5.193 +  let
   5.194 +    val aT = TFree (Name.aT, @{sort type})
   5.195 +    val c = (@{const_name HOL.eq}, aT --> aT --> @{typ bool})
   5.196 +    fun mk ts = Term.list_comb (HOLogic.eq_const (Term.fastype_of (hd ts)), ts)
   5.197 +  in
   5.198 +    dest_builtin_fun ctxt c []
   5.199 +    |> Option.map (fn (n, i, _, _) => (n, i, [t, u], mk))
   5.200 +  end
   5.201 +
   5.202 +fun special_builtin_fun pred ctxt (c as (_, T)) ts =
   5.203 +  if pred (Term.body_type T, Term.binder_types T) then
   5.204 +    dest_builtin_fun ctxt c ts
   5.205 +  else NONE
   5.206 +
   5.207 +fun dest_builtin_pred ctxt = special_builtin_fun (equal @{typ bool} o fst) ctxt
   5.208 +
   5.209 +fun dest_builtin_conn ctxt =
   5.210 +  special_builtin_fun (forall (equal @{typ bool}) o (op ::)) ctxt
   5.211 +
   5.212 +fun dest_builtin ctxt c ts =
   5.213 +  let val t = Term.list_comb (Const c, ts)
   5.214 +  in
   5.215 +    (case dest_builtin_num ctxt t of
   5.216 +      SOME (n, _) => SOME (n, 0, [], K t)
   5.217 +    | NONE => dest_builtin_fun ctxt c ts)
   5.218 +  end
   5.219 +
   5.220 +fun dest_builtin_fun_ext ctxt (c as (_, T)) ts =    
   5.221 +  (case lookup_builtin_fun ctxt c of
   5.222 +    SOME (_, Int f) => f ctxt T ts |> Option.map (fn (_, _, us, _) => us)
   5.223 +  | SOME (_, Ext f) => SOME (f ctxt T ts)
   5.224 +  | NONE => NONE)
   5.225 +
   5.226 +fun dest_builtin_ext ctxt c ts =
   5.227 +  if is_builtin_num_ext ctxt (Term.list_comb (Const c, ts)) then SOME []
   5.228 +  else dest_builtin_fun_ext ctxt c ts
   5.229 +
   5.230 +fun is_builtin_fun ctxt c ts = is_some (dest_builtin_fun ctxt c ts)
   5.231 +
   5.232 +fun is_builtin_fun_ext ctxt c ts = is_some (dest_builtin_fun_ext ctxt c ts)
   5.233 +
   5.234 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Tools/SMT2/smt2_config.ML	Thu Mar 13 13:18:13 2014 +0100
     6.3 @@ -0,0 +1,250 @@
     6.4 +(*  Title:      HOL/Tools/SMT2/smt2_config.ML
     6.5 +    Author:     Sascha Boehme, TU Muenchen
     6.6 +
     6.7 +Configuration options and diagnostic tools for SMT.
     6.8 +*)
     6.9 +
    6.10 +signature SMT2_CONFIG =
    6.11 +sig
    6.12 +  (*solver*)
    6.13 +  type solver_info = {
    6.14 +    name: string,
    6.15 +    class: Proof.context -> SMT2_Utils.class,
    6.16 +    avail: unit -> bool,
    6.17 +    options: Proof.context -> string list }
    6.18 +  val add_solver: solver_info -> Context.generic -> Context.generic
    6.19 +  val set_solver_options: string * string -> Context.generic -> Context.generic
    6.20 +  val is_available: Proof.context -> string -> bool
    6.21 +  val available_solvers_of: Proof.context -> string list
    6.22 +  val select_solver: string -> Context.generic -> Context.generic
    6.23 +  val solver_of: Proof.context -> string
    6.24 +  val solver_class_of: Proof.context -> SMT2_Utils.class
    6.25 +  val solver_options_of: Proof.context -> string list
    6.26 +
    6.27 +  (*options*)
    6.28 +  val oracle: bool Config.T
    6.29 +  val timeout: real Config.T
    6.30 +  val random_seed: int Config.T
    6.31 +  val read_only_certificates: bool Config.T
    6.32 +  val verbose: bool Config.T
    6.33 +  val trace: bool Config.T
    6.34 +  val trace_used_facts: bool Config.T
    6.35 +  val monomorph_limit: int Config.T
    6.36 +  val monomorph_instances: int Config.T
    6.37 +  val infer_triggers: bool Config.T
    6.38 +  val filter_only_facts: bool Config.T
    6.39 +  val debug_files: string Config.T
    6.40 +
    6.41 +  (*tools*)
    6.42 +  val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
    6.43 +
    6.44 +  (*diagnostics*)
    6.45 +  val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
    6.46 +  val verbose_msg: Proof.context -> ('a -> string) -> 'a -> unit
    6.47 +
    6.48 +  (*certificates*)
    6.49 +  val select_certificates: string -> Context.generic -> Context.generic
    6.50 +  val certificates_of: Proof.context -> Cache_IO.cache option
    6.51 +
    6.52 +  (*setup*)
    6.53 +  val print_setup: Proof.context -> unit
    6.54 +end
    6.55 +
    6.56 +structure SMT2_Config: SMT2_CONFIG =
    6.57 +struct
    6.58 +
    6.59 +(* solver *)
    6.60 +
    6.61 +type solver_info = {
    6.62 +  name: string,
    6.63 +  class: Proof.context -> SMT2_Utils.class,
    6.64 +  avail: unit -> bool,
    6.65 +  options: Proof.context -> string list }
    6.66 +
    6.67 +(* FIXME just one data slot (record) per program unit *)
    6.68 +structure Solvers = Generic_Data
    6.69 +(
    6.70 +  type T = (solver_info * string list) Symtab.table * string option
    6.71 +  val empty = (Symtab.empty, NONE)
    6.72 +  val extend = I
    6.73 +  fun merge ((ss1, s1), (ss2, s2)) =
    6.74 +    (Symtab.merge (K true) (ss1, ss2), merge_options (s1, s2))
    6.75 +)
    6.76 +
    6.77 +fun set_solver_options (name, options) =
    6.78 +  let val opts = String.tokens (Symbol.is_ascii_blank o str) options
    6.79 +  in Solvers.map (apfst (Symtab.map_entry name (apsnd (K opts)))) end
    6.80 +
    6.81 +fun add_solver (info as {name, ...} : solver_info) context =
    6.82 +  if Symtab.defined (fst (Solvers.get context)) name then
    6.83 +    error ("Solver already registered: " ^ quote name)
    6.84 +  else
    6.85 +    context
    6.86 +    |> Solvers.map (apfst (Symtab.update (name, (info, []))))
    6.87 +    |> Context.map_theory (Attrib.setup (Binding.name (name ^ "_options"))
    6.88 +        (Scan.lift (@{keyword "="} |-- Args.name) >>
    6.89 +          (Thm.declaration_attribute o K o set_solver_options o pair name))
    6.90 +        ("Additional command line options for SMT solver " ^ quote name))
    6.91 +
    6.92 +fun all_solvers_of ctxt = Symtab.keys (fst (Solvers.get (Context.Proof ctxt)))
    6.93 +
    6.94 +fun solver_name_of ctxt = snd (Solvers.get (Context.Proof ctxt))
    6.95 +
    6.96 +fun is_available ctxt name =
    6.97 +  (case Symtab.lookup (fst (Solvers.get (Context.Proof ctxt))) name of
    6.98 +    SOME ({avail, ...}, _) => avail ()
    6.99 +  | NONE => false)
   6.100 +
   6.101 +fun available_solvers_of ctxt =
   6.102 +  filter (is_available ctxt) (all_solvers_of ctxt)
   6.103 +
   6.104 +fun warn_solver (Context.Proof ctxt) name =
   6.105 +      Context_Position.if_visible ctxt
   6.106 +        warning ("The SMT solver " ^ quote name ^ " is not installed.")
   6.107 +  | warn_solver _ _ = ();
   6.108 +
   6.109 +fun select_solver name context =
   6.110 +  let
   6.111 +    val ctxt = Context.proof_of context
   6.112 +    val upd = Solvers.map (apsnd (K (SOME name)))
   6.113 +  in
   6.114 +    if not (member (op =) (all_solvers_of ctxt) name) then
   6.115 +      error ("Trying to select unknown solver: " ^ quote name)
   6.116 +    else if not (is_available ctxt name) then
   6.117 +      (warn_solver context name; upd context)
   6.118 +    else upd context
   6.119 +  end
   6.120 +
   6.121 +fun no_solver_err () = error "No SMT solver selected"
   6.122 +
   6.123 +fun solver_of ctxt =
   6.124 +  (case solver_name_of ctxt of
   6.125 +    SOME name => name
   6.126 +  | NONE => no_solver_err ())
   6.127 +
   6.128 +fun solver_info_of default select ctxt =
   6.129 +  (case Solvers.get (Context.Proof ctxt) of
   6.130 +    (solvers, SOME name) => select (Symtab.lookup solvers name)
   6.131 +  | (_, NONE) => default ())
   6.132 +
   6.133 +fun solver_class_of ctxt =
   6.134 +  let fun class_of ({class, ...}: solver_info, _) = class ctxt
   6.135 +  in solver_info_of no_solver_err (class_of o the) ctxt end
   6.136 +
   6.137 +fun solver_options_of ctxt =
   6.138 +  let
   6.139 +    fun all_options NONE = []
   6.140 +      | all_options (SOME ({options, ...} : solver_info, opts)) =
   6.141 +          opts @ options ctxt
   6.142 +  in solver_info_of (K []) all_options ctxt end
   6.143 +
   6.144 +val setup_solver =
   6.145 +  Attrib.setup @{binding smt2_solver}
   6.146 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
   6.147 +      (Thm.declaration_attribute o K o select_solver))
   6.148 +    "SMT solver configuration"
   6.149 +
   6.150 +
   6.151 +(* options *)
   6.152 +
   6.153 +val oracle = Attrib.setup_config_bool @{binding smt2_oracle} (K true)
   6.154 +val timeout = Attrib.setup_config_real @{binding smt2_timeout} (K 30.0)
   6.155 +val random_seed = Attrib.setup_config_int @{binding smt2_random_seed} (K 1)
   6.156 +val read_only_certificates = Attrib.setup_config_bool @{binding smt2_read_only_certificates} (K false)
   6.157 +val verbose = Attrib.setup_config_bool @{binding smt2_verbose} (K true)
   6.158 +val trace = Attrib.setup_config_bool @{binding smt2_trace} (K false)
   6.159 +val trace_used_facts = Attrib.setup_config_bool @{binding smt2_trace_used_facts} (K false)
   6.160 +val monomorph_limit = Attrib.setup_config_int @{binding smt2_monomorph_limit} (K 10)
   6.161 +val monomorph_instances = Attrib.setup_config_int @{binding smt2_monomorph_instances} (K 500)
   6.162 +val infer_triggers = Attrib.setup_config_bool @{binding smt2_infer_triggers} (K false)
   6.163 +val filter_only_facts = Attrib.setup_config_bool @{binding smt2_filter_only_facts} (K false)
   6.164 +val debug_files = Attrib.setup_config_string @{binding smt2_debug_files} (K "")
   6.165 +
   6.166 +
   6.167 +(* diagnostics *)
   6.168 +
   6.169 +fun cond_trace flag f x = if flag then tracing ("SMT: " ^ f x) else ()
   6.170 +
   6.171 +fun verbose_msg ctxt = cond_trace (Config.get ctxt verbose)
   6.172 +
   6.173 +fun trace_msg ctxt = cond_trace (Config.get ctxt trace)
   6.174 +
   6.175 +
   6.176 +(* tools *)
   6.177 +
   6.178 +fun with_timeout ctxt f x =
   6.179 +  TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) f x
   6.180 +  handle TimeLimit.TimeOut => raise SMT2_Failure.SMT SMT2_Failure.Time_Out
   6.181 +
   6.182 +
   6.183 +(* certificates *)
   6.184 +
   6.185 +(* FIXME just one data slot (record) per program unit *)
   6.186 +structure Certificates = Generic_Data
   6.187 +(
   6.188 +  type T = Cache_IO.cache option
   6.189 +  val empty = NONE
   6.190 +  val extend = I
   6.191 +  fun merge (s, _) = s  (* FIXME merge options!? *)
   6.192 +)
   6.193 +
   6.194 +val get_certificates_path =
   6.195 +  Option.map (Cache_IO.cache_path_of) o Certificates.get o Context.Proof
   6.196 +
   6.197 +fun select_certificates name context = context |> Certificates.put (
   6.198 +  if name = "" then NONE
   6.199 +  else
   6.200 +    Path.explode name
   6.201 +    |> Path.append (Thy_Load.master_directory (Context.theory_of context))
   6.202 +    |> SOME o Cache_IO.unsynchronized_init)
   6.203 +
   6.204 +val certificates_of = Certificates.get o Context.Proof
   6.205 +
   6.206 +val setup_certificates =
   6.207 +  Attrib.setup @{binding smt2_certificates}
   6.208 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
   6.209 +      (Thm.declaration_attribute o K o select_certificates))
   6.210 +    "SMT certificates configuration"
   6.211 +
   6.212 +
   6.213 +(* setup *)
   6.214 +
   6.215 +val _ = Theory.setup (
   6.216 +  setup_solver #>
   6.217 +  setup_certificates)
   6.218 +
   6.219 +fun print_setup ctxt =
   6.220 +  let
   6.221 +    fun string_of_bool b = if b then "true" else "false"
   6.222 +
   6.223 +    val names = available_solvers_of ctxt
   6.224 +    val ns = if null names then ["(none)"] else sort_strings names
   6.225 +    val n = the_default "(none)" (solver_name_of ctxt)
   6.226 +    val opts = solver_options_of ctxt
   6.227 +    
   6.228 +    val t = string_of_real (Config.get ctxt timeout)
   6.229 +
   6.230 +    val certs_filename =
   6.231 +      (case get_certificates_path ctxt of
   6.232 +        SOME path => Path.print path
   6.233 +      | NONE => "(disabled)")
   6.234 +  in
   6.235 +    Pretty.writeln (Pretty.big_list "SMT setup:" [
   6.236 +      Pretty.str ("Current SMT solver: " ^ n),
   6.237 +      Pretty.str ("Current SMT solver options: " ^ space_implode " " opts),
   6.238 +      Pretty.str_list "Available SMT solvers: "  "" ns,
   6.239 +      Pretty.str ("Current timeout: " ^ t ^ " seconds"),
   6.240 +      Pretty.str ("With proofs: " ^
   6.241 +        string_of_bool (not (Config.get ctxt oracle))),
   6.242 +      Pretty.str ("Certificates cache: " ^ certs_filename),
   6.243 +      Pretty.str ("Fixed certificates: " ^
   6.244 +        string_of_bool (Config.get ctxt read_only_certificates))])
   6.245 +  end
   6.246 +
   6.247 +val _ =
   6.248 +  Outer_Syntax.improper_command @{command_spec "smt2_status"}
   6.249 +    "show the available SMT solvers, the currently selected SMT solver, \
   6.250 +    \and the values of SMT configuration options"
   6.251 +    (Scan.succeed (Toplevel.keep (print_setup o Toplevel.context_of)))
   6.252 +
   6.253 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/SMT2/smt2_datatypes.ML	Thu Mar 13 13:18:13 2014 +0100
     7.3 @@ -0,0 +1,133 @@
     7.4 +(*  Title:      HOL/Tools/SMT2/smt2_datatypes.ML
     7.5 +    Author:     Sascha Boehme, TU Muenchen
     7.6 +
     7.7 +Collector functions for common type declarations and their representation
     7.8 +as algebraic datatypes.
     7.9 +*)
    7.10 +
    7.11 +signature SMT2_DATATYPES =
    7.12 +sig
    7.13 +  val add_decls: typ ->
    7.14 +    (typ * (term * term list) list) list list * Proof.context ->
    7.15 +    (typ * (term * term list) list) list list * Proof.context
    7.16 +end
    7.17 +
    7.18 +structure SMT2_Datatypes: SMT2_DATATYPES =
    7.19 +struct
    7.20 +
    7.21 +val lhs_head_of = Term.head_of o fst o Logic.dest_equals o Thm.prop_of
    7.22 +
    7.23 +fun mk_selectors T Ts ctxt =
    7.24 +  let
    7.25 +    val (sels, ctxt') =
    7.26 +      Variable.variant_fixes (replicate (length Ts) "select") ctxt
    7.27 +  in (map2 (fn n => fn U => Free (n, T --> U)) sels Ts, ctxt') end
    7.28 +
    7.29 +
    7.30 +(* datatype declarations *)
    7.31 +
    7.32 +fun get_datatype_decl ({descr, ...} : Datatype.info) n Ts ctxt =
    7.33 +  let
    7.34 +    fun get_vars (_, (m, vs, _)) = if m = n then SOME vs else NONE
    7.35 +    val vars = the (get_first get_vars descr) ~~ Ts
    7.36 +    val lookup_var = the o AList.lookup (op =) vars
    7.37 +
    7.38 +    fun typ_of (dt as Datatype.DtTFree _) = lookup_var dt
    7.39 +      | typ_of (Datatype.DtType (m, dts)) = Type (m, map typ_of dts)
    7.40 +      | typ_of (Datatype.DtRec i) =
    7.41 +          the (AList.lookup (op =) descr i)
    7.42 +          |> (fn (m, dts, _) => Type (m, map typ_of dts))
    7.43 +
    7.44 +    fun mk_constr T (m, dts) ctxt =
    7.45 +      let
    7.46 +        val Ts = map typ_of dts
    7.47 +        val constr = Const (m, Ts ---> T)
    7.48 +        val (selects, ctxt') = mk_selectors T Ts ctxt
    7.49 +      in ((constr, selects), ctxt') end
    7.50 +
    7.51 +    fun mk_decl (i, (_, _, constrs)) ctxt =
    7.52 +      let
    7.53 +        val T = typ_of (Datatype.DtRec i)
    7.54 +        val (css, ctxt') = fold_map (mk_constr T) constrs ctxt
    7.55 +      in ((T, css), ctxt') end
    7.56 +
    7.57 +  in fold_map mk_decl descr ctxt end
    7.58 +
    7.59 +
    7.60 +(* record declarations *)
    7.61 +
    7.62 +val record_name_of = Long_Name.implode o fst o split_last o Long_Name.explode
    7.63 +
    7.64 +fun get_record_decl ({ext_def, ...} : Record.info) T ctxt =
    7.65 +  let
    7.66 +    val (con, _) = Term.dest_Const (lhs_head_of ext_def)
    7.67 +    val (fields, more) = Record.get_extT_fields (Proof_Context.theory_of ctxt) T
    7.68 +    val fieldTs = map snd fields @ [snd more]
    7.69 +
    7.70 +    val constr = Const (con, fieldTs ---> T)
    7.71 +    val (selects, ctxt') = mk_selectors T fieldTs ctxt
    7.72 +  in ((T, [(constr, selects)]), ctxt') end
    7.73 +
    7.74 +
    7.75 +(* typedef declarations *)
    7.76 +
    7.77 +fun get_typedef_decl (info : Typedef.info) T Ts =
    7.78 +  let
    7.79 +    val ({Abs_name, Rep_name, abs_type, rep_type, ...}, _) = info
    7.80 +
    7.81 +    val env = snd (Term.dest_Type abs_type) ~~ Ts
    7.82 +    val instT = Term.map_atyps (perhaps (AList.lookup (op =) env))
    7.83 +
    7.84 +    val constr = Const (Abs_name, instT (rep_type --> abs_type))
    7.85 +    val select = Const (Rep_name, instT (abs_type --> rep_type))
    7.86 +  in (T, [(constr, [select])]) end
    7.87 +
    7.88 +
    7.89 +(* collection of declarations *)
    7.90 +
    7.91 +fun declared declss T = exists (exists (equal T o fst)) declss
    7.92 +fun declared' dss T = exists (exists (equal T o fst) o snd) dss
    7.93 +
    7.94 +fun get_decls T n Ts ctxt =
    7.95 +  let val thy = Proof_Context.theory_of ctxt
    7.96 +  in
    7.97 +    (case Datatype.get_info thy n of
    7.98 +      SOME info => get_datatype_decl info n Ts ctxt
    7.99 +    | NONE =>
   7.100 +        (case Record.get_info thy (record_name_of n) of
   7.101 +          SOME info => get_record_decl info T ctxt |>> single
   7.102 +        | NONE =>
   7.103 +            (case Typedef.get_info ctxt n of
   7.104 +              [] => ([], ctxt)
   7.105 +            | info :: _ => ([get_typedef_decl info T Ts], ctxt))))
   7.106 +  end
   7.107 +
   7.108 +fun add_decls T (declss, ctxt) =
   7.109 +  let
   7.110 +    fun depends Ts ds = exists (member (op =) (map fst ds)) Ts
   7.111 +
   7.112 +    fun add (TFree _) = I
   7.113 +      | add (TVar _) = I
   7.114 +      | add (T as Type (@{type_name fun}, _)) =
   7.115 +          fold add (Term.body_type T :: Term.binder_types T)
   7.116 +      | add @{typ bool} = I
   7.117 +      | add (T as Type (n, Ts)) = (fn (dss, ctxt1) =>
   7.118 +          if declared declss T orelse declared' dss T then (dss, ctxt1)
   7.119 +          else if SMT2_Builtin.is_builtin_typ_ext ctxt1 T then (dss, ctxt1)
   7.120 +          else
   7.121 +            (case get_decls T n Ts ctxt1 of
   7.122 +              ([], _) => (dss, ctxt1)
   7.123 +            | (ds, ctxt2) =>
   7.124 +                let
   7.125 +                  val constrTs =
   7.126 +                    maps (map (snd o Term.dest_Const o fst) o snd) ds
   7.127 +                  val Us = fold (union (op =) o Term.binder_types) constrTs []
   7.128 +
   7.129 +                  fun ins [] = [(Us, ds)]
   7.130 +                    | ins ((Uds as (Us', _)) :: Udss) =
   7.131 +                        if depends Us' ds then (Us, ds) :: Uds :: Udss
   7.132 +                        else Uds :: ins Udss
   7.133 +            in fold add Us (ins dss, ctxt2) end))
   7.134 +  in add T ([], ctxt) |>> append declss o map snd end
   7.135 +
   7.136 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/SMT2/smt2_failure.ML	Thu Mar 13 13:18:13 2014 +0100
     8.3 @@ -0,0 +1,61 @@
     8.4 +(*  Title:      HOL/Tools/SMT2/smt2_failure.ML
     8.5 +    Author:     Sascha Boehme, TU Muenchen
     8.6 +
     8.7 +Failures and exception of SMT.
     8.8 +*)
     8.9 +
    8.10 +signature SMT2_FAILURE =
    8.11 +sig
    8.12 +  type counterexample = {
    8.13 +    is_real_cex: bool,
    8.14 +    free_constraints: term list,
    8.15 +    const_defs: term list}
    8.16 +  datatype failure =
    8.17 +    Counterexample of counterexample |
    8.18 +    Time_Out |
    8.19 +    Out_Of_Memory |
    8.20 +    Abnormal_Termination of int |
    8.21 +    Other_Failure of string
    8.22 +  val pretty_counterexample: Proof.context -> counterexample -> Pretty.T
    8.23 +  val string_of_failure: Proof.context -> failure -> string
    8.24 +  exception SMT of failure
    8.25 +end
    8.26 +
    8.27 +structure SMT2_Failure: SMT2_FAILURE =
    8.28 +struct
    8.29 +
    8.30 +type counterexample = {
    8.31 +  is_real_cex: bool,
    8.32 +  free_constraints: term list,
    8.33 +  const_defs: term list}
    8.34 +
    8.35 +datatype failure =
    8.36 +  Counterexample of counterexample |
    8.37 +  Time_Out |
    8.38 +  Out_Of_Memory |
    8.39 +  Abnormal_Termination of int |
    8.40 +  Other_Failure of string
    8.41 +
    8.42 +fun pretty_counterexample ctxt {is_real_cex, free_constraints, const_defs} =
    8.43 +  let
    8.44 +    val msg =
    8.45 +      if is_real_cex then "Counterexample found (possibly spurious)"
    8.46 +      else "Potential counterexample found"
    8.47 +  in
    8.48 +    if null free_constraints andalso null const_defs then Pretty.str msg
    8.49 +    else
    8.50 +      Pretty.big_list (msg ^ ":")
    8.51 +        (map (Syntax.pretty_term ctxt) (free_constraints @ const_defs))
    8.52 +  end
    8.53 +
    8.54 +fun string_of_failure ctxt (Counterexample cex) =
    8.55 +      Pretty.string_of (pretty_counterexample ctxt cex)
    8.56 +  | string_of_failure _ Time_Out = "Timed out"
    8.57 +  | string_of_failure _ Out_Of_Memory = "Ran out of memory"
    8.58 +  | string_of_failure _ (Abnormal_Termination err) =
    8.59 +      "Solver terminated abnormally with error code " ^ string_of_int err
    8.60 +  | string_of_failure _ (Other_Failure msg) = msg
    8.61 +
    8.62 +exception SMT of failure
    8.63 +
    8.64 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Tools/SMT2/smt2_normalize.ML	Thu Mar 13 13:18:13 2014 +0100
     9.3 @@ -0,0 +1,652 @@
     9.4 +(*  Title:      HOL/Tools/SMT2/smt2_normalize.ML
     9.5 +    Author:     Sascha Boehme, TU Muenchen
     9.6 +
     9.7 +Normalization steps on theorems required by SMT solvers.
     9.8 +*)
     9.9 +
    9.10 +signature SMT2_NORMALIZE =
    9.11 +sig
    9.12 +  val drop_fact_warning: Proof.context -> thm -> unit
    9.13 +  val atomize_conv: Proof.context -> conv
    9.14 +  type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
    9.15 +  val add_extra_norm: SMT2_Utils.class * extra_norm -> Context.generic ->
    9.16 +    Context.generic
    9.17 +  val normalize: (int * (int option * thm)) list -> Proof.context ->
    9.18 +    (int * thm) list * Proof.context
    9.19 +end
    9.20 +
    9.21 +structure SMT2_Normalize: SMT2_NORMALIZE =
    9.22 +struct
    9.23 +
    9.24 +fun drop_fact_warning ctxt =
    9.25 +  SMT2_Config.verbose_msg ctxt (prefix "Warning: dropping assumption: " o
    9.26 +    Display.string_of_thm ctxt)
    9.27 +
    9.28 +
    9.29 +(* general theorem normalizations *)
    9.30 +
    9.31 +(** instantiate elimination rules **)
    9.32 + 
    9.33 +local
    9.34 +  val (cpfalse, cfalse) =
    9.35 +    `SMT2_Utils.mk_cprop (Thm.cterm_of @{theory} @{const False})
    9.36 +
    9.37 +  fun inst f ct thm =
    9.38 +    let val cv = f (Drule.strip_imp_concl (Thm.cprop_of thm))
    9.39 +    in Thm.instantiate ([], [(cv, ct)]) thm end
    9.40 +in
    9.41 +
    9.42 +fun instantiate_elim thm =
    9.43 +  (case Thm.concl_of thm of
    9.44 +    @{const Trueprop} $ Var (_, @{typ bool}) => inst Thm.dest_arg cfalse thm
    9.45 +  | Var _ => inst I cpfalse thm
    9.46 +  | _ => thm)
    9.47 +
    9.48 +end
    9.49 +
    9.50 +
    9.51 +(** normalize definitions **)
    9.52 +
    9.53 +fun norm_def thm =
    9.54 +  (case Thm.prop_of thm of
    9.55 +    @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _ $ Abs _) =>
    9.56 +      norm_def (thm RS @{thm fun_cong})
    9.57 +  | Const (@{const_name "=="}, _) $ _ $ Abs _ =>
    9.58 +      norm_def (thm RS @{thm meta_eq_to_obj_eq})
    9.59 +  | _ => thm)
    9.60 +
    9.61 +
    9.62 +(** atomization **)
    9.63 +
    9.64 +fun atomize_conv ctxt ct =
    9.65 +  (case Thm.term_of ct of
    9.66 +    @{const "==>"} $ _ $ _ =>
    9.67 +      Conv.binop_conv (atomize_conv ctxt) then_conv
    9.68 +      Conv.rewr_conv @{thm atomize_imp}
    9.69 +  | Const (@{const_name "=="}, _) $ _ $ _ =>
    9.70 +      Conv.binop_conv (atomize_conv ctxt) then_conv
    9.71 +      Conv.rewr_conv @{thm atomize_eq}
    9.72 +  | Const (@{const_name all}, _) $ Abs _ =>
    9.73 +      Conv.binder_conv (atomize_conv o snd) ctxt then_conv
    9.74 +      Conv.rewr_conv @{thm atomize_all}
    9.75 +  | _ => Conv.all_conv) ct
    9.76 +
    9.77 +val setup_atomize =
    9.78 +  fold SMT2_Builtin.add_builtin_fun_ext'' [@{const_name "==>"},
    9.79 +    @{const_name "=="}, @{const_name all}, @{const_name Trueprop}]
    9.80 +
    9.81 +
    9.82 +(** unfold special quantifiers **)
    9.83 +
    9.84 +local
    9.85 +  val ex1_def = mk_meta_eq @{lemma
    9.86 +    "Ex1 = (%P. EX x. P x & (ALL y. P y --> y = x))"
    9.87 +    by (rule ext) (simp only: Ex1_def)}
    9.88 +
    9.89 +  val ball_def = mk_meta_eq @{lemma "Ball = (%A P. ALL x. x : A --> P x)"
    9.90 +    by (rule ext)+ (rule Ball_def)}
    9.91 +
    9.92 +  val bex_def = mk_meta_eq @{lemma "Bex = (%A P. EX x. x : A & P x)"
    9.93 +    by (rule ext)+ (rule Bex_def)}
    9.94 +
    9.95 +  val special_quants = [(@{const_name Ex1}, ex1_def),
    9.96 +    (@{const_name Ball}, ball_def), (@{const_name Bex}, bex_def)]
    9.97 +  
    9.98 +  fun special_quant (Const (n, _)) = AList.lookup (op =) special_quants n
    9.99 +    | special_quant _ = NONE
   9.100 +
   9.101 +  fun special_quant_conv _ ct =
   9.102 +    (case special_quant (Thm.term_of ct) of
   9.103 +      SOME thm => Conv.rewr_conv thm
   9.104 +    | NONE => Conv.all_conv) ct
   9.105 +in
   9.106 +
   9.107 +fun unfold_special_quants_conv ctxt =
   9.108 +  SMT2_Utils.if_exists_conv (is_some o special_quant)
   9.109 +    (Conv.top_conv special_quant_conv ctxt)
   9.110 +
   9.111 +val setup_unfolded_quants =
   9.112 +  fold (SMT2_Builtin.add_builtin_fun_ext'' o fst) special_quants
   9.113 +
   9.114 +end
   9.115 +
   9.116 +
   9.117 +(** trigger inference **)
   9.118 +
   9.119 +local
   9.120 +  (*** check trigger syntax ***)
   9.121 +
   9.122 +  fun dest_trigger (Const (@{const_name pat}, _) $ _) = SOME true
   9.123 +    | dest_trigger (Const (@{const_name nopat}, _) $ _) = SOME false
   9.124 +    | dest_trigger _ = NONE
   9.125 +
   9.126 +  fun eq_list [] = false
   9.127 +    | eq_list (b :: bs) = forall (equal b) bs
   9.128 +
   9.129 +  fun proper_trigger t =
   9.130 +    t
   9.131 +    |> these o try HOLogic.dest_list
   9.132 +    |> map (map_filter dest_trigger o these o try HOLogic.dest_list)
   9.133 +    |> (fn [] => false | bss => forall eq_list bss)
   9.134 +
   9.135 +  fun proper_quant inside f t =
   9.136 +    (case t of
   9.137 +      Const (@{const_name All}, _) $ Abs (_, _, u) => proper_quant true f u
   9.138 +    | Const (@{const_name Ex}, _) $ Abs (_, _, u) => proper_quant true f u
   9.139 +    | @{const trigger} $ p $ u =>
   9.140 +        (if inside then f p else false) andalso proper_quant false f u
   9.141 +    | Abs (_, _, u) => proper_quant false f u
   9.142 +    | u1 $ u2 => proper_quant false f u1 andalso proper_quant false f u2
   9.143 +    | _ => true)
   9.144 +
   9.145 +  fun check_trigger_error ctxt t =
   9.146 +    error ("SMT triggers must only occur under quantifier and multipatterns " ^
   9.147 +      "must have the same kind: " ^ Syntax.string_of_term ctxt t)
   9.148 +
   9.149 +  fun check_trigger_conv ctxt ct =
   9.150 +    if proper_quant false proper_trigger (SMT2_Utils.term_of ct) then
   9.151 +      Conv.all_conv ct
   9.152 +    else check_trigger_error ctxt (Thm.term_of ct)
   9.153 +
   9.154 +
   9.155 +  (*** infer simple triggers ***)
   9.156 +
   9.157 +  fun dest_cond_eq ct =
   9.158 +    (case Thm.term_of ct of
   9.159 +      Const (@{const_name HOL.eq}, _) $ _ $ _ => Thm.dest_binop ct
   9.160 +    | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct)
   9.161 +    | _ => raise CTERM ("no equation", [ct]))
   9.162 +
   9.163 +  fun get_constrs thy (Type (n, _)) = these (Datatype.get_constrs thy n)
   9.164 +    | get_constrs _ _ = []
   9.165 +
   9.166 +  fun is_constr thy (n, T) =
   9.167 +    let fun match (m, U) = m = n andalso Sign.typ_instance thy (T, U)
   9.168 +    in can (the o find_first match o get_constrs thy o Term.body_type) T end
   9.169 +
   9.170 +  fun is_constr_pat thy t =
   9.171 +    (case Term.strip_comb t of
   9.172 +      (Free _, []) => true
   9.173 +    | (Const c, ts) => is_constr thy c andalso forall (is_constr_pat thy) ts
   9.174 +    | _ => false)
   9.175 +
   9.176 +  fun is_simp_lhs ctxt t =
   9.177 +    (case Term.strip_comb t of
   9.178 +      (Const c, ts as _ :: _) =>
   9.179 +        not (SMT2_Builtin.is_builtin_fun_ext ctxt c ts) andalso
   9.180 +        forall (is_constr_pat (Proof_Context.theory_of ctxt)) ts
   9.181 +    | _ => false)
   9.182 +
   9.183 +  fun has_all_vars vs t =
   9.184 +    subset (op aconv) (vs, map Free (Term.add_frees t []))
   9.185 +
   9.186 +  fun minimal_pats vs ct =
   9.187 +    if has_all_vars vs (Thm.term_of ct) then
   9.188 +      (case Thm.term_of ct of
   9.189 +        _ $ _ =>
   9.190 +          (case pairself (minimal_pats vs) (Thm.dest_comb ct) of
   9.191 +            ([], []) => [[ct]]
   9.192 +          | (ctss, ctss') => union (eq_set (op aconvc)) ctss ctss')
   9.193 +      | _ => [])
   9.194 +    else []
   9.195 +
   9.196 +  fun proper_mpat _ _ _ [] = false
   9.197 +    | proper_mpat thy gen u cts =
   9.198 +        let
   9.199 +          val tps = (op ~~) (`gen (map Thm.term_of cts))
   9.200 +          fun some_match u = tps |> exists (fn (t', t) =>
   9.201 +            Pattern.matches thy (t', u) andalso not (t aconv u))
   9.202 +        in not (Term.exists_subterm some_match u) end
   9.203 +
   9.204 +  val pat =
   9.205 +    SMT2_Utils.mk_const_pat @{theory} @{const_name SMT2.pat} SMT2_Utils.destT1
   9.206 +  fun mk_pat ct = Thm.apply (SMT2_Utils.instT' ct pat) ct
   9.207 +
   9.208 +  fun mk_clist T = pairself (Thm.cterm_of @{theory})
   9.209 +    (HOLogic.cons_const T, HOLogic.nil_const T)
   9.210 +  fun mk_list (ccons, cnil) f cts = fold_rev (Thm.mk_binop ccons o f) cts cnil
   9.211 +  val mk_pat_list = mk_list (mk_clist @{typ SMT2.pattern})
   9.212 +  val mk_mpat_list = mk_list (mk_clist @{typ "SMT2.pattern list"})  
   9.213 +  fun mk_trigger ctss = mk_mpat_list (mk_pat_list mk_pat) ctss
   9.214 +
   9.215 +  val trigger_eq =
   9.216 +    mk_meta_eq @{lemma "p = SMT2.trigger t p" by (simp add: trigger_def)}
   9.217 +
   9.218 +  fun insert_trigger_conv [] ct = Conv.all_conv ct
   9.219 +    | insert_trigger_conv ctss ct =
   9.220 +        let val (ctr, cp) = Thm.dest_binop (Thm.rhs_of trigger_eq) ||> rpair ct
   9.221 +        in Thm.instantiate ([], [cp, (ctr, mk_trigger ctss)]) trigger_eq end
   9.222 +
   9.223 +  fun infer_trigger_eq_conv outer_ctxt (ctxt, cvs) ct =
   9.224 +    let
   9.225 +      val (lhs, rhs) = dest_cond_eq ct
   9.226 +
   9.227 +      val vs = map Thm.term_of cvs
   9.228 +      val thy = Proof_Context.theory_of ctxt
   9.229 +
   9.230 +      fun get_mpats ct =
   9.231 +        if is_simp_lhs ctxt (Thm.term_of ct) then minimal_pats vs ct
   9.232 +        else []
   9.233 +      val gen = Variable.export_terms ctxt outer_ctxt
   9.234 +      val filter_mpats = filter (proper_mpat thy gen (Thm.term_of rhs))
   9.235 +
   9.236 +    in insert_trigger_conv (filter_mpats (get_mpats lhs)) ct end
   9.237 +
   9.238 +  fun has_trigger (@{const SMT2.trigger} $ _ $ _) = true
   9.239 +    | has_trigger _ = false
   9.240 +
   9.241 +  fun try_trigger_conv cv ct =
   9.242 +    if SMT2_Utils.under_quant has_trigger (SMT2_Utils.term_of ct) then
   9.243 +      Conv.all_conv ct
   9.244 +    else Conv.try_conv cv ct
   9.245 +
   9.246 +  fun infer_trigger_conv ctxt =
   9.247 +    if Config.get ctxt SMT2_Config.infer_triggers then
   9.248 +      try_trigger_conv
   9.249 +        (SMT2_Utils.under_quant_conv (infer_trigger_eq_conv ctxt) ctxt)
   9.250 +    else Conv.all_conv
   9.251 +in
   9.252 +
   9.253 +fun trigger_conv ctxt =
   9.254 +  SMT2_Utils.prop_conv
   9.255 +    (check_trigger_conv ctxt then_conv infer_trigger_conv ctxt)
   9.256 +
   9.257 +val setup_trigger =
   9.258 +  fold SMT2_Builtin.add_builtin_fun_ext''
   9.259 +    [@{const_name SMT2.pat}, @{const_name SMT2.nopat}, @{const_name SMT2.trigger}]
   9.260 +
   9.261 +end
   9.262 +
   9.263 +
   9.264 +(** adding quantifier weights **)
   9.265 +
   9.266 +local
   9.267 +  (*** check weight syntax ***)
   9.268 +
   9.269 +  val has_no_weight =
   9.270 +    not o Term.exists_subterm (fn @{const SMT2.weight} => true | _ => false)
   9.271 +
   9.272 +  fun is_weight (@{const SMT2.weight} $ w $ t) =
   9.273 +        (case try HOLogic.dest_number w of
   9.274 +          SOME (_, i) => i >= 0 andalso has_no_weight t
   9.275 +        | _ => false)
   9.276 +    | is_weight t = has_no_weight t
   9.277 +
   9.278 +  fun proper_trigger (@{const SMT2.trigger} $ _ $ t) = is_weight t
   9.279 +    | proper_trigger t = is_weight t 
   9.280 +
   9.281 +  fun check_weight_error ctxt t =
   9.282 +    error ("SMT weight must be a non-negative number and must only occur " ^
   9.283 +      "under the top-most quantifier and an optional trigger: " ^
   9.284 +      Syntax.string_of_term ctxt t)
   9.285 +
   9.286 +  fun check_weight_conv ctxt ct =
   9.287 +    if SMT2_Utils.under_quant proper_trigger (SMT2_Utils.term_of ct) then
   9.288 +      Conv.all_conv ct
   9.289 +    else check_weight_error ctxt (Thm.term_of ct)
   9.290 +
   9.291 +
   9.292 +  (*** insertion of weights ***)
   9.293 +
   9.294 +  fun under_trigger_conv cv ct =
   9.295 +    (case Thm.term_of ct of
   9.296 +      @{const SMT2.trigger} $ _ $ _ => Conv.arg_conv cv
   9.297 +    | _ => cv) ct
   9.298 +
   9.299 +  val weight_eq =
   9.300 +    mk_meta_eq @{lemma "p = SMT2.weight i p" by (simp add: weight_def)}
   9.301 +  fun mk_weight_eq w =
   9.302 +    let val cv = Thm.dest_arg1 (Thm.rhs_of weight_eq)
   9.303 +    in
   9.304 +      Thm.instantiate ([], [(cv, Numeral.mk_cnumber @{ctyp int} w)]) weight_eq
   9.305 +    end
   9.306 +
   9.307 +  fun add_weight_conv NONE _ = Conv.all_conv
   9.308 +    | add_weight_conv (SOME weight) ctxt =
   9.309 +        let val cv = Conv.rewr_conv (mk_weight_eq weight)
   9.310 +        in SMT2_Utils.under_quant_conv (K (under_trigger_conv cv)) ctxt end
   9.311 +in
   9.312 +
   9.313 +fun weight_conv weight ctxt = 
   9.314 +  SMT2_Utils.prop_conv
   9.315 +    (check_weight_conv ctxt then_conv add_weight_conv weight ctxt)
   9.316 +
   9.317 +val setup_weight = SMT2_Builtin.add_builtin_fun_ext'' @{const_name SMT2.weight}
   9.318 +
   9.319 +end
   9.320 +
   9.321 +
   9.322 +(** combined general normalizations **)
   9.323 +
   9.324 +fun gen_normalize1_conv ctxt weight =
   9.325 +  atomize_conv ctxt then_conv
   9.326 +  unfold_special_quants_conv ctxt then_conv
   9.327 +  Thm.beta_conversion true then_conv
   9.328 +  trigger_conv ctxt then_conv
   9.329 +  weight_conv weight ctxt
   9.330 +
   9.331 +fun gen_normalize1 ctxt weight thm =
   9.332 +  thm
   9.333 +  |> instantiate_elim
   9.334 +  |> norm_def
   9.335 +  |> Conv.fconv_rule (Thm.beta_conversion true then_conv Thm.eta_conversion)
   9.336 +  |> Drule.forall_intr_vars
   9.337 +  |> Conv.fconv_rule (gen_normalize1_conv ctxt weight)
   9.338 +  (* Z3 4.3.1 silently normalizes "P --> Q --> R" to "P & Q --> R" *)
   9.339 +  |> Raw_Simplifier.rewrite_rule ctxt @{thms HOL.imp_conjL[symmetric, THEN eq_reflection]}
   9.340 +
   9.341 +fun gen_norm1_safe ctxt (i, (weight, thm)) =
   9.342 +  (case try (gen_normalize1 ctxt weight) thm of
   9.343 +    SOME thm' => SOME (i, thm')
   9.344 +  | NONE => (drop_fact_warning ctxt thm; NONE))
   9.345 +
   9.346 +fun gen_normalize ctxt iwthms = map_filter (gen_norm1_safe ctxt) iwthms
   9.347 +
   9.348 +
   9.349 +
   9.350 +(* unfolding of definitions and theory-specific rewritings *)
   9.351 +
   9.352 +fun expand_head_conv cv ct =
   9.353 +  (case Thm.term_of ct of
   9.354 +    _ $ _ =>
   9.355 +      Conv.fun_conv (expand_head_conv cv) then_conv
   9.356 +      Conv.try_conv (Thm.beta_conversion false)
   9.357 +  | _ => cv) ct
   9.358 +
   9.359 +
   9.360 +(** rewrite bool case expressions as if expressions **)
   9.361 +
   9.362 +local
   9.363 +  fun is_case_bool (Const (@{const_name "bool.case_bool"}, _)) = true
   9.364 +    | is_case_bool _ = false
   9.365 +
   9.366 +  val thm = mk_meta_eq @{lemma
   9.367 +    "case_bool = (%x y P. if P then x else y)" by (rule ext)+ simp}
   9.368 +
   9.369 +  fun unfold_conv _ =
   9.370 +    SMT2_Utils.if_true_conv (is_case_bool o Term.head_of)
   9.371 +      (expand_head_conv (Conv.rewr_conv thm))
   9.372 +in
   9.373 +
   9.374 +fun rewrite_case_bool_conv ctxt =
   9.375 +  SMT2_Utils.if_exists_conv is_case_bool (Conv.top_conv unfold_conv ctxt)
   9.376 +
   9.377 +val setup_case_bool =
   9.378 +  SMT2_Builtin.add_builtin_fun_ext'' @{const_name "bool.case_bool"}
   9.379 +
   9.380 +end
   9.381 +
   9.382 +
   9.383 +(** unfold abs, min and max **)
   9.384 +
   9.385 +local
   9.386 +  val abs_def = mk_meta_eq @{lemma
   9.387 +    "abs = (%a::'a::abs_if. if a < 0 then - a else a)"
   9.388 +    by (rule ext) (rule abs_if)}
   9.389 +
   9.390 +  val min_def = mk_meta_eq @{lemma "min = (%a b. if a <= b then a else b)"
   9.391 +    by (rule ext)+ (rule min_def)}
   9.392 +
   9.393 +  val max_def = mk_meta_eq  @{lemma "max = (%a b. if a <= b then b else a)"
   9.394 +    by (rule ext)+ (rule max_def)}
   9.395 +
   9.396 +  val defs = [(@{const_name min}, min_def), (@{const_name max}, max_def),
   9.397 +    (@{const_name abs}, abs_def)]
   9.398 +
   9.399 +  fun is_builtinT ctxt T =
   9.400 +    SMT2_Builtin.is_builtin_typ_ext ctxt (Term.domain_type T)
   9.401 +
   9.402 +  fun abs_min_max ctxt (Const (n, T)) =
   9.403 +        (case AList.lookup (op =) defs n of
   9.404 +          NONE => NONE
   9.405 +        | SOME thm => if is_builtinT ctxt T then SOME thm else NONE)
   9.406 +    | abs_min_max _ _ = NONE
   9.407 +
   9.408 +  fun unfold_amm_conv ctxt ct =
   9.409 +    (case abs_min_max ctxt (Term.head_of (Thm.term_of ct)) of
   9.410 +      SOME thm => expand_head_conv (Conv.rewr_conv thm)
   9.411 +    | NONE => Conv.all_conv) ct
   9.412 +in
   9.413 +
   9.414 +fun unfold_abs_min_max_conv ctxt =
   9.415 +  SMT2_Utils.if_exists_conv (is_some o abs_min_max ctxt)
   9.416 +    (Conv.top_conv unfold_amm_conv ctxt)
   9.417 +  
   9.418 +val setup_abs_min_max = fold (SMT2_Builtin.add_builtin_fun_ext'' o fst) defs
   9.419 +
   9.420 +end
   9.421 +
   9.422 +
   9.423 +(** embedding of standard natural number operations into integer operations **)
   9.424 +
   9.425 +local
   9.426 +  val nat_embedding = @{lemma
   9.427 +    "ALL n. nat (int n) = n"
   9.428 +    "ALL i. i >= 0 --> int (nat i) = i"
   9.429 +    "ALL i. i < 0 --> int (nat i) = 0"
   9.430 +    by simp_all}
   9.431 +
   9.432 +  val simple_nat_ops = [
   9.433 +    @{const less (nat)}, @{const less_eq (nat)},
   9.434 +    @{const Suc}, @{const plus (nat)}, @{const minus (nat)}]
   9.435 +
   9.436 +  val mult_nat_ops =
   9.437 +    [@{const times (nat)}, @{const div (nat)}, @{const mod (nat)}]
   9.438 +
   9.439 +  val nat_ops = simple_nat_ops @ mult_nat_ops
   9.440 +
   9.441 +  val nat_consts = nat_ops @ [@{const numeral (nat)},
   9.442 +    @{const zero_class.zero (nat)}, @{const one_class.one (nat)}]
   9.443 +
   9.444 +  val nat_int_coercions = [@{const of_nat (int)}, @{const nat}]
   9.445 +
   9.446 +  val builtin_nat_ops = nat_int_coercions @ simple_nat_ops
   9.447 +
   9.448 +  val is_nat_const = member (op aconv) nat_consts
   9.449 +
   9.450 +  fun is_nat_const' @{const of_nat (int)} = true
   9.451 +    | is_nat_const' t = is_nat_const t
   9.452 +
   9.453 +  val expands = map mk_meta_eq @{lemma
   9.454 +    "0 = nat 0"
   9.455 +    "1 = nat 1"
   9.456 +    "(numeral :: num => nat) = (%i. nat (numeral i))"
   9.457 +    "op < = (%a b. int a < int b)"
   9.458 +    "op <= = (%a b. int a <= int b)"
   9.459 +    "Suc = (%a. nat (int a + 1))"
   9.460 +    "op + = (%a b. nat (int a + int b))"
   9.461 +    "op - = (%a b. nat (int a - int b))"
   9.462 +    "op * = (%a b. nat (int a * int b))"
   9.463 +    "op div = (%a b. nat (int a div int b))"
   9.464 +    "op mod = (%a b. nat (int a mod int b))"
   9.465 +    by (fastforce simp add: nat_mult_distrib nat_div_distrib nat_mod_distrib)+}
   9.466 +
   9.467 +  val ints = map mk_meta_eq @{lemma
   9.468 +    "int 0 = 0"
   9.469 +    "int 1 = 1"
   9.470 +    "int (Suc n) = int n + 1"
   9.471 +    "int (n + m) = int n + int m"
   9.472 +    "int (n - m) = int (nat (int n - int m))"
   9.473 +    "int (n * m) = int n * int m"
   9.474 +    "int (n div m) = int n div int m"
   9.475 +    "int (n mod m) = int n mod int m"
   9.476 +    by (auto simp add: int_mult zdiv_int zmod_int)}
   9.477 +
   9.478 +  val int_if = mk_meta_eq @{lemma
   9.479 +    "int (if P then n else m) = (if P then int n else int m)"
   9.480 +    by simp}
   9.481 +
   9.482 +  fun mk_number_eq ctxt i lhs =
   9.483 +    let
   9.484 +      val eq = SMT2_Utils.mk_cequals lhs (Numeral.mk_cnumber @{ctyp int} i)
   9.485 +      val ctxt' = put_simpset HOL_ss ctxt addsimps @{thms Int.int_numeral}
   9.486 +      val tac = HEADGOAL (Simplifier.simp_tac ctxt')
   9.487 +    in Goal.norm_result ctxt (Goal.prove_internal ctxt [] eq (K tac)) end
   9.488 +
   9.489 +  fun ite_conv cv1 cv2 =
   9.490 +    Conv.combination_conv (Conv.combination_conv (Conv.arg_conv cv1) cv2) cv2
   9.491 +
   9.492 +  fun int_conv ctxt ct =
   9.493 +    (case Thm.term_of ct of
   9.494 +      @{const of_nat (int)} $ (n as (@{const numeral (nat)} $ _)) =>
   9.495 +        Conv.rewr_conv (mk_number_eq ctxt (snd (HOLogic.dest_number n)) ct)
   9.496 +    | @{const of_nat (int)} $ _ =>
   9.497 +        (Conv.rewrs_conv ints then_conv Conv.sub_conv ints_conv ctxt) else_conv
   9.498 +        (Conv.rewr_conv int_if then_conv
   9.499 +          ite_conv (nat_conv ctxt) (int_conv ctxt)) else_conv
   9.500 +        Conv.sub_conv (Conv.top_sweep_conv nat_conv) ctxt
   9.501 +    | _ => Conv.no_conv) ct
   9.502 +
   9.503 +  and ints_conv ctxt = Conv.top_sweep_conv int_conv ctxt
   9.504 +
   9.505 +  and expand_conv ctxt =
   9.506 +    SMT2_Utils.if_conv (is_nat_const o Term.head_of)
   9.507 +      (expand_head_conv (Conv.rewrs_conv expands) then_conv ints_conv ctxt)
   9.508 +      (int_conv ctxt)
   9.509 +
   9.510 +  and nat_conv ctxt = SMT2_Utils.if_exists_conv is_nat_const' (Conv.top_sweep_conv expand_conv ctxt)
   9.511 +
   9.512 +  val uses_nat_int = Term.exists_subterm (member (op aconv) nat_int_coercions)
   9.513 +in
   9.514 +
   9.515 +val nat_as_int_conv = nat_conv
   9.516 +
   9.517 +fun add_nat_embedding thms =
   9.518 +  if exists (uses_nat_int o Thm.prop_of) thms then (thms, nat_embedding)
   9.519 +  else (thms, [])
   9.520 +
   9.521 +val setup_nat_as_int =
   9.522 +  SMT2_Builtin.add_builtin_typ_ext (@{typ nat}, K true) #>
   9.523 +  fold (SMT2_Builtin.add_builtin_fun_ext' o Term.dest_Const) builtin_nat_ops
   9.524 +
   9.525 +end
   9.526 +
   9.527 +
   9.528 +(** normalize numerals **)
   9.529 +
   9.530 +local
   9.531 +  (*
   9.532 +    rewrite Numeral1 into 1
   9.533 +    rewrite - 0 into 0
   9.534 +  *)
   9.535 +
   9.536 +  fun is_irregular_number (Const (@{const_name numeral}, _) $ Const (@{const_name num.One}, _)) =
   9.537 +        true
   9.538 +    | is_irregular_number (Const (@{const_name uminus}, _) $ Const (@{const_name Groups.zero}, _)) =
   9.539 +        true
   9.540 +    | is_irregular_number _ =
   9.541 +        false;
   9.542 +
   9.543 +  fun is_strange_number ctxt t = is_irregular_number t andalso SMT2_Builtin.is_builtin_num ctxt t;
   9.544 +
   9.545 +  val proper_num_ss =
   9.546 +    simpset_of (put_simpset HOL_ss @{context}
   9.547 +      addsimps @{thms Num.numeral_One minus_zero})
   9.548 +
   9.549 +  fun norm_num_conv ctxt =
   9.550 +    SMT2_Utils.if_conv (is_strange_number ctxt)
   9.551 +      (Simplifier.rewrite (put_simpset proper_num_ss ctxt)) Conv.no_conv
   9.552 +in
   9.553 +
   9.554 +fun normalize_numerals_conv ctxt =
   9.555 +  SMT2_Utils.if_exists_conv (is_strange_number ctxt)
   9.556 +    (Conv.top_sweep_conv norm_num_conv ctxt)
   9.557 +
   9.558 +end
   9.559 +
   9.560 +
   9.561 +(** combined unfoldings and rewritings **)
   9.562 +
   9.563 +fun unfold_conv ctxt =
   9.564 +  rewrite_case_bool_conv ctxt then_conv
   9.565 +  unfold_abs_min_max_conv ctxt then_conv
   9.566 +  nat_as_int_conv ctxt then_conv
   9.567 +  Thm.beta_conversion true
   9.568 +
   9.569 +fun unfold1 ctxt = map (apsnd (Conv.fconv_rule (unfold_conv ctxt)))
   9.570 +
   9.571 +fun burrow_ids f ithms =
   9.572 +  let
   9.573 +    val (is, thms) = split_list ithms
   9.574 +    val (thms', extra_thms) = f thms
   9.575 +  in (is ~~ thms') @ map (pair ~1) extra_thms end
   9.576 +
   9.577 +fun unfold2 ctxt ithms =
   9.578 +  ithms
   9.579 +  |> map (apsnd (Conv.fconv_rule (normalize_numerals_conv ctxt)))
   9.580 +  |> burrow_ids add_nat_embedding
   9.581 +
   9.582 +
   9.583 +
   9.584 +(* overall normalization *)
   9.585 +
   9.586 +type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
   9.587 +
   9.588 +structure Extra_Norms = Generic_Data
   9.589 +(
   9.590 +  type T = extra_norm SMT2_Utils.dict
   9.591 +  val empty = []
   9.592 +  val extend = I
   9.593 +  fun merge data = SMT2_Utils.dict_merge fst data
   9.594 +)
   9.595 +
   9.596 +fun add_extra_norm (cs, norm) =
   9.597 +  Extra_Norms.map (SMT2_Utils.dict_update (cs, norm))
   9.598 +
   9.599 +fun apply_extra_norms ctxt ithms =
   9.600 +  let
   9.601 +    val cs = SMT2_Config.solver_class_of ctxt
   9.602 +    val es = SMT2_Utils.dict_lookup (Extra_Norms.get (Context.Proof ctxt)) cs
   9.603 +  in burrow_ids (fold (fn e => e ctxt) es o rpair []) ithms end
   9.604 +
   9.605 +local
   9.606 +  val ignored = member (op =) [@{const_name All}, @{const_name Ex},
   9.607 +    @{const_name Let}, @{const_name If}, @{const_name HOL.eq}]
   9.608 +
   9.609 +  val schematic_consts_of =
   9.610 +    let
   9.611 +      fun collect (@{const SMT2.trigger} $ p $ t) =
   9.612 +            collect_trigger p #> collect t
   9.613 +        | collect (t $ u) = collect t #> collect u
   9.614 +        | collect (Abs (_, _, t)) = collect t
   9.615 +        | collect (t as Const (n, _)) = 
   9.616 +            if not (ignored n) then Monomorph.add_schematic_consts_of t else I
   9.617 +        | collect _ = I
   9.618 +      and collect_trigger t =
   9.619 +        let val dest = these o try HOLogic.dest_list 
   9.620 +        in fold (fold collect_pat o dest) (dest t) end
   9.621 +      and collect_pat (Const (@{const_name SMT2.pat}, _) $ t) = collect t
   9.622 +        | collect_pat (Const (@{const_name SMT2.nopat}, _) $ t) = collect t
   9.623 +        | collect_pat _ = I
   9.624 +    in (fn t => collect t Symtab.empty) end
   9.625 +in
   9.626 +
   9.627 +fun monomorph ctxt xthms =
   9.628 +  let val (xs, thms) = split_list xthms
   9.629 +  in
   9.630 +    map (pair 1) thms
   9.631 +    |> Monomorph.monomorph schematic_consts_of ctxt
   9.632 +    |> maps (uncurry (map o pair)) o map2 pair xs o map (map snd)
   9.633 +  end
   9.634 +
   9.635 +end
   9.636 +
   9.637 +fun normalize iwthms ctxt =
   9.638 +  iwthms
   9.639 +  |> gen_normalize ctxt
   9.640 +  |> unfold1 ctxt
   9.641 +  |> monomorph ctxt
   9.642 +  |> unfold2 ctxt
   9.643 +  |> apply_extra_norms ctxt
   9.644 +  |> rpair ctxt
   9.645 +
   9.646 +val _ = Theory.setup (Context.theory_map (
   9.647 +  setup_atomize #>
   9.648 +  setup_unfolded_quants #>
   9.649 +  setup_trigger #>
   9.650 +  setup_weight #>
   9.651 +  setup_case_bool #>
   9.652 +  setup_abs_min_max #>
   9.653 +  setup_nat_as_int))
   9.654 +
   9.655 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Tools/SMT2/smt2_real.ML	Thu Mar 13 13:18:13 2014 +0100
    10.3 @@ -0,0 +1,121 @@
    10.4 +(*  Title:      HOL/Tools/SMT2/smt2_real.ML
    10.5 +    Author:     Sascha Boehme, TU Muenchen
    10.6 +
    10.7 +SMT setup for reals.
    10.8 +*)
    10.9 +
   10.10 +structure SMT2_Real: sig end =
   10.11 +struct
   10.12 +
   10.13 +
   10.14 +(* SMT-LIB logic *)
   10.15 +
   10.16 +fun smtlib_logic ts =
   10.17 +  if exists (Term.exists_type (Term.exists_subtype (equal @{typ real}))) ts
   10.18 +  then SOME "AUFLIRA"
   10.19 +  else NONE
   10.20 +
   10.21 +
   10.22 +(* SMT-LIB and Z3 built-ins *)
   10.23 +
   10.24 +local
   10.25 +  fun real_num _ i = SOME (string_of_int i ^ ".0")
   10.26 +
   10.27 +  fun is_linear [t] = SMT2_Utils.is_number t
   10.28 +    | is_linear [t, u] = SMT2_Utils.is_number t orelse SMT2_Utils.is_number u
   10.29 +    | is_linear _ = false
   10.30 +
   10.31 +  fun mk_times ts = Term.list_comb (@{const times (real)}, ts)
   10.32 +
   10.33 +  fun times _ _ ts = if is_linear ts then SOME ("*", 2, ts, mk_times) else NONE
   10.34 +in
   10.35 +
   10.36 +val setup_builtins =
   10.37 +  SMT2_Builtin.add_builtin_typ SMTLIB2_Interface.smtlib2C
   10.38 +    (@{typ real}, K (SOME "Real"), real_num) #>
   10.39 +  fold (SMT2_Builtin.add_builtin_fun' SMTLIB2_Interface.smtlib2C) [
   10.40 +    (@{const less (real)}, "<"),
   10.41 +    (@{const less_eq (real)}, "<="),
   10.42 +    (@{const uminus (real)}, "~"),
   10.43 +    (@{const plus (real)}, "+"),
   10.44 +    (@{const minus (real)}, "-") ] #>
   10.45 +  SMT2_Builtin.add_builtin_fun SMTLIB2_Interface.smtlib2C
   10.46 +    (Term.dest_Const @{const times (real)}, times) #>
   10.47 +  SMT2_Builtin.add_builtin_fun' Z3_New_Interface.smtlib2_z3C
   10.48 +    (@{const times (real)}, "*") #>
   10.49 +  SMT2_Builtin.add_builtin_fun' Z3_New_Interface.smtlib2_z3C
   10.50 +    (@{const divide (real)}, "/")
   10.51 +
   10.52 +end
   10.53 +
   10.54 +
   10.55 +(* Z3 constructors *)
   10.56 +
   10.57 +local
   10.58 +  fun z3_mk_builtin_typ (Z3_New_Interface.Sym ("Real", _)) = SOME @{typ real}
   10.59 +    | z3_mk_builtin_typ (Z3_New_Interface.Sym ("real", _)) = SOME @{typ real}
   10.60 +        (*FIXME: delete*)
   10.61 +    | z3_mk_builtin_typ _ = NONE
   10.62 +
   10.63 +  fun z3_mk_builtin_num _ i T =
   10.64 +    if T = @{typ real} then SOME (Numeral.mk_cnumber @{ctyp real} i)
   10.65 +    else NONE
   10.66 +
   10.67 +  fun mk_nary _ cu [] = cu
   10.68 +    | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
   10.69 +
   10.70 +  val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (real)})
   10.71 +  val add = Thm.cterm_of @{theory} @{const plus (real)}
   10.72 +  val real0 = Numeral.mk_cnumber @{ctyp real} 0
   10.73 +  val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (real)})
   10.74 +  val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (real)})
   10.75 +  val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const divide (real)})
   10.76 +  val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (real)})
   10.77 +  val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (real)})
   10.78 +
   10.79 +  fun z3_mk_builtin_fun (Z3_New_Interface.Sym ("-", _)) [ct] = SOME (mk_uminus ct)
   10.80 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("+", _)) cts =
   10.81 +        SOME (mk_nary add real0 cts)
   10.82 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("-", _)) [ct, cu] =
   10.83 +        SOME (mk_sub ct cu)
   10.84 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("*", _)) [ct, cu] =
   10.85 +        SOME (mk_mul ct cu)
   10.86 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("/", _)) [ct, cu] =
   10.87 +        SOME (mk_div ct cu)
   10.88 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("<", _)) [ct, cu] =
   10.89 +        SOME (mk_lt ct cu)
   10.90 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym ("<=", _)) [ct, cu] =
   10.91 +        SOME (mk_le ct cu)
   10.92 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym (">", _)) [ct, cu] =
   10.93 +        SOME (mk_lt cu ct)
   10.94 +    | z3_mk_builtin_fun (Z3_New_Interface.Sym (">=", _)) [ct, cu] =
   10.95 +        SOME (mk_le cu ct)
   10.96 +    | z3_mk_builtin_fun _ _ = NONE
   10.97 +in
   10.98 +
   10.99 +val z3_mk_builtins = {
  10.100 +  mk_builtin_typ = z3_mk_builtin_typ,
  10.101 +  mk_builtin_num = z3_mk_builtin_num,
  10.102 +  mk_builtin_fun = (fn _ => fn sym => fn cts =>
  10.103 +    (case try (#T o Thm.rep_cterm o hd) cts of
  10.104 +      SOME @{typ real} => z3_mk_builtin_fun sym cts
  10.105 +    | _ => NONE)) }
  10.106 +
  10.107 +end
  10.108 +
  10.109 +
  10.110 +(* Z3 proof replay *)
  10.111 +
  10.112 +val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [
  10.113 +  "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc
  10.114 +
  10.115 +
  10.116 +(* setup *)
  10.117 +
  10.118 +val _ = Theory.setup (Context.theory_map (
  10.119 +  SMTLIB2_Interface.add_logic (10, smtlib_logic) #>
  10.120 +  setup_builtins #>
  10.121 +  Z3_New_Interface.add_mk_builtins z3_mk_builtins #>
  10.122 +  Z3_New_Proof_Tools.add_simproc real_linarith_proc))
  10.123 +
  10.124 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Tools/SMT2/smt2_setup_solvers.ML	Thu Mar 13 13:18:13 2014 +0100
    11.3 @@ -0,0 +1,183 @@
    11.4 +(*  Title:      HOL/Tools/SMT2/smt2_setup_solvers.ML
    11.5 +    Author:     Sascha Boehme, TU Muenchen
    11.6 +
    11.7 +Setup SMT solvers.
    11.8 +*)
    11.9 +
   11.10 +signature SMT2_SETUP_SOLVERS =
   11.11 +sig
   11.12 +  datatype z3_non_commercial =
   11.13 +    Z3_Non_Commercial_Unknown |
   11.14 +    Z3_Non_Commercial_Accepted |
   11.15 +    Z3_Non_Commercial_Declined
   11.16 +  val z3_non_commercial: unit -> z3_non_commercial
   11.17 +  val z3_extensions: bool Config.T
   11.18 +end
   11.19 +
   11.20 +structure SMT2_Setup_Solvers: SMT2_SETUP_SOLVERS =
   11.21 +struct
   11.22 +
   11.23 +(* helper functions *)
   11.24 +
   11.25 +fun make_avail name () = getenv (name ^ "_SOLVER") <> ""
   11.26 +
   11.27 +fun make_command name () = [getenv (name ^ "_SOLVER")]
   11.28 +
   11.29 +fun outcome_of unsat sat unknown solver_name line =
   11.30 +  if String.isPrefix unsat line then SMT2_Solver.Unsat
   11.31 +  else if String.isPrefix sat line then SMT2_Solver.Sat
   11.32 +  else if String.isPrefix unknown line then SMT2_Solver.Unknown
   11.33 +  else raise SMT2_Failure.SMT (SMT2_Failure.Other_Failure ("Solver " ^
   11.34 +    quote solver_name ^ " failed. Enable SMT tracing by setting the " ^
   11.35 +    "configuration option " ^ quote (Config.name_of SMT2_Config.trace) ^ " and " ^
   11.36 +    "see the trace for details."))
   11.37 +
   11.38 +fun on_first_line test_outcome solver_name lines =
   11.39 +  let
   11.40 +    val empty_line = (fn "" => true | _ => false)
   11.41 +    val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
   11.42 +    val (l, ls) = split_first (snd (take_prefix empty_line lines))
   11.43 +  in (test_outcome solver_name l, ls) end
   11.44 +
   11.45 +
   11.46 +(* CVC3 *)
   11.47 +
   11.48 +local
   11.49 +  fun cvc3_options ctxt = [
   11.50 +    "-seed", string_of_int (Config.get ctxt SMT2_Config.random_seed),
   11.51 +    "-lang", "smtlib", "-output-lang", "presentation",
   11.52 +    "-timeout", string_of_int (Real.ceil (Config.get ctxt SMT2_Config.timeout))]
   11.53 +in
   11.54 +
   11.55 +val cvc3: SMT2_Solver.solver_config = {
   11.56 +  name = "cvc3_new",
   11.57 +  class = K SMTLIB2_Interface.smtlib2C,
   11.58 +  avail = make_avail "CVC3_NEW",
   11.59 +  command = make_command "CVC3_NEW",
   11.60 +  options = cvc3_options,
   11.61 +  default_max_relevant = 400 (* FUDGE *),
   11.62 +  supports_filter = false,
   11.63 +  outcome =
   11.64 +    on_first_line (outcome_of "Unsatisfiable." "Satisfiable." "Unknown."),
   11.65 +  cex_parser = NONE,
   11.66 +  replay = NONE }
   11.67 +
   11.68 +end
   11.69 +
   11.70 +
   11.71 +(* Yices *)
   11.72 +
   11.73 +val yices: SMT2_Solver.solver_config = {
   11.74 +  name = "yices_new",
   11.75 +  class = K SMTLIB2_Interface.smtlib2C,
   11.76 +  avail = make_avail "YICES_NEW",
   11.77 +  command = make_command "YICES_NEW",
   11.78 +  options = (fn ctxt => [
   11.79 +    "--rand-seed=" ^ string_of_int (Config.get ctxt SMT2_Config.random_seed),
   11.80 +    "--timeout=" ^
   11.81 +      string_of_int (Real.ceil (Config.get ctxt SMT2_Config.timeout)),
   11.82 +    "--smtlib"]),
   11.83 +  default_max_relevant = 350 (* FUDGE *),
   11.84 +  supports_filter = false,
   11.85 +  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
   11.86 +  cex_parser = NONE,
   11.87 +  replay = NONE }
   11.88 +
   11.89 +
   11.90 +(* Z3 *)
   11.91 +
   11.92 +datatype z3_non_commercial =
   11.93 +  Z3_Non_Commercial_Unknown |
   11.94 +  Z3_Non_Commercial_Accepted |
   11.95 +  Z3_Non_Commercial_Declined
   11.96 +
   11.97 +local
   11.98 +  val accepted = member (op =) ["yes", "Yes", "YES"]
   11.99 +  val declined = member (op =) ["no", "No", "NO"]
  11.100 +in
  11.101 +
  11.102 +fun z3_non_commercial () =
  11.103 +  let
  11.104 +    val flag1 = Options.default_string @{option z3_non_commercial}
  11.105 +    val flag2 = getenv "Z3_NON_COMMERCIAL"
  11.106 +  in
  11.107 +    if accepted flag1 then Z3_Non_Commercial_Accepted
  11.108 +    else if declined flag1 then Z3_Non_Commercial_Declined
  11.109 +    else if accepted flag2 then Z3_Non_Commercial_Accepted
  11.110 +    else if declined flag2 then Z3_Non_Commercial_Declined
  11.111 +    else Z3_Non_Commercial_Unknown
  11.112 +  end
  11.113 +
  11.114 +fun if_z3_non_commercial f =
  11.115 +  (case z3_non_commercial () of
  11.116 +    Z3_Non_Commercial_Accepted => f ()
  11.117 +  | Z3_Non_Commercial_Declined =>
  11.118 +      error (Pretty.string_of (Pretty.para
  11.119 +        "The SMT solver Z3 may only be used for non-commercial applications."))
  11.120 +  | Z3_Non_Commercial_Unknown =>
  11.121 +      error (Pretty.string_of (Pretty.para
  11.122 +        ("The SMT solver Z3 is not activated. To activate it, set the Isabelle \
  11.123 +         \system option \"z3_non_commercial\" to \"yes\" (e.g. via \
  11.124 +         \the Isabelle/jEdit menu Plugin Options / Isabelle / General)."))))
  11.125 +
  11.126 +end
  11.127 +
  11.128 +val z3_extensions = Attrib.setup_config_bool @{binding z3_new_extensions} (K false)
  11.129 +
  11.130 +local
  11.131 +  fun z3_make_command name () = if_z3_non_commercial (make_command name)
  11.132 +
  11.133 +  fun z3_options ctxt =
  11.134 +    ["REFINE_INJ_AXIOM=false" (* not supported by replay *),
  11.135 +     "-rs:" ^ string_of_int (Config.get ctxt SMT2_Config.random_seed),
  11.136 +     "-T:" ^ string_of_int (Real.ceil (Config.get ctxt SMT2_Config.timeout)),
  11.137 +     "-smt2"]
  11.138 +
  11.139 +  fun z3_on_first_or_last_line solver_name lines =
  11.140 +    let
  11.141 +      fun junk l =
  11.142 +        if String.isPrefix "WARNING: Out of allocated virtual memory" l
  11.143 +        then raise SMT2_Failure.SMT SMT2_Failure.Out_Of_Memory
  11.144 +        else
  11.145 +          String.isPrefix "WARNING" l orelse
  11.146 +          String.isPrefix "ERROR" l orelse
  11.147 +          forall Symbol.is_ascii_blank (Symbol.explode l)
  11.148 +      val lines = filter_out junk lines
  11.149 +      fun outcome split =
  11.150 +        the_default ("", []) (try split lines)
  11.151 +        |>> outcome_of "unsat" "sat" "unknown" solver_name
  11.152 +    in
  11.153 +      (* Starting with version 4.0, Z3 puts the outcome on the first line of the
  11.154 +         output rather than on the last line. *)
  11.155 +      outcome (fn lines => (hd lines, tl lines))
  11.156 +      handle SMT2_Failure.SMT _ => outcome (swap o split_last)
  11.157 +    end
  11.158 +
  11.159 +  fun select_class ctxt =
  11.160 +    if Config.get ctxt z3_extensions then Z3_New_Interface.smtlib2_z3C
  11.161 +    else SMTLIB2_Interface.smtlib2C
  11.162 +in
  11.163 +
  11.164 +val z3: SMT2_Solver.solver_config = {
  11.165 +  name = "z3_new",
  11.166 +  class = select_class,
  11.167 +  avail = make_avail "Z3_NEW",
  11.168 +  command = z3_make_command "Z3_NEW",
  11.169 +  options = z3_options,
  11.170 +  default_max_relevant = 350 (* FUDGE *),
  11.171 +  supports_filter = true,
  11.172 +  outcome = z3_on_first_or_last_line,
  11.173 +  cex_parser = NONE,
  11.174 +  replay = SOME Z3_New_Proof_Replay.replay }
  11.175 +
  11.176 +end
  11.177 +
  11.178 +
  11.179 +(* overall setup *)
  11.180 +
  11.181 +val _ = Theory.setup (
  11.182 +  SMT2_Solver.add_solver cvc3 #>
  11.183 +  SMT2_Solver.add_solver yices #>
  11.184 +  SMT2_Solver.add_solver z3)
  11.185 +
  11.186 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/SMT2/smt2_solver.ML	Thu Mar 13 13:18:13 2014 +0100
    12.3 @@ -0,0 +1,367 @@
    12.4 +(*  Title:      HOL/Tools/SMT2/smt2_solver.ML
    12.5 +    Author:     Sascha Boehme, TU Muenchen
    12.6 +
    12.7 +SMT solvers registry and SMT tactic.
    12.8 +*)
    12.9 +
   12.10 +signature SMT2_SOLVER =
   12.11 +sig
   12.12 +  (*configuration*)
   12.13 +  datatype outcome = Unsat | Sat | Unknown
   12.14 +  type solver_config = {
   12.15 +    name: string,
   12.16 +    class: Proof.context -> SMT2_Utils.class,
   12.17 +    avail: unit -> bool,
   12.18 +    command: unit -> string list,
   12.19 +    options: Proof.context -> string list,
   12.20 +    default_max_relevant: int,
   12.21 +    supports_filter: bool,
   12.22 +    outcome: string -> string list -> outcome * string list,
   12.23 +    cex_parser: (Proof.context -> SMT2_Translate.replay_data -> string list ->
   12.24 +      term list * term list) option,
   12.25 +    replay: (Proof.context -> SMT2_Translate.replay_data -> string list -> int list * thm) option }
   12.26 +
   12.27 +  (*registry*)
   12.28 +  val add_solver: solver_config -> theory -> theory
   12.29 +  val solver_name_of: Proof.context -> string
   12.30 +  val available_solvers_of: Proof.context -> string list
   12.31 +  val apply_solver: Proof.context -> (int * (int option * thm)) list ->
   12.32 +    int list * thm
   12.33 +  val default_max_relevant: Proof.context -> string -> int
   12.34 +
   12.35 +  (*filter*)
   12.36 +  type 'a smt2_filter_data =
   12.37 +    ('a * thm) list * ((int * thm) list * Proof.context)
   12.38 +  val smt2_filter_preprocess: Proof.context -> thm list -> thm ->
   12.39 +    ('a * (int option * thm)) list -> int -> 'a smt2_filter_data
   12.40 +  val smt2_filter_apply: Time.time -> 'a smt2_filter_data ->
   12.41 +    {outcome: SMT2_Failure.failure option, used_facts: ('a * thm) list}
   12.42 +
   12.43 +  (*tactic*)
   12.44 +  val smt2_tac: Proof.context -> thm list -> int -> tactic
   12.45 +  val smt2_tac': Proof.context -> thm list -> int -> tactic
   12.46 +end
   12.47 +
   12.48 +structure SMT2_Solver: SMT2_SOLVER =
   12.49 +struct
   12.50 +
   12.51 +
   12.52 +(* interface to external solvers *)
   12.53 +
   12.54 +local
   12.55 +
   12.56 +fun make_cmd command options problem_path proof_path = space_implode " " (
   12.57 +  "(exec 2>&1;" :: map File.shell_quote (command @ options) @
   12.58 +  [File.shell_path problem_path, ")", ">", File.shell_path proof_path])
   12.59 +
   12.60 +fun trace_and ctxt msg f x =
   12.61 +  let val _ = SMT2_Config.trace_msg ctxt (fn () => msg) ()
   12.62 +  in f x end
   12.63 +
   12.64 +fun run ctxt name mk_cmd input =
   12.65 +  (case SMT2_Config.certificates_of ctxt of
   12.66 +    NONE =>
   12.67 +      if not (SMT2_Config.is_available ctxt name) then
   12.68 +        error ("The SMT solver " ^ quote name ^ " is not installed.")
   12.69 +      else if Config.get ctxt SMT2_Config.debug_files = "" then
   12.70 +        trace_and ctxt ("Invoking SMT solver " ^ quote name ^ " ...")
   12.71 +          (Cache_IO.run mk_cmd) input
   12.72 +      else
   12.73 +        let
   12.74 +          val base_path = Path.explode (Config.get ctxt SMT2_Config.debug_files)
   12.75 +          val in_path = Path.ext "smt2_in" base_path
   12.76 +          val out_path = Path.ext "smt2_out" base_path
   12.77 +        in Cache_IO.raw_run mk_cmd input in_path out_path end
   12.78 +  | SOME certs =>
   12.79 +      (case Cache_IO.lookup certs input of
   12.80 +        (NONE, key) =>
   12.81 +          if Config.get ctxt SMT2_Config.read_only_certificates then
   12.82 +            error ("Bad certificate cache: missing certificate")
   12.83 +          else
   12.84 +            Cache_IO.run_and_cache certs key mk_cmd input
   12.85 +      | (SOME output, _) =>
   12.86 +          trace_and ctxt ("Using cached certificate from " ^
   12.87 +            File.shell_path (Cache_IO.cache_path_of certs) ^ " ...")
   12.88 +            I output))
   12.89 +
   12.90 +fun run_solver ctxt name mk_cmd input =
   12.91 +  let
   12.92 +    fun pretty tag ls = Pretty.string_of (Pretty.big_list tag
   12.93 +      (map Pretty.str ls))
   12.94 +
   12.95 +    val _ = SMT2_Config.trace_msg ctxt (pretty "Problem:" o split_lines) input
   12.96 +
   12.97 +    val {redirected_output=res, output=err, return_code} =
   12.98 +      SMT2_Config.with_timeout ctxt (run ctxt name mk_cmd) input
   12.99 +    val _ = SMT2_Config.trace_msg ctxt (pretty "Solver:") err
  12.100 +
  12.101 +    val output = fst (take_suffix (equal "") res)
  12.102 +    val _ = SMT2_Config.trace_msg ctxt (pretty "Result:") output
  12.103 +
  12.104 +    val _ = return_code <> 0 andalso
  12.105 +      raise SMT2_Failure.SMT (SMT2_Failure.Abnormal_Termination return_code)
  12.106 +  in output end
  12.107 +
  12.108 +fun trace_assms ctxt =
  12.109 +  SMT2_Config.trace_msg ctxt (Pretty.string_of o
  12.110 +    Pretty.big_list "Assertions:" o map (Display.pretty_thm ctxt o snd))
  12.111 +
  12.112 +fun trace_replay_data ({context=ctxt, typs, terms, ...} : SMT2_Translate.replay_data) =
  12.113 +  let
  12.114 +    fun pretty_eq n p = Pretty.block [Pretty.str n, Pretty.str " = ", p]
  12.115 +    fun p_typ (n, T) = pretty_eq n (Syntax.pretty_typ ctxt T)
  12.116 +    fun p_term (n, t) = pretty_eq n (Syntax.pretty_term ctxt t)
  12.117 +  in
  12.118 +    SMT2_Config.trace_msg ctxt (fn () =>
  12.119 +      Pretty.string_of (Pretty.big_list "Names:" [
  12.120 +        Pretty.big_list "sorts:" (map p_typ (Symtab.dest typs)),
  12.121 +        Pretty.big_list "functions:" (map p_term (Symtab.dest terms))])) ()
  12.122 +  end
  12.123 +
  12.124 +in
  12.125 +
  12.126 +fun invoke name command ithms ctxt =
  12.127 +  let
  12.128 +    val options = SMT2_Config.solver_options_of ctxt
  12.129 +    val cmd = command ()
  12.130 +    val comments = [space_implode " " (cmd @ options)]
  12.131 +
  12.132 +    val (str, replay_data as {context=ctxt', ...}) =
  12.133 +      ithms
  12.134 +      |> tap (trace_assms ctxt)
  12.135 +      |> SMT2_Translate.translate ctxt comments
  12.136 +      ||> tap trace_replay_data
  12.137 +  in (run_solver ctxt' name (make_cmd cmd options) str, replay_data) end
  12.138 +
  12.139 +end
  12.140 +
  12.141 +
  12.142 +(* configuration *)
  12.143 +
  12.144 +datatype outcome = Unsat | Sat | Unknown
  12.145 +
  12.146 +type solver_config = {
  12.147 +  name: string,
  12.148 +  class: Proof.context -> SMT2_Utils.class,
  12.149 +  avail: unit -> bool,
  12.150 +  command: unit -> string list,
  12.151 +  options: Proof.context -> string list,
  12.152 +  default_max_relevant: int,
  12.153 +  supports_filter: bool,
  12.154 +  outcome: string -> string list -> outcome * string list,
  12.155 +  cex_parser: (Proof.context -> SMT2_Translate.replay_data -> string list ->
  12.156 +    term list * term list) option,
  12.157 +  replay: (Proof.context -> SMT2_Translate.replay_data -> string list -> int list * thm) option }
  12.158 +
  12.159 +
  12.160 +(* registry *)
  12.161 +
  12.162 +type solver_info = {
  12.163 +  command: unit -> string list,
  12.164 +  default_max_relevant: int,
  12.165 +  supports_filter: bool,
  12.166 +  replay: Proof.context -> string list * SMT2_Translate.replay_data -> int list * thm }
  12.167 +
  12.168 +structure Solvers = Generic_Data
  12.169 +(
  12.170 +  type T = solver_info Symtab.table
  12.171 +  val empty = Symtab.empty
  12.172 +  val extend = I
  12.173 +  fun merge data = Symtab.merge (K true) data
  12.174 +)
  12.175 +
  12.176 +local
  12.177 +  fun finish outcome cex_parser replay ocl outer_ctxt
  12.178 +      (output, (replay_data as {context=ctxt, ...} : SMT2_Translate.replay_data)) =
  12.179 +    (case outcome output of
  12.180 +      (Unsat, ls) =>
  12.181 +        if not (Config.get ctxt SMT2_Config.oracle) andalso is_some replay
  12.182 +        then the replay outer_ctxt replay_data ls
  12.183 +        else ([], ocl ())
  12.184 +    | (result, ls) =>
  12.185 +        let
  12.186 +          val (ts, us) =
  12.187 +            (case cex_parser of SOME f => f ctxt replay_data ls | _ => ([], []))
  12.188 +         in
  12.189 +          raise SMT2_Failure.SMT (SMT2_Failure.Counterexample {
  12.190 +            is_real_cex = (result = Sat),
  12.191 +            free_constraints = ts,
  12.192 +            const_defs = us})
  12.193 +        end)
  12.194 +
  12.195 +  val cfalse = Thm.cterm_of @{theory} (@{const Trueprop} $ @{const False})
  12.196 +in
  12.197 +
  12.198 +fun add_solver cfg =
  12.199 +  let
  12.200 +    val {name, class, avail, command, options, default_max_relevant,
  12.201 +      supports_filter, outcome, cex_parser, replay} = cfg
  12.202 +
  12.203 +    fun core_oracle () = cfalse
  12.204 +
  12.205 +    fun solver ocl = {
  12.206 +      command = command,
  12.207 +      default_max_relevant = default_max_relevant,
  12.208 +      supports_filter = supports_filter,
  12.209 +      replay = finish (outcome name) cex_parser replay ocl }
  12.210 +
  12.211 +    val info = {name=name, class=class, avail=avail, options=options}
  12.212 +  in
  12.213 +    Thm.add_oracle (Binding.name name, core_oracle) #-> (fn (_, ocl) =>
  12.214 +    Context.theory_map (Solvers.map (Symtab.update_new (name, solver ocl)))) #>
  12.215 +    Context.theory_map (SMT2_Config.add_solver info)
  12.216 +  end
  12.217 +
  12.218 +end
  12.219 +
  12.220 +fun get_info ctxt name =
  12.221 +  the (Symtab.lookup (Solvers.get (Context.Proof ctxt)) name)
  12.222 +
  12.223 +val solver_name_of = SMT2_Config.solver_of
  12.224 +
  12.225 +val available_solvers_of = SMT2_Config.available_solvers_of
  12.226 +
  12.227 +fun name_and_info_of ctxt =
  12.228 +  let val name = solver_name_of ctxt
  12.229 +  in (name, get_info ctxt name) end
  12.230 +
  12.231 +fun gen_preprocess ctxt iwthms = SMT2_Normalize.normalize iwthms ctxt
  12.232 +
  12.233 +fun gen_apply (ithms, ctxt) =
  12.234 +  let val (name, {command, replay, ...}) = name_and_info_of ctxt
  12.235 +  in
  12.236 +    (ithms, ctxt)
  12.237 +    |-> invoke name command
  12.238 +    |> replay ctxt
  12.239 +    |>> distinct (op =)
  12.240 +  end
  12.241 +
  12.242 +fun apply_solver ctxt = gen_apply o gen_preprocess ctxt
  12.243 +
  12.244 +val default_max_relevant = #default_max_relevant oo get_info
  12.245 +
  12.246 +val supports_filter = #supports_filter o snd o name_and_info_of 
  12.247 +
  12.248 +
  12.249 +(* check well-sortedness *)
  12.250 +
  12.251 +val has_topsort = Term.exists_type (Term.exists_subtype (fn
  12.252 +    TFree (_, []) => true
  12.253 +  | TVar (_, []) => true
  12.254 +  | _ => false))
  12.255 +
  12.256 +(* without this test, we would run into problems when atomizing the rules: *)
  12.257 +fun check_topsort ctxt thm =
  12.258 +  if has_topsort (Thm.prop_of thm) then
  12.259 +    (SMT2_Normalize.drop_fact_warning ctxt thm; TrueI)
  12.260 +  else
  12.261 +    thm
  12.262 +
  12.263 +fun check_topsorts ctxt iwthms = map (apsnd (apsnd (check_topsort ctxt))) iwthms
  12.264 +
  12.265 +
  12.266 +(* filter *)
  12.267 +
  12.268 +val cnot = Thm.cterm_of @{theory} @{const Not}
  12.269 +
  12.270 +fun mk_result outcome xrules = { outcome = outcome, used_facts = xrules }
  12.271 +
  12.272 +type 'a smt2_filter_data = ('a * thm) list * ((int * thm) list * Proof.context)
  12.273 +
  12.274 +fun smt2_filter_preprocess ctxt facts goal xwthms i =
  12.275 +  let
  12.276 +    val ctxt =
  12.277 +      ctxt
  12.278 +      |> Config.put SMT2_Config.oracle false
  12.279 +      |> Config.put SMT2_Config.filter_only_facts true
  12.280 +
  12.281 +    val ({context=ctxt', prems, concl, ...}, _) = Subgoal.focus ctxt i goal
  12.282 +    fun negate ct = Thm.dest_comb ct ||> Thm.apply cnot |-> Thm.apply
  12.283 +    val cprop =
  12.284 +      (case try negate (Thm.rhs_of (SMT2_Normalize.atomize_conv ctxt' concl)) of
  12.285 +        SOME ct => ct
  12.286 +      | NONE => raise SMT2_Failure.SMT (SMT2_Failure.Other_Failure (
  12.287 +          "goal is not a HOL term")))
  12.288 +  in
  12.289 +    map snd xwthms
  12.290 +    |> map_index I
  12.291 +    |> append (map (pair ~1 o pair NONE) (Thm.assume cprop :: prems @ facts))
  12.292 +    |> check_topsorts ctxt'
  12.293 +    |> gen_preprocess ctxt'
  12.294 +    |> pair (map (apsnd snd) xwthms)
  12.295 +  end
  12.296 +
  12.297 +fun smt2_filter_apply time_limit (xthms, (ithms, ctxt)) =
  12.298 +  let
  12.299 +    val ctxt' =
  12.300 +      ctxt
  12.301 +      |> Config.put SMT2_Config.timeout (Time.toReal time_limit)
  12.302 +
  12.303 +    fun filter_thms false = K xthms
  12.304 +      | filter_thms true = map_filter (try (nth xthms)) o fst
  12.305 +  in
  12.306 +    (ithms, ctxt')
  12.307 +    |> gen_apply
  12.308 +    |> filter_thms (supports_filter ctxt')
  12.309 +    |> mk_result NONE
  12.310 +  end
  12.311 +  handle SMT2_Failure.SMT fail => mk_result (SOME fail) []
  12.312 +
  12.313 +
  12.314 +(* SMT tactic *)
  12.315 +
  12.316 +local
  12.317 +  fun trace_assumptions ctxt iwthms idxs =
  12.318 +    let
  12.319 +      val wthms =
  12.320 +        idxs
  12.321 +        |> filter (fn i => i >= 0)
  12.322 +        |> map_filter (AList.lookup (op =) iwthms)
  12.323 +    in
  12.324 +      if Config.get ctxt SMT2_Config.trace_used_facts andalso length wthms > 0
  12.325 +      then
  12.326 +        tracing (Pretty.string_of (Pretty.big_list "SMT used facts:"
  12.327 +          (map (Display.pretty_thm ctxt o snd) wthms)))
  12.328 +      else ()
  12.329 +    end
  12.330 +
  12.331 +  fun solve ctxt iwthms =
  12.332 +    iwthms
  12.333 +    |> check_topsorts ctxt
  12.334 +    |> apply_solver ctxt
  12.335 +    |>> trace_assumptions ctxt iwthms
  12.336 +    |> snd
  12.337 +
  12.338 +  fun str_of ctxt fail =
  12.339 +    SMT2_Failure.string_of_failure ctxt fail
  12.340 +    |> prefix ("Solver " ^ SMT2_Config.solver_of ctxt ^ ": ")
  12.341 +
  12.342 +  fun safe_solve ctxt iwthms = SOME (solve ctxt iwthms)
  12.343 +    handle
  12.344 +      SMT2_Failure.SMT (fail as SMT2_Failure.Counterexample _) =>
  12.345 +        (SMT2_Config.verbose_msg ctxt (str_of ctxt) fail; NONE)
  12.346 +    | SMT2_Failure.SMT (fail as SMT2_Failure.Time_Out) =>
  12.347 +        error ("SMT: Solver " ^ quote (SMT2_Config.solver_of ctxt) ^ ": " ^
  12.348 +          SMT2_Failure.string_of_failure ctxt fail ^ " (setting the " ^
  12.349 +          "configuration option " ^ quote (Config.name_of SMT2_Config.timeout) ^ " might help)")
  12.350 +    | SMT2_Failure.SMT fail => error (str_of ctxt fail)
  12.351 +
  12.352 +  fun tag_rules thms = map_index (apsnd (pair NONE)) thms
  12.353 +  fun tag_prems thms = map (pair ~1 o pair NONE) thms
  12.354 +
  12.355 +  fun resolve (SOME thm) = rtac thm 1
  12.356 +    | resolve NONE = no_tac
  12.357 +
  12.358 +  fun tac prove ctxt rules =
  12.359 +    CONVERSION (SMT2_Normalize.atomize_conv ctxt)
  12.360 +    THEN' rtac @{thm ccontr}
  12.361 +    THEN' SUBPROOF (fn {context, prems, ...} =>
  12.362 +      resolve (prove context (tag_rules rules @ tag_prems prems))) ctxt
  12.363 +in
  12.364 +
  12.365 +val smt2_tac = tac safe_solve
  12.366 +val smt2_tac' = tac (SOME oo solve)
  12.367 +
  12.368 +end
  12.369 +
  12.370 +end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Tools/SMT2/smt2_translate.ML	Thu Mar 13 13:18:13 2014 +0100
    13.3 @@ -0,0 +1,540 @@
    13.4 +(*  Title:      HOL/Tools/SMT2/smt2_translate.ML
    13.5 +    Author:     Sascha Boehme, TU Muenchen
    13.6 +
    13.7 +Translate theorems into an SMT intermediate format and serialize them.
    13.8 +*)
    13.9 +
   13.10 +signature SMT2_TRANSLATE =
   13.11 +sig
   13.12 +  (*intermediate term structure*)
   13.13 +  datatype squant = SForall | SExists
   13.14 +  datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   13.15 +  datatype sterm =
   13.16 +    SVar of int |
   13.17 +    SApp of string * sterm list |
   13.18 +    SLet of string * sterm * sterm |
   13.19 +    SQua of squant * string list * sterm spattern list * int option * sterm
   13.20 +
   13.21 +  (*translation configuration*)
   13.22 +  type sign = {
   13.23 +    header: string,
   13.24 +    sorts: string list,
   13.25 +    dtyps: (string * (string * (string * string) list) list) list list,
   13.26 +    funcs: (string * (string list * string)) list }
   13.27 +  type config = {
   13.28 +    header: term list -> string,
   13.29 +    has_datatypes: bool,
   13.30 +    serialize: string list -> sign -> sterm list -> string }
   13.31 +  type replay_data = {
   13.32 +    context: Proof.context,
   13.33 +    typs: typ Symtab.table,
   13.34 +    terms: term Symtab.table,
   13.35 +    rewrite_rules: thm list,
   13.36 +    assms: (int * thm) list }
   13.37 +
   13.38 +  (*translation*)
   13.39 +  val add_config: SMT2_Utils.class * (Proof.context -> config) -> Context.generic -> Context.generic
   13.40 +  val translate: Proof.context -> string list -> (int * thm) list -> string * replay_data
   13.41 +end
   13.42 +
   13.43 +structure SMT2_Translate: SMT2_TRANSLATE =
   13.44 +struct
   13.45 +
   13.46 +
   13.47 +(* intermediate term structure *)
   13.48 +
   13.49 +datatype squant = SForall | SExists
   13.50 +
   13.51 +datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   13.52 +
   13.53 +datatype sterm =
   13.54 +  SVar of int |
   13.55 +  SApp of string * sterm list |
   13.56 +  SLet of string * sterm * sterm |
   13.57 +  SQua of squant * string list * sterm spattern list * int option * sterm
   13.58 +
   13.59 +
   13.60 +
   13.61 +(* translation configuration *)
   13.62 +
   13.63 +type sign = {
   13.64 +  header: string,
   13.65 +  sorts: string list,
   13.66 +  dtyps: (string * (string * (string * string) list) list) list list,
   13.67 +  funcs: (string * (string list * string)) list }
   13.68 +
   13.69 +type config = {
   13.70 +  header: term list -> string,
   13.71 +  has_datatypes: bool,
   13.72 +  serialize: string list -> sign -> sterm list -> string }
   13.73 +
   13.74 +type replay_data = {
   13.75 +  context: Proof.context,
   13.76 +  typs: typ Symtab.table,
   13.77 +  terms: term Symtab.table,
   13.78 +  rewrite_rules: thm list,
   13.79 +  assms: (int * thm) list }
   13.80 +
   13.81 +
   13.82 +
   13.83 +(* translation context *)
   13.84 +
   13.85 +fun add_components_of_typ (Type (s, Ts)) =
   13.86 +    cons (Long_Name.base_name s) #> fold_rev add_components_of_typ Ts
   13.87 +  | add_components_of_typ (TFree (s, _)) = cons (perhaps (try (unprefix "'")) s)
   13.88 +  | add_components_of_typ _ = I;
   13.89 +
   13.90 +fun suggested_name_of_typ T = space_implode "_" (add_components_of_typ T []);
   13.91 +
   13.92 +fun suggested_name_of_term (Const (s, _)) = Long_Name.base_name s
   13.93 +  | suggested_name_of_term (Free (s, _)) = s
   13.94 +  | suggested_name_of_term _ = Name.uu
   13.95 +
   13.96 +val empty_tr_context = (Name.context, Typtab.empty, Termtab.empty)
   13.97 +val safe_prefix = "$"
   13.98 +
   13.99 +fun add_typ T proper (cx as (names, typs, terms)) =
  13.100 +  (case Typtab.lookup typs T of
  13.101 +    SOME (name, _) => (name, cx)
  13.102 +  | NONE =>
  13.103 +      let
  13.104 +        val sugg = safe_prefix ^ Name.desymbolize true (suggested_name_of_typ T)
  13.105 +        val (name, names') = Name.variant sugg names
  13.106 +        val typs' = Typtab.update (T, (name, proper)) typs
  13.107 +      in (name, (names', typs', terms)) end)
  13.108 +
  13.109 +fun add_fun t sort (cx as (names, typs, terms)) =
  13.110 +  (case Termtab.lookup terms t of
  13.111 +    SOME (name, _) => (name, cx)
  13.112 +  | NONE => 
  13.113 +      let
  13.114 +        val sugg = safe_prefix ^ Name.desymbolize false (suggested_name_of_term t)
  13.115 +        val (name, names') = Name.variant sugg names
  13.116 +        val terms' = Termtab.update (t, (name, sort)) terms
  13.117 +      in (name, (names', typs, terms')) end)
  13.118 +
  13.119 +fun sign_of header dtyps (_, typs, terms) = {
  13.120 +  header = header,
  13.121 +  sorts = Typtab.fold (fn (_, (n, true)) => cons n | _ => I) typs [],
  13.122 +  dtyps = dtyps,
  13.123 +  funcs = Termtab.fold (fn (_, (n, SOME ss)) => cons (n,ss) | _ => I) terms []}
  13.124 +
  13.125 +fun replay_data_of ctxt rules assms (_, typs, terms) =
  13.126 +  let
  13.127 +    fun add_typ (T, (n, _)) = Symtab.update (n, T)
  13.128 +    val typs' = Typtab.fold add_typ typs Symtab.empty
  13.129 +
  13.130 +    fun add_fun (t, (n, _)) = Symtab.update (n, t)
  13.131 +    val terms' = Termtab.fold add_fun terms Symtab.empty
  13.132 +  in
  13.133 +    {context=ctxt, typs=typs', terms=terms', rewrite_rules=rules, assms=assms}
  13.134 +  end
  13.135 +
  13.136 +
  13.137 +
  13.138 +(* preprocessing *)
  13.139 +
  13.140 +(** datatype declarations **)
  13.141 +
  13.142 +fun collect_datatypes_and_records (tr_context, ctxt) ts =
  13.143 +  let
  13.144 +    val (declss, ctxt') = fold (Term.fold_types SMT2_Datatypes.add_decls) ts ([], ctxt)
  13.145 +
  13.146 +    fun is_decl_typ T = exists (exists (equal T o fst)) declss
  13.147 +
  13.148 +    fun add_typ' T proper =
  13.149 +      (case SMT2_Builtin.dest_builtin_typ ctxt' T of
  13.150 +        SOME n => pair n
  13.151 +      | NONE => add_typ T proper)
  13.152 +
  13.153 +    fun tr_select sel =
  13.154 +      let val T = Term.range_type (Term.fastype_of sel)
  13.155 +      in add_fun sel NONE ##>> add_typ' T (not (is_decl_typ T)) end
  13.156 +    fun tr_constr (constr, selects) =
  13.157 +      add_fun constr NONE ##>> fold_map tr_select selects
  13.158 +    fun tr_typ (T, cases) = add_typ' T false ##>> fold_map tr_constr cases
  13.159 +    val (declss', tr_context') = fold_map (fold_map tr_typ) declss tr_context
  13.160 +
  13.161 +    fun add (constr, selects) =
  13.162 +      Termtab.update (constr, length selects) #>
  13.163 +      fold (Termtab.update o rpair 1) selects
  13.164 +    val funcs = fold (fold (fold add o snd)) declss Termtab.empty
  13.165 +  in ((funcs, declss', tr_context', ctxt'), ts) end
  13.166 +    (* FIXME: also return necessary datatype and record theorems *)
  13.167 +
  13.168 +
  13.169 +(** eta-expand quantifiers, let expressions and built-ins *)
  13.170 +
  13.171 +local
  13.172 +  fun eta f T t = Abs (Name.uu, T, f (Term.incr_boundvars 1 t $ Bound 0))
  13.173 +
  13.174 +  fun exp f T = eta f (Term.domain_type (Term.domain_type T))
  13.175 +
  13.176 +  fun exp2 T q =
  13.177 +    let val U = Term.domain_type T
  13.178 +    in Abs (Name.uu, U, q $ eta I (Term.domain_type U) (Bound 0)) end
  13.179 +
  13.180 +  fun expf k i T t =
  13.181 +    let val Ts = drop i (fst (SMT2_Utils.dest_funT k T))
  13.182 +    in
  13.183 +      Term.incr_boundvars (length Ts) t
  13.184 +      |> fold_rev (fn i => fn u => u $ Bound i) (0 upto length Ts - 1)
  13.185 +      |> fold_rev (fn T => fn u => Abs (Name.uu, T, u)) Ts
  13.186 +    end
  13.187 +in
  13.188 +
  13.189 +fun eta_expand ctxt funcs =
  13.190 +  let
  13.191 +    fun exp_func t T ts =
  13.192 +      (case Termtab.lookup funcs t of
  13.193 +        SOME k => Term.list_comb (t, ts) |> k <> length ts ? expf k (length ts) T
  13.194 +      | NONE => Term.list_comb (t, ts))
  13.195 +
  13.196 +    fun expand ((q as Const (@{const_name All}, _)) $ Abs a) = q $ abs_expand a
  13.197 +      | expand ((q as Const (@{const_name All}, T)) $ t) = q $ exp expand T t
  13.198 +      | expand (q as Const (@{const_name All}, T)) = exp2 T q
  13.199 +      | expand ((q as Const (@{const_name Ex}, _)) $ Abs a) = q $ abs_expand a
  13.200 +      | expand ((q as Const (@{const_name Ex}, T)) $ t) = q $ exp expand T t
  13.201 +      | expand (q as Const (@{const_name Ex}, T)) = exp2 T q
  13.202 +      | expand ((l as Const (@{const_name Let}, _)) $ t $ Abs a) = expand (Term.betapply (Abs a, t))
  13.203 +      | expand ((l as Const (@{const_name Let}, T)) $ t $ u) = expand (u $ t)
  13.204 +      | expand ((l as Const (@{const_name Let}, T)) $ t) =
  13.205 +          let val U = Term.domain_type (Term.range_type T)
  13.206 +          in Abs (Name.uu, U, Bound 0 $ Term.incr_boundvars 1 t) end
  13.207 +      | expand (Const (@{const_name Let}, T)) =
  13.208 +          let val U = Term.domain_type (Term.range_type T)
  13.209 +          in Abs (Name.uu, Term.domain_type T, Abs (Name.uu, U, Bound 0 $ Bound 1)) end
  13.210 +      | expand t =
  13.211 +          (case Term.strip_comb t of
  13.212 +            (u as Const (c as (_, T)), ts) =>
  13.213 +              (case SMT2_Builtin.dest_builtin ctxt c ts of
  13.214 +                SOME (_, k, us, mk) =>
  13.215 +                  if k = length us then mk (map expand us)
  13.216 +                  else if k < length us then chop k (map expand us) |>> mk |> Term.list_comb
  13.217 +                  else expf k (length ts) T (mk (map expand us))
  13.218 +              | NONE => exp_func u T (map expand ts))
  13.219 +          | (u as Free (_, T), ts) => exp_func u T (map expand ts)
  13.220 +          | (Abs a, ts) => Term.list_comb (abs_expand a, map expand ts)
  13.221 +          | (u, ts) => Term.list_comb (u, map expand ts))
  13.222 +
  13.223 +    and abs_expand (n, T, t) = Abs (n, T, expand t)
  13.224 +  
  13.225 +  in map expand end
  13.226 +
  13.227 +end
  13.228 +
  13.229 +
  13.230 +(** introduce explicit applications **)
  13.231 +
  13.232 +local
  13.233 +  (*
  13.234 +    Make application explicit for functions with varying number of arguments.
  13.235 +  *)
  13.236 +
  13.237 +  fun add t i = apfst (Termtab.map_default (t, i) (Integer.min i))
  13.238 +  fun add_type T = apsnd (Typtab.update (T, ()))
  13.239 +
  13.240 +  fun min_arities t =
  13.241 +    (case Term.strip_comb t of
  13.242 +      (u as Const _, ts) => add u (length ts) #> fold min_arities ts
  13.243 +    | (u as Free _, ts) => add u (length ts) #> fold min_arities ts
  13.244 +    | (Abs (_, T, u), ts) => (can dest_funT T ? add_type T) #> min_arities u #> fold min_arities ts
  13.245 +    | (_, ts) => fold min_arities ts)
  13.246 +
  13.247 +  fun minimize types t i =
  13.248 +    let
  13.249 +      fun find_min j [] _ = j
  13.250 +        | find_min j (U :: Us) T =
  13.251 +            if Typtab.defined types T then j else find_min (j + 1) Us (U --> T)
  13.252 +
  13.253 +      val (Ts, T) = Term.strip_type (Term.type_of t)
  13.254 +    in find_min 0 (take i (rev Ts)) T end
  13.255 +
  13.256 +  fun app u (t, T) =
  13.257 +    (Const (@{const_name SMT2.fun_app}, T --> T) $ t $ u, Term.range_type T)
  13.258 +
  13.259 +  fun apply i t T ts =
  13.260 +    let
  13.261 +      val (ts1, ts2) = chop i ts
  13.262 +      val (_, U) = SMT2_Utils.dest_funT i T
  13.263 +    in fst (fold app ts2 (Term.list_comb (t, ts1), U)) end
  13.264 +in
  13.265 +
  13.266 +fun intro_explicit_application ctxt funcs ts =
  13.267 +  let
  13.268 +    val (arities, types) = fold min_arities ts (Termtab.empty, Typtab.empty)
  13.269 +    val arities' = Termtab.map (minimize types) arities (* FIXME: highly suspicious *)
  13.270 +
  13.271 +    fun app_func t T ts =
  13.272 +      if is_some (Termtab.lookup funcs t) then Term.list_comb (t, ts)
  13.273 +      else apply (the (Termtab.lookup arities' t)) t T ts
  13.274 +
  13.275 +    fun in_list T f t = HOLogic.mk_list T (map f (HOLogic.dest_list t))
  13.276 +
  13.277 +    fun traverse Ts t =
  13.278 +      (case Term.strip_comb t of
  13.279 +        (q as Const (@{const_name All}, _), [Abs (x, T, u)]) =>
  13.280 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  13.281 +      | (q as Const (@{const_name Ex}, _), [Abs (x, T, u)]) =>
  13.282 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  13.283 +      | (q as Const (@{const_name Let}, _), [u1, u2 as Abs _]) =>
  13.284 +          q $ traverse Ts u1 $ traverse Ts u2
  13.285 +      | (u as Const (c as (_, T)), ts) =>
  13.286 +          (case SMT2_Builtin.dest_builtin ctxt c ts of
  13.287 +            SOME (_, k, us, mk) =>
  13.288 +              let
  13.289 +                val (ts1, ts2) = chop k (map (traverse Ts) us)
  13.290 +                val U = Term.strip_type T |>> snd o chop k |> (op --->)
  13.291 +              in apply 0 (mk ts1) U ts2 end
  13.292 +          | NONE => app_func u T (map (traverse Ts) ts))
  13.293 +      | (u as Free (_, T), ts) => app_func u T (map (traverse Ts) ts)
  13.294 +      | (u as Bound i, ts) => apply 0 u (nth Ts i) (map (traverse Ts) ts)
  13.295 +      | (Abs (n, T, u), ts) => traverses Ts (Abs (n, T, traverse (T::Ts) u)) ts
  13.296 +      | (u, ts) => traverses Ts u ts)
  13.297 +    and in_trigger Ts ((c as @{const SMT2.trigger}) $ p $ t) = c $ in_pats Ts p $ in_weight Ts t
  13.298 +      | in_trigger Ts t = in_weight Ts t
  13.299 +    and in_pats Ts ps =
  13.300 +      in_list @{typ "SMT2.pattern list"} (in_list @{typ SMT2.pattern} (in_pat Ts)) ps
  13.301 +    and in_pat Ts ((p as Const (@{const_name SMT2.pat}, _)) $ t) = p $ traverse Ts t
  13.302 +      | in_pat Ts ((p as Const (@{const_name SMT2.nopat}, _)) $ t) = p $ traverse Ts t
  13.303 +      | in_pat _ t = raise TERM ("bad pattern", [t])
  13.304 +    and in_weight Ts ((c as @{const SMT2.weight}) $ w $ t) = c $ w $ traverse Ts t
  13.305 +      | in_weight Ts t = traverse Ts t 
  13.306 +    and traverses Ts t ts = Term.list_comb (t, map (traverse Ts) ts)
  13.307 +  in map (traverse []) ts end
  13.308 +
  13.309 +val fun_app_eq = mk_meta_eq @{thm SMT2.fun_app_def}
  13.310 +
  13.311 +end
  13.312 +
  13.313 +
  13.314 +(** map HOL formulas to FOL formulas (i.e., separate formulas froms terms) **)
  13.315 +
  13.316 +local
  13.317 +  val is_quant = member (op =) [@{const_name All}, @{const_name Ex}]
  13.318 +
  13.319 +  val fol_rules = [
  13.320 +    Let_def,
  13.321 +    @{lemma "P = True == P" by (rule eq_reflection) simp},
  13.322 +    @{lemma "if P then True else False == P" by (rule eq_reflection) simp}]
  13.323 +
  13.324 +  exception BAD_PATTERN of unit
  13.325 +
  13.326 +  fun wrap_in_if pat t =
  13.327 +    if pat then raise BAD_PATTERN ()
  13.328 +    else @{const If (bool)} $ t $ @{const True} $ @{const False}
  13.329 +
  13.330 +  fun is_builtin_conn_or_pred ctxt c ts =
  13.331 +    is_some (SMT2_Builtin.dest_builtin_conn ctxt c ts) orelse
  13.332 +    is_some (SMT2_Builtin.dest_builtin_pred ctxt c ts)
  13.333 +in
  13.334 +
  13.335 +fun folify ctxt =
  13.336 +  let
  13.337 +    fun in_list T f t = HOLogic.mk_list T (map_filter f (HOLogic.dest_list t))
  13.338 +
  13.339 +    fun in_term pat t =
  13.340 +      (case Term.strip_comb t of
  13.341 +        (@{const True}, []) => t
  13.342 +      | (@{const False}, []) => t
  13.343 +      | (u as Const (@{const_name If}, _), [t1, t2, t3]) =>
  13.344 +          if pat then raise BAD_PATTERN ()
  13.345 +          else u $ in_form t1 $ in_term pat t2 $ in_term pat t3
  13.346 +      | (Const (c as (n, _)), ts) =>
  13.347 +          if is_builtin_conn_or_pred ctxt c ts then wrap_in_if pat (in_form t)
  13.348 +          else if is_quant n then wrap_in_if pat (in_form t)
  13.349 +          else Term.list_comb (Const c, map (in_term pat) ts)
  13.350 +      | (Free c, ts) => Term.list_comb (Free c, map (in_term pat) ts)
  13.351 +      | _ => t)
  13.352 +
  13.353 +    and in_weight ((c as @{const SMT2.weight}) $ w $ t) = c $ w $ in_form t
  13.354 +      | in_weight t = in_form t 
  13.355 +
  13.356 +    and in_pat ((p as Const (@{const_name SMT2.pat}, _)) $ t) =
  13.357 +          p $ in_term true t
  13.358 +      | in_pat ((p as Const (@{const_name SMT2.nopat}, _)) $ t) =
  13.359 +          p $ in_term true t
  13.360 +      | in_pat t = raise TERM ("bad pattern", [t])
  13.361 +
  13.362 +    and in_pats ps =
  13.363 +      in_list @{typ "SMT2.pattern list"}
  13.364 +        (SOME o in_list @{typ SMT2.pattern} (try in_pat)) ps
  13.365 +
  13.366 +    and in_trigger ((c as @{const SMT2.trigger}) $ p $ t) =
  13.367 +          c $ in_pats p $ in_weight t
  13.368 +      | in_trigger t = in_weight t
  13.369 +
  13.370 +    and in_form t =
  13.371 +      (case Term.strip_comb t of
  13.372 +        (q as Const (qn, _), [Abs (n, T, u)]) =>
  13.373 +          if is_quant qn then q $ Abs (n, T, in_trigger u)
  13.374 +          else in_term false t
  13.375 +      | (Const c, ts) =>
  13.376 +          (case SMT2_Builtin.dest_builtin_conn ctxt c ts of
  13.377 +            SOME (_, _, us, mk) => mk (map in_form us)
  13.378 +          | NONE =>
  13.379 +              (case SMT2_Builtin.dest_builtin_pred ctxt c ts of
  13.380 +                SOME (_, _, us, mk) => mk (map (in_term false) us)
  13.381 +              | NONE => in_term false t))
  13.382 +      | _ => in_term false t)
  13.383 +  in
  13.384 +    map in_form #>
  13.385 +    pair (fol_rules, I)
  13.386 +  end
  13.387 +
  13.388 +end
  13.389 +
  13.390 +
  13.391 +(* translation into intermediate format *)
  13.392 +
  13.393 +(** utility functions **)
  13.394 +
  13.395 +val quantifier = (fn
  13.396 +    @{const_name All} => SOME SForall
  13.397 +  | @{const_name Ex} => SOME SExists
  13.398 +  | _ => NONE)
  13.399 +
  13.400 +fun group_quant qname Ts (t as Const (q, _) $ Abs (_, T, u)) =
  13.401 +      if q = qname then group_quant qname (T :: Ts) u else (Ts, t)
  13.402 +  | group_quant _ Ts t = (Ts, t)
  13.403 +
  13.404 +fun dest_weight (@{const SMT2.weight} $ w $ t) = (SOME (snd (HOLogic.dest_number w)), t)
  13.405 +  | dest_weight t = (NONE, t)
  13.406 +
  13.407 +fun dest_pat (Const (@{const_name SMT2.pat}, _) $ t) = (t, true)
  13.408 +  | dest_pat (Const (@{const_name SMT2.nopat}, _) $ t) = (t, false)
  13.409 +  | dest_pat t = raise TERM ("bad pattern", [t])
  13.410 +
  13.411 +fun dest_pats [] = I
  13.412 +  | dest_pats ts =
  13.413 +      (case map dest_pat ts |> split_list ||> distinct (op =) of
  13.414 +        (ps, [true]) => cons (SPat ps)
  13.415 +      | (ps, [false]) => cons (SNoPat ps)
  13.416 +      | _ => raise TERM ("bad multi-pattern", ts))
  13.417 +
  13.418 +fun dest_trigger (@{const SMT2.trigger} $ tl $ t) =
  13.419 +      (rev (fold (dest_pats o HOLogic.dest_list) (HOLogic.dest_list tl) []), t)
  13.420 +  | dest_trigger t = ([], t)
  13.421 +
  13.422 +fun dest_quant qn T t = quantifier qn |> Option.map (fn q =>
  13.423 +  let
  13.424 +    val (Ts, u) = group_quant qn [T] t
  13.425 +    val (ps, p) = dest_trigger u
  13.426 +    val (w, b) = dest_weight p
  13.427 +  in (q, rev Ts, ps, w, b) end)
  13.428 +
  13.429 +fun fold_map_pat f (SPat ts) = fold_map f ts #>> SPat
  13.430 +  | fold_map_pat f (SNoPat ts) = fold_map f ts #>> SNoPat
  13.431 +
  13.432 +
  13.433 +(** translation from Isabelle terms into SMT intermediate terms **)
  13.434 +
  13.435 +fun intermediate header dtyps builtin ctxt ts trx =
  13.436 +  let
  13.437 +    fun transT (T as TFree _) = add_typ T true
  13.438 +      | transT (T as TVar _) = (fn _ => raise TYPE ("bad SMT type", [T], []))
  13.439 +      | transT (T as Type _) =
  13.440 +          (case SMT2_Builtin.dest_builtin_typ ctxt T of
  13.441 +            SOME n => pair n
  13.442 +          | NONE => add_typ T true)
  13.443 +
  13.444 +    fun app n ts = SApp (n, ts)
  13.445 +
  13.446 +    fun trans t =
  13.447 +      (case Term.strip_comb t of
  13.448 +        (Const (qn, _), [Abs (_, T, t1)]) =>
  13.449 +          (case dest_quant qn T t1 of
  13.450 +            SOME (q, Ts, ps, w, b) =>
  13.451 +              fold_map transT Ts ##>> fold_map (fold_map_pat trans) ps ##>>
  13.452 +              trans b #>> (fn ((Ts', ps'), b') => SQua (q, Ts', ps', w, b'))
  13.453 +          | NONE => raise TERM ("unsupported quantifier", [t]))
  13.454 +      | (Const (@{const_name Let}, _), [t1, Abs (_, T, t2)]) =>
  13.455 +          transT T ##>> trans t1 ##>> trans t2 #>> (fn ((U, u1), u2) => SLet (U, u1, u2))
  13.456 +      | (u as Const (c as (_, T)), ts) =>
  13.457 +          (case builtin ctxt c ts of
  13.458 +            SOME (n, _, us, _) => fold_map trans us #>> app n
  13.459 +          | NONE => transs u T ts)
  13.460 +      | (u as Free (_, T), ts) => transs u T ts
  13.461 +      | (Bound i, []) => pair (SVar i)
  13.462 +      | _ => raise TERM ("bad SMT term", [t]))
  13.463 + 
  13.464 +    and transs t T ts =
  13.465 +      let val (Us, U) = SMT2_Utils.dest_funT (length ts) T
  13.466 +      in
  13.467 +        fold_map transT Us ##>> transT U #-> (fn Up =>
  13.468 +        add_fun t (SOME Up) ##>> fold_map trans ts #>> SApp)
  13.469 +      end
  13.470 +
  13.471 +    val (us, trx') = fold_map trans ts trx
  13.472 +  in ((sign_of (header ts) dtyps trx', us), trx') end
  13.473 +
  13.474 +
  13.475 +
  13.476 +(* translation *)
  13.477 +
  13.478 +structure Configs = Generic_Data
  13.479 +(
  13.480 +  type T = (Proof.context -> config) SMT2_Utils.dict
  13.481 +  val empty = []
  13.482 +  val extend = I
  13.483 +  fun merge data = SMT2_Utils.dict_merge fst data
  13.484 +)
  13.485 +
  13.486 +fun add_config (cs, cfg) = Configs.map (SMT2_Utils.dict_update (cs, cfg))
  13.487 +
  13.488 +fun get_config ctxt = 
  13.489 +  let val cs = SMT2_Config.solver_class_of ctxt
  13.490 +  in
  13.491 +    (case SMT2_Utils.dict_get (Configs.get (Context.Proof ctxt)) cs of
  13.492 +      SOME cfg => cfg ctxt
  13.493 +    | NONE => error ("SMT: no translation configuration found " ^
  13.494 +        "for solver class " ^ quote (SMT2_Utils.string_of_class cs)))
  13.495 +  end
  13.496 +
  13.497 +fun translate ctxt comments ithms =
  13.498 +  let
  13.499 +    val {header, has_datatypes, serialize} = get_config ctxt
  13.500 +
  13.501 +    fun no_dtyps (tr_context, ctxt) ts =
  13.502 +      ((Termtab.empty, [], tr_context, ctxt), ts)
  13.503 +
  13.504 +    val ts1 = map (Envir.beta_eta_contract o SMT2_Utils.prop_of o snd) ithms
  13.505 +
  13.506 +    val ((funcs, dtyps, tr_context, ctxt1), ts2) =
  13.507 +      ((empty_tr_context, ctxt), ts1)
  13.508 +      |-> (if has_datatypes then collect_datatypes_and_records else no_dtyps)
  13.509 +
  13.510 +    fun is_binder (Const (@{const_name Let}, _) $ _) = true
  13.511 +      | is_binder t = Lambda_Lifting.is_quantifier t
  13.512 +
  13.513 +    fun mk_trigger ((q as Const (@{const_name All}, _)) $ Abs (n, T, t)) =
  13.514 +          q $ Abs (n, T, mk_trigger t)
  13.515 +      | mk_trigger (eq as (Const (@{const_name HOL.eq}, T) $ lhs $ _)) =
  13.516 +          Term.domain_type T --> @{typ SMT2.pattern}
  13.517 +          |> (fn T => Const (@{const_name SMT2.pat}, T) $ lhs)
  13.518 +          |> HOLogic.mk_list @{typ SMT2.pattern} o single
  13.519 +          |> HOLogic.mk_list @{typ "SMT2.pattern list"} o single
  13.520 +          |> (fn t => @{const SMT2.trigger} $ t $ eq)
  13.521 +      | mk_trigger t = t
  13.522 +
  13.523 +    val (ctxt2, ts3) =
  13.524 +      ts2
  13.525 +      |> eta_expand ctxt1 funcs
  13.526 +      |> rpair ctxt1
  13.527 +      |-> Lambda_Lifting.lift_lambdas NONE is_binder
  13.528 +      |-> (fn (ts', defs) => fn ctxt' =>
  13.529 +          map mk_trigger defs @ ts'
  13.530 +          |> intro_explicit_application ctxt' funcs 
  13.531 +          |> pair ctxt')
  13.532 +
  13.533 +    val ((rewrite_rules, builtin), ts4) = folify ctxt2 ts3
  13.534 +
  13.535 +    val rewrite_rules' = fun_app_eq :: rewrite_rules
  13.536 +  in
  13.537 +    (ts4, tr_context)
  13.538 +    |-> intermediate header dtyps (builtin SMT2_Builtin.dest_builtin) ctxt2
  13.539 +    |>> uncurry (serialize comments)
  13.540 +    ||> replay_data_of ctxt2 rewrite_rules' ithms
  13.541 +  end
  13.542 +
  13.543 +end
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Tools/SMT2/smt2_utils.ML	Thu Mar 13 13:18:13 2014 +0100
    14.3 @@ -0,0 +1,224 @@
    14.4 +(*  Title:      HOL/Tools/SMT2/smt2_utils.ML
    14.5 +    Author:     Sascha Boehme, TU Muenchen
    14.6 +
    14.7 +General utility functions.
    14.8 +*)
    14.9 +
   14.10 +signature SMT2_UTILS =
   14.11 +sig
   14.12 +  (*basic combinators*)
   14.13 +  val repeat: ('a -> 'a option) -> 'a -> 'a
   14.14 +  val repeat_yield: ('a -> 'b -> ('a * 'b) option) -> 'a -> 'b -> 'a * 'b
   14.15 +
   14.16 +  (*class dictionaries*)
   14.17 +  type class = string list
   14.18 +  val basicC: class
   14.19 +  val string_of_class: class -> string
   14.20 +  type 'a dict = (class * 'a) Ord_List.T
   14.21 +  val dict_map_default: class * 'a -> ('a -> 'a) -> 'a dict -> 'a dict
   14.22 +  val dict_update: class * 'a -> 'a dict -> 'a dict
   14.23 +  val dict_merge: ('a * 'a -> 'a) -> 'a dict * 'a dict -> 'a dict
   14.24 +  val dict_lookup: 'a dict -> class -> 'a list
   14.25 +  val dict_get: 'a dict -> class -> 'a option
   14.26 +
   14.27 +  (*types*)
   14.28 +  val dest_funT: int -> typ -> typ list * typ
   14.29 +
   14.30 +  (*terms*)
   14.31 +  val dest_conj: term -> term * term
   14.32 +  val dest_disj: term -> term * term
   14.33 +  val under_quant: (term -> 'a) -> term -> 'a
   14.34 +  val is_number: term -> bool
   14.35 +
   14.36 +  (*patterns and instantiations*)
   14.37 +  val mk_const_pat: theory -> string -> (ctyp -> 'a) -> 'a * cterm
   14.38 +  val destT1: ctyp -> ctyp
   14.39 +  val destT2: ctyp -> ctyp
   14.40 +  val instTs: ctyp list -> ctyp list * cterm -> cterm
   14.41 +  val instT: ctyp -> ctyp * cterm -> cterm
   14.42 +  val instT': cterm -> ctyp * cterm -> cterm
   14.43 +
   14.44 +  (*certified terms*)
   14.45 +  val certify: Proof.context -> term -> cterm
   14.46 +  val typ_of: cterm -> typ
   14.47 +  val dest_cabs: cterm -> Proof.context -> cterm * Proof.context
   14.48 +  val dest_all_cabs: cterm -> Proof.context -> cterm * Proof.context
   14.49 +  val dest_cbinder: cterm -> Proof.context -> cterm * Proof.context
   14.50 +  val dest_all_cbinders: cterm -> Proof.context -> cterm * Proof.context
   14.51 +  val mk_cprop: cterm -> cterm
   14.52 +  val dest_cprop: cterm -> cterm
   14.53 +  val mk_cequals: cterm -> cterm -> cterm
   14.54 +  val term_of: cterm -> term
   14.55 +  val prop_of: thm -> term
   14.56 +
   14.57 +  (*conversions*)
   14.58 +  val if_conv: (term -> bool) -> conv -> conv -> conv
   14.59 +  val if_true_conv: (term -> bool) -> conv -> conv
   14.60 +  val if_exists_conv: (term -> bool) -> conv -> conv
   14.61 +  val binders_conv: (Proof.context -> conv) -> Proof.context -> conv
   14.62 +  val under_quant_conv: (Proof.context * cterm list -> conv) ->
   14.63 +    Proof.context -> conv
   14.64 +  val prop_conv: conv -> conv
   14.65 +end
   14.66 +
   14.67 +structure SMT2_Utils: SMT2_UTILS =
   14.68 +struct
   14.69 +
   14.70 +(* basic combinators *)
   14.71 +
   14.72 +fun repeat f =
   14.73 +  let fun rep x = (case f x of SOME y => rep y | NONE => x)
   14.74 +  in rep end
   14.75 +
   14.76 +fun repeat_yield f =
   14.77 +  let fun rep x y = (case f x y of SOME (x', y') => rep x' y' | NONE => (x, y))
   14.78 +  in rep end
   14.79 +
   14.80 +
   14.81 +(* class dictionaries *)
   14.82 +
   14.83 +type class = string list
   14.84 +
   14.85 +val basicC = []
   14.86 +
   14.87 +fun string_of_class [] = "basic"
   14.88 +  | string_of_class cs = "basic." ^ space_implode "." cs
   14.89 +
   14.90 +type 'a dict = (class * 'a) Ord_List.T
   14.91 +
   14.92 +fun class_ord ((cs1, _), (cs2, _)) =
   14.93 +  rev_order (list_ord fast_string_ord (cs1, cs2))
   14.94 +
   14.95 +fun dict_insert (cs, x) d =
   14.96 +  if AList.defined (op =) d cs then d
   14.97 +  else Ord_List.insert class_ord (cs, x) d
   14.98 +
   14.99 +fun dict_map_default (cs, x) f =
  14.100 +  dict_insert (cs, x) #> AList.map_entry (op =) cs f
  14.101 +
  14.102 +fun dict_update (e as (_, x)) = dict_map_default e (K x)
  14.103 +
  14.104 +fun dict_merge val_merge = sort class_ord o AList.join (op =) (K val_merge)
  14.105 +
  14.106 +fun dict_lookup d cs =
  14.107 +  let fun match (cs', x) = if is_prefix (op =) cs' cs then SOME x else NONE
  14.108 +  in map_filter match d end
  14.109 +
  14.110 +fun dict_get d cs =
  14.111 +  (case AList.lookup (op =) d cs of
  14.112 +    NONE => (case cs of [] => NONE | _ => dict_get d (take (length cs - 1) cs))
  14.113 +  | SOME x => SOME x)
  14.114 +
  14.115 +
  14.116 +(* types *)
  14.117 +
  14.118 +val dest_funT =
  14.119 +  let
  14.120 +    fun dest Ts 0 T = (rev Ts, T)
  14.121 +      | dest Ts i (Type ("fun", [T, U])) = dest (T::Ts) (i-1) U
  14.122 +      | dest _ _ T = raise TYPE ("not a function type", [T], [])
  14.123 +  in dest [] end
  14.124 +
  14.125 +
  14.126 +(* terms *)
  14.127 +
  14.128 +fun dest_conj (@{const HOL.conj} $ t $ u) = (t, u)
  14.129 +  | dest_conj t = raise TERM ("not a conjunction", [t])
  14.130 +
  14.131 +fun dest_disj (@{const HOL.disj} $ t $ u) = (t, u)
  14.132 +  | dest_disj t = raise TERM ("not a disjunction", [t])
  14.133 +
  14.134 +fun under_quant f t =
  14.135 +  (case t of
  14.136 +    Const (@{const_name All}, _) $ Abs (_, _, u) => under_quant f u
  14.137 +  | Const (@{const_name Ex}, _) $ Abs (_, _, u) => under_quant f u
  14.138 +  | _ => f t)
  14.139 +
  14.140 +val is_number =
  14.141 +  let
  14.142 +    fun is_num env (Const (@{const_name Let}, _) $ t $ Abs (_, _, u)) = is_num (t :: env) u
  14.143 +      | is_num env (Bound i) = i < length env andalso is_num env (nth env i)
  14.144 +      | is_num _ t = can HOLogic.dest_number t
  14.145 +  in is_num [] end
  14.146 +
  14.147 +
  14.148 +(* patterns and instantiations *)
  14.149 +
  14.150 +fun mk_const_pat thy name destT =
  14.151 +  let val cpat = Thm.cterm_of thy (Const (name, Sign.the_const_type thy name))
  14.152 +  in (destT (Thm.ctyp_of_term cpat), cpat) end
  14.153 +
  14.154 +val destT1 = hd o Thm.dest_ctyp
  14.155 +val destT2 = hd o tl o Thm.dest_ctyp
  14.156 +
  14.157 +fun instTs cUs (cTs, ct) = Thm.instantiate_cterm (cTs ~~ cUs, []) ct
  14.158 +fun instT cU (cT, ct) = instTs [cU] ([cT], ct)
  14.159 +fun instT' ct = instT (Thm.ctyp_of_term ct)
  14.160 +
  14.161 +
  14.162 +(* certified terms *)
  14.163 +
  14.164 +fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt)
  14.165 +
  14.166 +fun typ_of ct = #T (Thm.rep_cterm ct) 
  14.167 +
  14.168 +fun dest_cabs ct ctxt =
  14.169 +  (case Thm.term_of ct of
  14.170 +    Abs _ =>
  14.171 +      let val (n, ctxt') = yield_singleton Variable.variant_fixes Name.uu ctxt
  14.172 +      in (snd (Thm.dest_abs (SOME n) ct), ctxt') end
  14.173 +  | _ => raise CTERM ("no abstraction", [ct]))
  14.174 +
  14.175 +val dest_all_cabs = repeat_yield (try o dest_cabs) 
  14.176 +
  14.177 +fun dest_cbinder ct ctxt =
  14.178 +  (case Thm.term_of ct of
  14.179 +    Const _ $ Abs _ => dest_cabs (Thm.dest_arg ct) ctxt
  14.180 +  | _ => raise CTERM ("not a binder", [ct]))
  14.181 +
  14.182 +val dest_all_cbinders = repeat_yield (try o dest_cbinder)
  14.183 +
  14.184 +val mk_cprop = Thm.apply (Thm.cterm_of @{theory} @{const Trueprop})
  14.185 +
  14.186 +fun dest_cprop ct =
  14.187 +  (case Thm.term_of ct of
  14.188 +    @{const Trueprop} $ _ => Thm.dest_arg ct
  14.189 +  | _ => raise CTERM ("not a property", [ct]))
  14.190 +
  14.191 +val equals = mk_const_pat @{theory} @{const_name "=="} destT1
  14.192 +fun mk_cequals ct cu = Thm.mk_binop (instT' ct equals) ct cu
  14.193 +
  14.194 +val dest_prop = (fn @{const Trueprop} $ t => t | t => t)
  14.195 +fun term_of ct = dest_prop (Thm.term_of ct)
  14.196 +fun prop_of thm = dest_prop (Thm.prop_of thm)
  14.197 +
  14.198 +
  14.199 +(* conversions *)
  14.200 +
  14.201 +fun if_conv pred cv1 cv2 ct = if pred (Thm.term_of ct) then cv1 ct else cv2 ct
  14.202 +
  14.203 +fun if_true_conv pred cv = if_conv pred cv Conv.all_conv
  14.204 +
  14.205 +fun if_exists_conv pred = if_true_conv (Term.exists_subterm pred)
  14.206 +
  14.207 +fun binders_conv cv ctxt =
  14.208 +  Conv.binder_conv (binders_conv cv o snd) ctxt else_conv cv ctxt
  14.209 +
  14.210 +fun under_quant_conv cv ctxt =
  14.211 +  let
  14.212 +    fun quant_conv inside ctxt cvs ct =
  14.213 +      (case Thm.term_of ct of
  14.214 +        Const (@{const_name All}, _) $ Abs _ =>
  14.215 +          Conv.binder_conv (under_conv cvs) ctxt
  14.216 +      | Const (@{const_name Ex}, _) $ Abs _ =>
  14.217 +          Conv.binder_conv (under_conv cvs) ctxt
  14.218 +      | _ => if inside then cv (ctxt, cvs) else Conv.all_conv) ct
  14.219 +    and under_conv cvs (cv, ctxt) = quant_conv true ctxt (cv :: cvs)
  14.220 +  in quant_conv false ctxt [] end
  14.221 +
  14.222 +fun prop_conv cv ct =
  14.223 +  (case Thm.term_of ct of
  14.224 +    @{const Trueprop} $ _ => Conv.arg_conv cv ct
  14.225 +  | _ => raise CTERM ("not a property", [ct]))
  14.226 +
  14.227 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Tools/SMT2/smtlib2.ML	Thu Mar 13 13:18:13 2014 +0100
    15.3 @@ -0,0 +1,199 @@
    15.4 +(*  Title:      HOL/Tools/SMT2/smtlib2.ML
    15.5 +    Author:     Sascha Boehme, TU Muenchen
    15.6 +
    15.7 +Parsing and generating SMT-LIB 2.
    15.8 +*)
    15.9 +
   15.10 +signature SMTLIB2 =
   15.11 +sig
   15.12 +  exception PARSE of int * string
   15.13 +  datatype tree = 
   15.14 +    Num of int |
   15.15 +    Dec of int * int |
   15.16 +    Str of string |
   15.17 +    Sym of string |
   15.18 +    Key of string |
   15.19 +    S of tree list
   15.20 +  val parse: string list -> tree
   15.21 +  val pretty_tree: tree -> Pretty.T
   15.22 +  val str_of: tree -> string
   15.23 +end
   15.24 +
   15.25 +structure SMTLIB2: SMTLIB2 =
   15.26 +struct
   15.27 +
   15.28 +(* data structures *)
   15.29 +
   15.30 +exception PARSE of int * string
   15.31 +
   15.32 +datatype tree = 
   15.33 +  Num of int |
   15.34 +  Dec of int * int |
   15.35 +  Str of string |
   15.36 +  Sym of string |
   15.37 +  Key of string |
   15.38 +  S of tree list
   15.39 +
   15.40 +datatype unfinished = None | String of string | Symbol of string
   15.41 +
   15.42 +
   15.43 +
   15.44 +(* utilities *)
   15.45 +
   15.46 +fun read_raw pred l cs =
   15.47 +  (case take_prefix pred cs of
   15.48 +    ([], []) => raise PARSE (l, "empty token")
   15.49 +  | ([], c :: _) => raise PARSE (l, "unexpected character " ^ quote c)
   15.50 +  | x => x)
   15.51 +
   15.52 +
   15.53 +
   15.54 +(* numerals and decimals *)
   15.55 +
   15.56 +fun int_of cs = fst (read_int cs)
   15.57 +
   15.58 +fun read_num l cs =
   15.59 +  (case read_raw Symbol.is_ascii_digit l cs of
   15.60 +    (cs1, "." :: cs') =>
   15.61 +      let val (cs2, cs'') = read_raw Symbol.is_ascii_digit l cs'
   15.62 +      in (Dec (int_of cs1, int_of cs2), cs'') end
   15.63 +  | (cs1, cs2) => (Num (int_of cs1), cs2))
   15.64 +
   15.65 +
   15.66 +
   15.67 +(* binary numbers *)
   15.68 +
   15.69 +fun is_bin c = (c = "0" orelse c = "1")
   15.70 +
   15.71 +fun read_bin l cs = read_raw is_bin l cs |>> Num o fst o read_radix_int 2
   15.72 +
   15.73 +
   15.74 +
   15.75 +(* hex numbers *)
   15.76 +
   15.77 +val is_hex = member (op =) (raw_explode "0123456789abcdefABCDEF")
   15.78 +
   15.79 +fun within c1 c2 c = (ord c1 <= ord c andalso ord c <= ord c2)
   15.80 +
   15.81 +fun unhex i [] = i
   15.82 +  | unhex i (c :: cs) =
   15.83 +      if within "0" "9" c then unhex (i * 16 + (ord c - ord "0")) cs
   15.84 +      else if within "a" "f" c then unhex (i * 16 + (ord c - ord "a" + 10)) cs
   15.85 +      else if within "A" "F" c then unhex (i * 16 + (ord c - ord "A" + 10)) cs
   15.86 +      else raise Fail ("bad hex character " ^ quote c)
   15.87 +
   15.88 +fun read_hex l cs = read_raw is_hex l cs |>> Num o unhex 0
   15.89 +
   15.90 +
   15.91 +
   15.92 +(* symbols *)
   15.93 +
   15.94 +val symbol_chars = raw_explode "~!@$%^&*_+=<>.?/-" 
   15.95 +
   15.96 +fun is_sym c =
   15.97 +  Symbol.is_ascii_letter c orelse
   15.98 +  Symbol.is_ascii_digit c orelse
   15.99 +  member (op =) symbol_chars c
  15.100 +
  15.101 +fun read_sym f l cs = read_raw is_sym l cs |>> f o implode
  15.102 +
  15.103 +
  15.104 +
  15.105 +(* quoted tokens *)
  15.106 +
  15.107 +fun read_quoted stop (escape, replacement) cs =
  15.108 +  let
  15.109 +    fun read _ [] = NONE
  15.110 +      | read rs (cs as (c :: cs')) =
  15.111 +          if is_prefix (op =) stop cs then
  15.112 +            SOME (implode (rev rs), drop (length stop) cs)
  15.113 +          else if not (null escape) andalso is_prefix (op =) escape cs then
  15.114 +            read (replacement :: rs) (drop (length escape) cs)
  15.115 +          else read (c :: rs) cs'
  15.116 +  in read [] cs end
  15.117 +
  15.118 +fun read_string cs = read_quoted ["\\", "\""] (["\\", "\\"], "\\") cs
  15.119 +fun read_symbol cs = read_quoted ["|"] ([], "") cs
  15.120 +
  15.121 +
  15.122 +
  15.123 +(* core parser *)
  15.124 +
  15.125 +fun read _ [] rest tss = (rest, tss)
  15.126 +  | read l ("(" :: cs) None tss = read l cs None ([] :: tss)
  15.127 +  | read l (")" :: cs) None (ts1 :: ts2 :: tss) =
  15.128 +      read l cs None ((S (rev ts1) :: ts2) :: tss)
  15.129 +  | read l ("#" :: "x" :: cs) None (ts :: tss) =
  15.130 +      token read_hex l cs ts tss
  15.131 +  | read l ("#" :: cs) None (ts :: tss) =
  15.132 +      token read_bin l cs ts tss
  15.133 +  | read l (":" :: cs) None (ts :: tss) =
  15.134 +      token (read_sym Key) l cs ts tss
  15.135 +  | read l ("\"" :: cs) None (ts :: tss) =
  15.136 +      quoted read_string String Str l "" cs ts tss
  15.137 +  | read l ("|" :: cs) None (ts :: tss) =
  15.138 +      quoted read_symbol Symbol Sym l "" cs ts tss
  15.139 +  | read l ((c as "!") :: cs) None (ts :: tss) =
  15.140 +      token (fn _ => pair (Sym c)) l cs ts tss
  15.141 +  | read l (c :: cs) None (ts :: tss) =
  15.142 +      if Symbol.is_ascii_blank c then read l cs None (ts :: tss)
  15.143 +      else if Symbol.is_digit c then token read_num l (c :: cs) ts tss
  15.144 +      else token (read_sym Sym) l (c :: cs) ts tss
  15.145 +  | read l cs (String s) (ts :: tss) =
  15.146 +      quoted read_string String Str l s cs ts tss
  15.147 +  | read l cs (Symbol s) (ts :: tss) =
  15.148 +      quoted read_symbol Symbol Sym l s cs ts tss
  15.149 +  | read l _ _ [] = raise PARSE (l, "bad parser state")
  15.150 +
  15.151 +and token f l cs ts tss =
  15.152 +  let val (t, cs') = f l cs
  15.153 +  in read l cs' None ((t :: ts) :: tss) end
  15.154 +
  15.155 +and quoted r f g l s cs ts tss =
  15.156 +  (case r cs of
  15.157 +    NONE => (f (s ^ implode cs), ts :: tss)
  15.158 +  | SOME (s', cs') => read l cs' None ((g (s ^ s') :: ts) :: tss))
  15.159 +  
  15.160 +
  15.161 +
  15.162 +(* overall parser *)
  15.163 +
  15.164 +fun read_line l line = read l (raw_explode line)
  15.165 +
  15.166 +fun add_line line (l, (None, tss)) =
  15.167 +      if size line = 0 orelse nth_string line 0 = ";" then (l + 1, (None, tss))
  15.168 +      else (l + 1, read_line l line None tss)
  15.169 +  | add_line line (l, (unfinished, tss)) =
  15.170 +      (l + 1, read_line l line unfinished tss)
  15.171 +
  15.172 +fun finish (_, (None, [[t]])) = t
  15.173 +  | finish (l, _) = raise PARSE (l, "bad nesting")
  15.174 +
  15.175 +fun parse lines = finish (fold add_line lines (1, (None, [[]])))
  15.176 +
  15.177 +
  15.178 +
  15.179 +(* pretty printer *)
  15.180 +
  15.181 +fun pretty_tree (Num i) = Pretty.str (string_of_int i)
  15.182 +  | pretty_tree (Dec (i, j)) =
  15.183 +      Pretty.str (string_of_int i ^ "." ^ string_of_int j)
  15.184 +  | pretty_tree (Str s) =
  15.185 +      raw_explode s
  15.186 +      |> maps (fn "\"" => ["\\", "\""] | "\\" => ["\\", "\\"] | c => [c])
  15.187 +      |> implode
  15.188 +      |> enclose "\"" "\""
  15.189 +      |> Pretty.str
  15.190 +  | pretty_tree (Sym s) =
  15.191 +      if String.isPrefix "(" s (* for bit vector functions *) orelse
  15.192 +         forall is_sym (raw_explode s) then
  15.193 +        Pretty.str s
  15.194 +      else
  15.195 +        Pretty.str ("|" ^ s ^ "|")
  15.196 +  | pretty_tree (Key s) = Pretty.str (":" ^ s)
  15.197 +  | pretty_tree (S trees) =
  15.198 +      Pretty.enclose "(" ")" (Pretty.separate "" (map pretty_tree trees))
  15.199 +
  15.200 +val str_of = Pretty.str_of o pretty_tree
  15.201 +
  15.202 +end
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Tools/SMT2/smtlib2_interface.ML	Thu Mar 13 13:18:13 2014 +0100
    16.3 @@ -0,0 +1,156 @@
    16.4 +(*  Title:      HOL/Tools/SMT2/smtlib2_interface.ML
    16.5 +    Author:     Sascha Boehme, TU Muenchen
    16.6 +    Author:     Jasmin Blanchette, TU Muenchen
    16.7 +
    16.8 +Interface to SMT solvers based on the SMT-LIB 2 format.
    16.9 +*)
   16.10 +
   16.11 +signature SMTLIB2_INTERFACE =
   16.12 +sig
   16.13 +  val smtlib2C: SMT2_Utils.class
   16.14 +  val add_logic: int * (term list -> string option) -> Context.generic ->
   16.15 +    Context.generic
   16.16 +  val translate_config: Proof.context -> SMT2_Translate.config
   16.17 +end
   16.18 +
   16.19 +structure SMTLIB2_Interface: SMTLIB2_INTERFACE =
   16.20 +struct
   16.21 +
   16.22 +val smtlib2C = ["smtlib2"]
   16.23 +
   16.24 +
   16.25 +(* builtins *)
   16.26 +
   16.27 +local
   16.28 +  fun int_num _ i = SOME (string_of_int i)
   16.29 +
   16.30 +  fun is_linear [t] = SMT2_Utils.is_number t
   16.31 +    | is_linear [t, u] = SMT2_Utils.is_number t orelse SMT2_Utils.is_number u
   16.32 +    | is_linear _ = false
   16.33 +
   16.34 +  fun times _ _ ts =
   16.35 +    let val mk = Term.list_comb o pair @{const times (int)}
   16.36 +    in if is_linear ts then SOME ("*", 2, ts, mk) else NONE end
   16.37 +in
   16.38 +
   16.39 +val setup_builtins =
   16.40 +  fold (SMT2_Builtin.add_builtin_typ smtlib2C) [
   16.41 +    (@{typ bool}, K (SOME "Bool"), K (K NONE)),
   16.42 +    (@{typ int}, K (SOME "Int"), int_num)] #>
   16.43 +  fold (SMT2_Builtin.add_builtin_fun' smtlib2C) [
   16.44 +    (@{const True}, "true"),
   16.45 +    (@{const False}, "false"),
   16.46 +    (@{const Not}, "not"),
   16.47 +    (@{const HOL.conj}, "and"),
   16.48 +    (@{const HOL.disj}, "or"),
   16.49 +    (@{const HOL.implies}, "=>"),
   16.50 +    (@{const HOL.eq ('a)}, "="),
   16.51 +    (@{const If ('a)}, "ite"),
   16.52 +    (@{const less (int)}, "<"),
   16.53 +    (@{const less_eq (int)}, "<="),
   16.54 +    (@{const uminus (int)}, "~"),
   16.55 +    (@{const plus (int)}, "+"),
   16.56 +    (@{const minus (int)}, "-")] #>
   16.57 +  SMT2_Builtin.add_builtin_fun smtlib2C
   16.58 +    (Term.dest_Const @{const times (int)}, times)
   16.59 +
   16.60 +end
   16.61 +
   16.62 +
   16.63 +(* serialization *)
   16.64 +
   16.65 +(** header **)
   16.66 +
   16.67 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
   16.68 +
   16.69 +structure Logics = Generic_Data
   16.70 +(
   16.71 +  type T = (int * (term list -> string option)) list
   16.72 +  val empty = []
   16.73 +  val extend = I
   16.74 +  fun merge data = Ord_List.merge fst_int_ord data
   16.75 +)
   16.76 +
   16.77 +fun add_logic pf = Logics.map (Ord_List.insert fst_int_ord pf)
   16.78 +
   16.79 +fun choose_logic ctxt ts =
   16.80 +  let
   16.81 +    fun choose [] = "AUFLIA"
   16.82 +      | choose ((_, f) :: fs) = (case f ts of SOME s => s | NONE => choose fs)
   16.83 +  in "(set-logic " ^ choose (Logics.get (Context.Proof ctxt)) ^ ")\n" end
   16.84 +
   16.85 +
   16.86 +(** serialization **)
   16.87 +
   16.88 +fun var i = "?v" ^ string_of_int i
   16.89 +
   16.90 +fun tree_of_sterm l (SMT2_Translate.SVar i) = SMTLIB2.Sym (var (l - i - 1))
   16.91 +  | tree_of_sterm _ (SMT2_Translate.SApp (n, [])) = SMTLIB2.Sym n
   16.92 +  | tree_of_sterm l (SMT2_Translate.SApp (n, ts)) =
   16.93 +      SMTLIB2.S (SMTLIB2.Sym n :: map (tree_of_sterm l) ts)
   16.94 +  | tree_of_sterm _ (SMT2_Translate.SLet _) =
   16.95 +      raise Fail "SMT-LIB: unsupported let expression"
   16.96 +  | tree_of_sterm l (SMT2_Translate.SQua (q, ss, pats, w, t)) =
   16.97 +      let
   16.98 +        val l' = l + length ss
   16.99 +
  16.100 +        fun quant_name SMT2_Translate.SForall = "forall"
  16.101 +          | quant_name SMT2_Translate.SExists = "exists"
  16.102 +
  16.103 +        fun gen_trees_of_pat keyword ps =
  16.104 +          [SMTLIB2.Key keyword, (case map (tree_of_sterm l') ps of [t] => t | ts => SMTLIB2.S ts)]
  16.105 +        fun trees_of_pat (SMT2_Translate.SPat ps) = gen_trees_of_pat "pattern" ps
  16.106 +          | trees_of_pat (SMT2_Translate.SNoPat ps) = gen_trees_of_pat "no-pattern" ps
  16.107 +        fun trees_of_weight NONE = []
  16.108 +          | trees_of_weight (SOME i) = [SMTLIB2.Key "weight", SMTLIB2.Num i]
  16.109 +        fun tree_of_pats_weight [] NONE t = t
  16.110 +          | tree_of_pats_weight pats w t =
  16.111 +            SMTLIB2.S (SMTLIB2.Sym "!" :: t :: maps trees_of_pat pats @ trees_of_weight w)
  16.112 +
  16.113 +        val vs = map_index (fn (i, ty) =>
  16.114 +          SMTLIB2.S [SMTLIB2.Sym (var (l + i)), SMTLIB2.Sym ty]) ss
  16.115 +
  16.116 +        val body = t
  16.117 +          |> tree_of_sterm l'
  16.118 +          |> tree_of_pats_weight pats w
  16.119 +      in
  16.120 +        SMTLIB2.S [SMTLIB2.Sym (quant_name q), SMTLIB2.S vs, body]
  16.121 +      end
  16.122 +
  16.123 +
  16.124 +fun sctrarg (sel, typ) = "(" ^ sel ^ " " ^ typ ^ ")"
  16.125 +fun sctr (name, args) = enclose "(" ")" (space_implode " " (name :: map sctrarg args))
  16.126 +fun sdatatype (name, ctrs) = enclose "(" ")" (space_implode " " (name :: map sctr ctrs))
  16.127 +
  16.128 +fun string_of_fun (f, (ss, s)) = f ^ " (" ^ space_implode " " ss ^ ") " ^ s
  16.129 +
  16.130 +fun serialize comments {header, sorts, dtyps, funcs} ts =
  16.131 +  Buffer.empty
  16.132 +  |> fold (Buffer.add o enclose "; " "\n") comments
  16.133 +  |> Buffer.add "(set-option :produce-proofs true)\n"
  16.134 +  |> Buffer.add header
  16.135 +  |> fold (Buffer.add o enclose "(declare-sort " " 0)\n")
  16.136 +       (sort fast_string_ord sorts)
  16.137 +  |> (if null dtyps then I
  16.138 +    else Buffer.add (enclose "(declare-datatypes () (" "))\n"
  16.139 +      (space_implode "\n  " (maps (map sdatatype) dtyps))))
  16.140 +  |> fold (Buffer.add o enclose "(declare-fun " ")\n" o string_of_fun)
  16.141 +       (sort (fast_string_ord o pairself fst) funcs)
  16.142 +  |> fold (Buffer.add o enclose "(assert " ")\n" o SMTLIB2.str_of o
  16.143 +       tree_of_sterm 0) ts
  16.144 +  |> Buffer.add "(check-sat)\n"
  16.145 +  |> Buffer.add "(get-proof)\n"
  16.146 +  |> Buffer.content
  16.147 +
  16.148 +(* interface *)
  16.149 +
  16.150 +fun translate_config ctxt = {
  16.151 +  header = choose_logic ctxt,
  16.152 +  has_datatypes = false,
  16.153 +  serialize = serialize}
  16.154 +
  16.155 +val _ = Theory.setup (Context.theory_map
  16.156 +  (setup_builtins #>
  16.157 +   SMT2_Translate.add_config (smtlib2C, translate_config)))
  16.158 +
  16.159 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Tools/SMT2/z3_new_interface.ML	Thu Mar 13 13:18:13 2014 +0100
    17.3 @@ -0,0 +1,220 @@
    17.4 +(*  Title:      HOL/Tools/SMT2/z3_new_interface.ML
    17.5 +    Author:     Sascha Boehme, TU Muenchen
    17.6 +
    17.7 +Interface to Z3 based on a relaxed version of SMT-LIB.
    17.8 +*)
    17.9 +
   17.10 +signature Z3_NEW_INTERFACE =
   17.11 +sig
   17.12 +  val smtlib2_z3C: SMT2_Utils.class
   17.13 +
   17.14 +  datatype sym = Sym of string * sym list
   17.15 +  type mk_builtins = {
   17.16 +    mk_builtin_typ: sym -> typ option,
   17.17 +    mk_builtin_num: theory -> int -> typ -> cterm option,
   17.18 +    mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
   17.19 +  val add_mk_builtins: mk_builtins -> Context.generic -> Context.generic
   17.20 +  val mk_builtin_typ: Proof.context -> sym -> typ option
   17.21 +  val mk_builtin_num: Proof.context -> int -> typ -> cterm option
   17.22 +  val mk_builtin_fun: Proof.context -> sym -> cterm list -> cterm option
   17.23 +
   17.24 +  val is_builtin_theory_term: Proof.context -> term -> bool
   17.25 +end
   17.26 +
   17.27 +structure Z3_New_Interface: Z3_NEW_INTERFACE =
   17.28 +struct
   17.29 +
   17.30 +val smtlib2_z3C = SMTLIB2_Interface.smtlib2C @ ["z3"]
   17.31 +
   17.32 +
   17.33 +
   17.34 +(* interface *)
   17.35 +
   17.36 +local
   17.37 +  fun translate_config ctxt =
   17.38 +    let
   17.39 +      val {serialize, ...} = SMTLIB2_Interface.translate_config ctxt
   17.40 +    in
   17.41 +      {header=K "", serialize=serialize, has_datatypes=true}
   17.42 +    end
   17.43 +
   17.44 +  fun is_div_mod @{const div (int)} = true
   17.45 +    | is_div_mod @{const mod (int)} = true
   17.46 +    | is_div_mod _ = false
   17.47 +
   17.48 +  val div_as_z3div = @{lemma
   17.49 +    "ALL k l. k div l = (
   17.50 +      if k = 0 | l = 0 then 0
   17.51 +      else if (0 < k & 0 < l) | (k < 0 & 0 < l) then z3div k l
   17.52 +      else z3div (-k) (-l))"
   17.53 +    by (simp add: SMT2.z3div_def)}
   17.54 +
   17.55 +  val mod_as_z3mod = @{lemma
   17.56 +    "ALL k l. k mod l = (
   17.57 +      if l = 0 then k
   17.58 +      else if k = 0 then 0
   17.59 +      else if (0 < k & 0 < l) | (k < 0 & 0 < l) then z3mod k l
   17.60 +      else - z3mod (-k) (-l))"
   17.61 +    by (simp add: z3mod_def)}
   17.62 +
   17.63 +  val have_int_div_mod =
   17.64 +    exists (Term.exists_subterm is_div_mod o Thm.prop_of)
   17.65 +
   17.66 +  fun add_div_mod _ (thms, extra_thms) =
   17.67 +    if have_int_div_mod thms orelse have_int_div_mod extra_thms then
   17.68 +      (thms, div_as_z3div :: mod_as_z3mod :: extra_thms)
   17.69 +    else (thms, extra_thms)
   17.70 +
   17.71 +  val setup_builtins =
   17.72 +    SMT2_Builtin.add_builtin_fun' smtlib2_z3C (@{const times (int)}, "*") #>
   17.73 +    SMT2_Builtin.add_builtin_fun' smtlib2_z3C (@{const z3div}, "div") #>
   17.74 +    SMT2_Builtin.add_builtin_fun' smtlib2_z3C (@{const z3mod}, "mod")
   17.75 +in
   17.76 +
   17.77 +val _ = Theory.setup (Context.theory_map (
   17.78 +  setup_builtins #>
   17.79 +  SMT2_Normalize.add_extra_norm (smtlib2_z3C, add_div_mod) #>
   17.80 +  SMT2_Translate.add_config (smtlib2_z3C, translate_config)))
   17.81 +
   17.82 +end
   17.83 +
   17.84 +
   17.85 +
   17.86 +(* constructors *)
   17.87 +
   17.88 +datatype sym = Sym of string * sym list
   17.89 +
   17.90 +
   17.91 +(** additional constructors **)
   17.92 +
   17.93 +type mk_builtins = {
   17.94 +  mk_builtin_typ: sym -> typ option,
   17.95 +  mk_builtin_num: theory -> int -> typ -> cterm option,
   17.96 +  mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
   17.97 +
   17.98 +fun chained _ [] = NONE
   17.99 +  | chained f (b :: bs) = (case f b of SOME y => SOME y | NONE => chained f bs)
  17.100 +
  17.101 +fun chained_mk_builtin_typ bs sym =
  17.102 +  chained (fn {mk_builtin_typ=mk, ...} : mk_builtins => mk sym) bs
  17.103 +
  17.104 +fun chained_mk_builtin_num ctxt bs i T =
  17.105 +  let val thy = Proof_Context.theory_of ctxt
  17.106 +  in chained (fn {mk_builtin_num=mk, ...} : mk_builtins => mk thy i T) bs end
  17.107 +
  17.108 +fun chained_mk_builtin_fun ctxt bs s cts =
  17.109 +  let val thy = Proof_Context.theory_of ctxt
  17.110 +  in chained (fn {mk_builtin_fun=mk, ...} : mk_builtins => mk thy s cts) bs end
  17.111 +
  17.112 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
  17.113 +
  17.114 +structure Mk_Builtins = Generic_Data
  17.115 +(
  17.116 +  type T = (int * mk_builtins) list
  17.117 +  val empty = []
  17.118 +  val extend = I
  17.119 +  fun merge data = Ord_List.merge fst_int_ord data
  17.120 +)
  17.121 +
  17.122 +fun add_mk_builtins mk =
  17.123 +  Mk_Builtins.map (Ord_List.insert fst_int_ord (serial (), mk))
  17.124 +
  17.125 +fun get_mk_builtins ctxt = map snd (Mk_Builtins.get (Context.Proof ctxt))
  17.126 +
  17.127 +
  17.128 +(** basic and additional constructors **)
  17.129 +
  17.130 +fun mk_builtin_typ _ (Sym ("Bool", _)) = SOME @{typ bool}
  17.131 +  | mk_builtin_typ _ (Sym ("Int", _)) = SOME @{typ int}
  17.132 +  | mk_builtin_typ _ (Sym ("bool", _)) = SOME @{typ bool}  (*FIXME: legacy*)
  17.133 +  | mk_builtin_typ _ (Sym ("int", _)) = SOME @{typ int}  (*FIXME: legacy*)
  17.134 +  | mk_builtin_typ ctxt sym = chained_mk_builtin_typ (get_mk_builtins ctxt) sym
  17.135 +
  17.136 +fun mk_builtin_num _ i @{typ int} = SOME (Numeral.mk_cnumber @{ctyp int} i)
  17.137 +  | mk_builtin_num ctxt i T =
  17.138 +      chained_mk_builtin_num ctxt (get_mk_builtins ctxt) i T
  17.139 +
  17.140 +val mk_true = Thm.cterm_of @{theory} (@{const Not} $ @{const False})
  17.141 +val mk_false = Thm.cterm_of @{theory} @{const False}
  17.142 +val mk_not = Thm.apply (Thm.cterm_of @{theory} @{const Not})
  17.143 +val mk_implies = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.implies})
  17.144 +val mk_iff = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.eq (bool)})
  17.145 +val conj = Thm.cterm_of @{theory} @{const HOL.conj}
  17.146 +val disj = Thm.cterm_of @{theory} @{const HOL.disj}
  17.147 +
  17.148 +fun mk_nary _ cu [] = cu
  17.149 +  | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
  17.150 +
  17.151 +val eq = SMT2_Utils.mk_const_pat @{theory} @{const_name HOL.eq} SMT2_Utils.destT1
  17.152 +fun mk_eq ct cu = Thm.mk_binop (SMT2_Utils.instT' ct eq) ct cu
  17.153 +
  17.154 +val if_term =
  17.155 +  SMT2_Utils.mk_const_pat @{theory} @{const_name If}
  17.156 +    (SMT2_Utils.destT1 o SMT2_Utils.destT2)
  17.157 +fun mk_if cc ct cu =
  17.158 +  Thm.mk_binop (Thm.apply (SMT2_Utils.instT' ct if_term) cc) ct cu
  17.159 +
  17.160 +val access =
  17.161 +  SMT2_Utils.mk_const_pat @{theory} @{const_name fun_app} SMT2_Utils.destT1
  17.162 +fun mk_access array = Thm.apply (SMT2_Utils.instT' array access) array
  17.163 +
  17.164 +val update = SMT2_Utils.mk_const_pat @{theory} @{const_name fun_upd}
  17.165 +  (Thm.dest_ctyp o SMT2_Utils.destT1)
  17.166 +fun mk_update array index value =
  17.167 +  let val cTs = Thm.dest_ctyp (Thm.ctyp_of_term array)
  17.168 +  in
  17.169 +    Thm.apply (Thm.mk_binop (SMT2_Utils.instTs cTs update) array index) value
  17.170 +  end
  17.171 +
  17.172 +val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (int)})
  17.173 +val add = Thm.cterm_of @{theory} @{const plus (int)}
  17.174 +val int0 = Numeral.mk_cnumber @{ctyp int} 0
  17.175 +val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (int)})
  17.176 +val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (int)})
  17.177 +val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3div})
  17.178 +val mk_mod = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3mod})
  17.179 +val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (int)})
  17.180 +val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (int)})
  17.181 +
  17.182 +fun mk_builtin_fun ctxt sym cts =
  17.183 +  (case (sym, cts) of
  17.184 +    (Sym ("true", _), []) => SOME mk_true
  17.185 +  | (Sym ("false", _), []) => SOME mk_false
  17.186 +  | (Sym ("not", _), [ct]) => SOME (mk_not ct)
  17.187 +  | (Sym ("and", _), _) => SOME (mk_nary conj mk_true cts)
  17.188 +  | (Sym ("or", _), _) => SOME (mk_nary disj mk_false cts)
  17.189 +  | (Sym ("implies", _), [ct, cu]) => SOME (mk_implies ct cu)
  17.190 +  | (Sym ("iff", _), [ct, cu]) => SOME (mk_iff ct cu)
  17.191 +  | (Sym ("~", _), [ct, cu]) => SOME (mk_iff ct cu)
  17.192 +  | (Sym ("xor", _), [ct, cu]) => SOME (mk_not (mk_iff ct cu))
  17.193 +  | (Sym ("if", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3)
  17.194 +  | (Sym ("ite", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3) (* FIXME: remove *)
  17.195 +  | (Sym ("=", _), [ct, cu]) => SOME (mk_eq ct cu)
  17.196 +  | (Sym ("select", _), [ca, ck]) => SOME (Thm.apply (mk_access ca) ck)
  17.197 +  | (Sym ("store", _), [ca, ck, cv]) => SOME (mk_update ca ck cv)
  17.198 +  | _ =>
  17.199 +    (case (sym, try (#T o Thm.rep_cterm o hd) cts, cts) of
  17.200 +      (Sym ("+", _), SOME @{typ int}, _) => SOME (mk_nary add int0 cts)
  17.201 +    | (Sym ("-", _), SOME @{typ int}, [ct]) => SOME (mk_uminus ct)
  17.202 +    | (Sym ("-", _), SOME @{typ int}, [ct, cu]) => SOME (mk_sub ct cu)
  17.203 +    | (Sym ("*", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mul ct cu)
  17.204 +    | (Sym ("div", _), SOME @{typ int}, [ct, cu]) => SOME (mk_div ct cu)
  17.205 +    | (Sym ("mod", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mod ct cu)
  17.206 +    | (Sym ("<", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt ct cu)
  17.207 +    | (Sym ("<=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le ct cu)
  17.208 +    | (Sym (">", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt cu ct)
  17.209 +    | (Sym (">=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le cu ct)
  17.210 +    | _ => chained_mk_builtin_fun ctxt (get_mk_builtins ctxt) sym cts))
  17.211 +
  17.212 +
  17.213 +
  17.214 +(* abstraction *)
  17.215 +
  17.216 +fun is_builtin_theory_term ctxt t =
  17.217 +  if SMT2_Builtin.is_builtin_num ctxt t then true
  17.218 +  else
  17.219 +    (case Term.strip_comb t of
  17.220 +      (Const c, ts) => SMT2_Builtin.is_builtin_fun ctxt c ts
  17.221 +    | _ => false)
  17.222 +
  17.223 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Tools/SMT2/z3_new_isar.ML	Thu Mar 13 13:18:13 2014 +0100
    18.3 @@ -0,0 +1,109 @@
    18.4 +(*  Title:      HOL/Tools/SMT2/z3_new_isar.ML
    18.5 +    Author:     Jasmin Blanchette, TU Muenchen
    18.6 +
    18.7 +Z3 proofs as generic ATP proofs for Isar proof reconstruction.
    18.8 +*)
    18.9 +
   18.10 +signature Z3_NEW_ISAR =
   18.11 +sig
   18.12 +  type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step
   18.13 +
   18.14 +  val atp_proof_of_z3_proof: theory -> Z3_New_Proof.z3_step list -> (term, string) atp_step list
   18.15 +end;
   18.16 +
   18.17 +structure Z3_New_Isar: Z3_NEW_ISAR =
   18.18 +struct
   18.19 +
   18.20 +open ATP_Util
   18.21 +open ATP_Problem
   18.22 +open ATP_Proof
   18.23 +open ATP_Proof_Reconstruct
   18.24 +
   18.25 +val z3_apply_def_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Apply_Def
   18.26 +val z3_hypothesis_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Hypothesis
   18.27 +val z3_intro_def_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Intro_Def
   18.28 +val z3_lemma_rule = Z3_New_Proof.string_of_rule Z3_New_Proof.Lemma
   18.29 +
   18.30 +fun inline_z3_defs _ [] = []
   18.31 +  | inline_z3_defs defs ((name, role, t, rule, deps) :: lines) =
   18.32 +    if rule = z3_intro_def_rule then
   18.33 +      let val def = t |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> swap in
   18.34 +        inline_z3_defs (insert (op =) def defs)
   18.35 +          (map (replace_dependencies_in_line (name, [])) lines)
   18.36 +      end
   18.37 +    else if rule = z3_apply_def_rule then
   18.38 +      inline_z3_defs defs (map (replace_dependencies_in_line (name, [])) lines)
   18.39 +    else
   18.40 +      (name, role, Term.subst_atomic defs t, rule, deps) :: inline_z3_defs defs lines
   18.41 +
   18.42 +fun add_z3_hypotheses [] = I
   18.43 +  | add_z3_hypotheses hyps =
   18.44 +    HOLogic.dest_Trueprop
   18.45 +    #> curry s_imp (Library.foldr1 s_conj (map HOLogic.dest_Trueprop hyps))
   18.46 +    #> HOLogic.mk_Trueprop
   18.47 +
   18.48 +fun inline_z3_hypotheses _ _ [] = []
   18.49 +  | inline_z3_hypotheses hyp_names hyps ((name, role, t, rule, deps) :: lines) =
   18.50 +    if rule = z3_hypothesis_rule then
   18.51 +      inline_z3_hypotheses (name :: hyp_names) (AList.map_default (op =) (t, []) (cons name) hyps)
   18.52 +        lines
   18.53 +    else
   18.54 +      let val deps' = subtract (op =) hyp_names deps in
   18.55 +        if rule = z3_lemma_rule then
   18.56 +          (name, role, t, rule, deps') :: inline_z3_hypotheses hyp_names hyps lines
   18.57 +        else
   18.58 +          let
   18.59 +            val add_hyps = filter_out (null o inter (op =) deps o snd) hyps
   18.60 +            val t' = add_z3_hypotheses (map fst add_hyps) t
   18.61 +            val deps' = subtract (op =) hyp_names deps
   18.62 +            val hyps' = fold (AList.update (op =) o apsnd (insert (op =) name)) add_hyps hyps
   18.63 +          in
   18.64 +            (name, role, t', rule, deps') :: inline_z3_hypotheses hyp_names hyps' lines
   18.65 +          end
   18.66 +      end
   18.67 +
   18.68 +fun simplify_prop (@{const Not} $ t) = s_not (simplify_prop t)
   18.69 +  | simplify_prop (@{const conj} $ t $ u) = s_conj (simplify_prop t, simplify_prop u)
   18.70 +  | simplify_prop (@{const disj} $ t $ u) = s_disj (simplify_prop t, simplify_prop u)
   18.71 +  | simplify_prop (@{const implies} $ t $ u) = s_imp (simplify_prop t, simplify_prop u)
   18.72 +  | simplify_prop (@{const HOL.eq (bool)} $ t $ u) = s_iff (simplify_prop t, simplify_prop u)
   18.73 +  | simplify_prop (t $ u) = simplify_prop t $ simplify_prop u
   18.74 +  | simplify_prop (Abs (s, T, t)) = Abs (s, T, simplify_prop t)
   18.75 +  | simplify_prop t = t
   18.76 +
   18.77 +fun simplify_line (name, role, t, rule, deps) = (name, role, simplify_prop t, rule, deps)
   18.78 +
   18.79 +fun atp_proof_of_z3_proof thy proof =
   18.80 +  let
   18.81 +    fun step_name_of id = (string_of_int id, [])
   18.82 +
   18.83 +    (* FIXME: find actual conjecture *)
   18.84 +    val id_of_last_asserted =
   18.85 +      proof
   18.86 +      |> rev |> find_first (fn Z3_New_Proof.Z3_Step {rule, ...} => rule = Z3_New_Proof.Asserted)
   18.87 +      |> Option.map (fn Z3_New_Proof.Z3_Step {id, ...} => id)
   18.88 +
   18.89 +    fun step_of (Z3_New_Proof.Z3_Step {id, rule, prems, concl, ...}) =
   18.90 +      let
   18.91 +        val role =
   18.92 +          (case rule of
   18.93 +            Z3_New_Proof.Asserted =>
   18.94 +              if id_of_last_asserted = SOME id then Negated_Conjecture else Hypothesis
   18.95 +          | Z3_New_Proof.Rewrite => Lemma
   18.96 +          | Z3_New_Proof.Rewrite_Star => Lemma
   18.97 +          | Z3_New_Proof.Skolemize => Lemma
   18.98 +          | Z3_New_Proof.Th_Lemma _ => Lemma
   18.99 +          | _ => Plain)
  18.100 +      in
  18.101 +        (step_name_of id, role, HOLogic.mk_Trueprop (Object_Logic.atomize_term thy concl),
  18.102 +         Z3_New_Proof.string_of_rule rule, map step_name_of prems)
  18.103 +      end
  18.104 +  in
  18.105 +    proof
  18.106 +    |> map step_of
  18.107 +    |> inline_z3_defs []
  18.108 +    |> inline_z3_hypotheses [] []
  18.109 +    |> map simplify_line
  18.110 +  end
  18.111 +
  18.112 +end;
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof.ML	Thu Mar 13 13:18:13 2014 +0100
    19.3 @@ -0,0 +1,563 @@
    19.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof.ML
    19.5 +    Author:     Sascha Boehme, TU Muenchen
    19.6 +
    19.7 +Z3 proofs: parsing and abstract syntax tree.
    19.8 +*)
    19.9 +
   19.10 +signature Z3_NEW_PROOF =
   19.11 +sig
   19.12 +  (*proof rules*)
   19.13 +  datatype z3_rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity |
   19.14 +    Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro |
   19.15 +    Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star |
   19.16 +    Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars |
   19.17 +    Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution |
   19.18 +    Iff_True | Iff_False | Commutativity | Def_Axiom | Intro_Def | Apply_Def |
   19.19 +    Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize |
   19.20 +    Modus_Ponens_Oeq | Th_Lemma of string
   19.21 +  val string_of_rule: z3_rule -> string
   19.22 +
   19.23 +  (*proofs*)
   19.24 +  datatype z3_step = Z3_Step of {
   19.25 +    id: int,
   19.26 +    rule: z3_rule,
   19.27 +    prems: int list,
   19.28 +    concl: term,
   19.29 +    fixes: string list,
   19.30 +    is_fix_step: bool}
   19.31 +
   19.32 +  (*type and term parsers*)
   19.33 +  type type_parser = SMTLIB2.tree * typ list -> typ option
   19.34 +  type term_parser = SMTLIB2.tree * term list -> term option
   19.35 +  val add_type_parser: type_parser -> Context.generic -> Context.generic
   19.36 +  val add_term_parser: term_parser -> Context.generic -> Context.generic
   19.37 +
   19.38 +  (*proof parser*)
   19.39 +  val parse: typ Symtab.table -> term Symtab.table -> string list ->
   19.40 +    Proof.context -> z3_step list * Proof.context
   19.41 +end
   19.42 +
   19.43 +structure Z3_New_Proof: Z3_NEW_PROOF =
   19.44 +struct
   19.45 +
   19.46 +(* proof rules *)
   19.47 +
   19.48 +datatype z3_rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity |
   19.49 +  Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro |
   19.50 +  Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star |
   19.51 +  Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | Dest_Eq_Res |
   19.52 +  Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False |
   19.53 +  Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos |
   19.54 +  Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize | Modus_Ponens_Oeq |
   19.55 +  Th_Lemma of string
   19.56 +  (* TODO: some proof rules come with further information
   19.57 +     that is currently dropped by the parser *)
   19.58 +
   19.59 +val rule_names = Symtab.make [
   19.60 +  ("true-axiom", True_Axiom),
   19.61 +  ("asserted", Asserted),
   19.62 +  ("goal", Goal),
   19.63 +  ("mp", Modus_Ponens),
   19.64 +  ("refl", Reflexivity),
   19.65 +  ("symm", Symmetry),
   19.66 +  ("trans", Transitivity),
   19.67 +  ("trans*", Transitivity_Star),
   19.68 +  ("monotonicity", Monotonicity),
   19.69 +  ("quant-intro", Quant_Intro),
   19.70 +  ("distributivity", Distributivity),
   19.71 +  ("and-elim", And_Elim),
   19.72 +  ("not-or-elim", Not_Or_Elim),
   19.73 +  ("rewrite", Rewrite),
   19.74 +  ("rewrite*", Rewrite_Star),
   19.75 +  ("pull-quant", Pull_Quant),
   19.76 +  ("pull-quant*", Pull_Quant_Star),
   19.77 +  ("push-quant", Push_Quant),
   19.78 +  ("elim-unused", Elim_Unused_Vars),
   19.79 +  ("der", Dest_Eq_Res),
   19.80 +  ("quant-inst", Quant_Inst),
   19.81 +  ("hypothesis", Hypothesis),
   19.82 +  ("lemma", Lemma),
   19.83 +  ("unit-resolution", Unit_Resolution),
   19.84 +  ("iff-true", Iff_True),
   19.85 +  ("iff-false", Iff_False),
   19.86 +  ("commutativity", Commutativity),
   19.87 +  ("def-axiom", Def_Axiom),
   19.88 +  ("intro-def", Intro_Def),
   19.89 +  ("apply-def", Apply_Def),
   19.90 +  ("iff~", Iff_Oeq),
   19.91 +  ("nnf-pos", Nnf_Pos),
   19.92 +  ("nnf-neg", Nnf_Neg),
   19.93 +  ("nnf*", Nnf_Star),
   19.94 +  ("cnf*", Cnf_Star),
   19.95 +  ("sk", Skolemize),
   19.96 +  ("mp~", Modus_Ponens_Oeq)]
   19.97 +
   19.98 +fun rule_of_string name =
   19.99 +  (case Symtab.lookup rule_names name of
  19.100 +    SOME rule => rule
  19.101 +  | NONE => error ("unknown Z3 proof rule " ^ quote name))
  19.102 +
  19.103 +fun string_of_rule (Th_Lemma kind) = "th-lemma " ^ kind
  19.104 +  | string_of_rule r =
  19.105 +      let fun eq_rule (s, r') = if r = r' then SOME s else NONE 
  19.106 +      in the (Symtab.get_first eq_rule rule_names) end
  19.107 +
  19.108 +
  19.109 +
  19.110 +(* proofs *)
  19.111 +
  19.112 +datatype z3_node = Z3_Node of {
  19.113 +  id: int,
  19.114 +  rule: z3_rule,
  19.115 +  prems: z3_node list,
  19.116 +  concl: term,
  19.117 +  bounds: string list}
  19.118 +
  19.119 +fun mk_node id rule prems concl bounds =
  19.120 +  Z3_Node {id=id, rule=rule, prems=prems, concl=concl, bounds=bounds}
  19.121 +
  19.122 +datatype z3_step = Z3_Step of {
  19.123 +  id: int,
  19.124 +  rule: z3_rule,
  19.125 +  prems: int list,
  19.126 +  concl: term,
  19.127 +  fixes: string list,
  19.128 +  is_fix_step: bool}
  19.129 +
  19.130 +fun mk_step id rule prems concl fixes is_fix_step =
  19.131 +  Z3_Step {id=id, rule=rule, prems=prems, concl=concl, fixes=fixes,
  19.132 +    is_fix_step=is_fix_step}
  19.133 +
  19.134 +
  19.135 +
  19.136 +(* core type and term parser *)
  19.137 +
  19.138 +fun core_type_parser (SMTLIB2.Sym "Bool", []) = SOME @{typ HOL.bool}
  19.139 +  | core_type_parser (SMTLIB2.Sym "Int", []) = SOME @{typ Int.int}
  19.140 +  | core_type_parser _ = NONE
  19.141 +
  19.142 +fun mk_unary n t =
  19.143 +  let val T = fastype_of t
  19.144 +  in Const (n, T --> T) $ t end
  19.145 +
  19.146 +fun mk_binary' n T U t1 t2 = Const (n, [T, T] ---> U) $ t1 $ t2
  19.147 +
  19.148 +fun mk_binary n t1 t2 =
  19.149 +  let val T = fastype_of t1
  19.150 +  in mk_binary' n T T t1 t2 end
  19.151 +
  19.152 +fun mk_rassoc f t ts =
  19.153 +  let val us = rev (t :: ts)
  19.154 +  in fold f (tl us) (hd us) end
  19.155 +
  19.156 +fun mk_lassoc f t ts = fold (fn u1 => fn u2 => f u2 u1) ts t
  19.157 +
  19.158 +fun mk_lassoc' n = mk_lassoc (mk_binary n)
  19.159 +
  19.160 +fun mk_binary_pred n S t1 t2 =
  19.161 +  let
  19.162 +    val T1 = fastype_of t1
  19.163 +    val T2 = fastype_of t2
  19.164 +    val T =
  19.165 +      if T1 <> Term.dummyT then T1
  19.166 +      else if T2 <> Term.dummyT then T2
  19.167 +      else TVar (("?a", serial ()), S)
  19.168 +  in mk_binary' n T @{typ HOL.bool} t1 t2 end
  19.169 +
  19.170 +fun mk_less t1 t2 = mk_binary_pred @{const_name ord_class.less} @{sort linorder} t1 t2
  19.171 +fun mk_less_eq t1 t2 = mk_binary_pred @{const_name ord_class.less_eq} @{sort linorder} t1 t2
  19.172 +
  19.173 +fun core_term_parser (SMTLIB2.Sym "true", _) = SOME @{const HOL.True}
  19.174 +  | core_term_parser (SMTLIB2.Sym "false", _) = SOME @{const HOL.False}
  19.175 +  | core_term_parser (SMTLIB2.Sym "not", [t]) = SOME (HOLogic.mk_not t)
  19.176 +  | core_term_parser (SMTLIB2.Sym "and", t :: ts) = SOME (mk_rassoc (curry HOLogic.mk_conj) t ts)
  19.177 +  | core_term_parser (SMTLIB2.Sym "or", t :: ts) = SOME (mk_rassoc (curry HOLogic.mk_disj) t ts)
  19.178 +  | core_term_parser (SMTLIB2.Sym "=>", [t1, t2]) = SOME (HOLogic.mk_imp (t1, t2))
  19.179 +  | core_term_parser (SMTLIB2.Sym "implies", [t1, t2]) = SOME (HOLogic.mk_imp (t1, t2))
  19.180 +  | core_term_parser (SMTLIB2.Sym "=", [t1, t2]) = SOME (HOLogic.mk_eq (t1, t2))
  19.181 +  | core_term_parser (SMTLIB2.Sym "~", [t1, t2]) = SOME (HOLogic.mk_eq (t1, t2))
  19.182 +  | core_term_parser (SMTLIB2.Sym "ite", [t1, t2, t3]) =
  19.183 +      let
  19.184 +        val T = fastype_of t2
  19.185 +        val c = Const (@{const_name HOL.If}, [@{typ HOL.bool}, T, T] ---> T)
  19.186 +      in SOME (c $ t1 $ t2 $ t3) end
  19.187 +  | core_term_parser (SMTLIB2.Num i, []) = SOME (HOLogic.mk_number @{typ Int.int} i)
  19.188 +  | core_term_parser (SMTLIB2.Sym "-", [t]) = SOME (mk_unary @{const_name uminus_class.uminus} t)
  19.189 +  | core_term_parser (SMTLIB2.Sym "~", [t]) = SOME (mk_unary @{const_name uminus_class.uminus} t)
  19.190 +  | core_term_parser (SMTLIB2.Sym "+", t :: ts) =
  19.191 +      SOME (mk_lassoc' @{const_name plus_class.plus} t ts)
  19.192 +  | core_term_parser (SMTLIB2.Sym "-", t :: ts) =
  19.193 +      SOME (mk_lassoc' @{const_name minus_class.minus} t ts)
  19.194 +  | core_term_parser (SMTLIB2.Sym "*", t :: ts) =
  19.195 +      SOME (mk_lassoc' @{const_name times_class.times} t ts)
  19.196 +  | core_term_parser (SMTLIB2.Sym "div", [t1, t2]) = SOME (mk_binary @{const_name SMT2.z3div} t1 t2)
  19.197 +  | core_term_parser (SMTLIB2.Sym "mod", [t1, t2]) = SOME (mk_binary @{const_name SMT2.z3mod} t1 t2)
  19.198 +  | core_term_parser (SMTLIB2.Sym "<", [t1, t2]) = SOME (mk_less t1 t2)
  19.199 +  | core_term_parser (SMTLIB2.Sym ">", [t1, t2]) = SOME (mk_less t2 t1)
  19.200 +  | core_term_parser (SMTLIB2.Sym "<=", [t1, t2]) = SOME (mk_less_eq t1 t2)
  19.201 +  | core_term_parser (SMTLIB2.Sym ">=", [t1, t2]) = SOME (mk_less_eq t2 t1)
  19.202 +  | core_term_parser _ = NONE
  19.203 +
  19.204 +
  19.205 +
  19.206 +(* type and term parsers *)
  19.207 +
  19.208 +type type_parser = SMTLIB2.tree * typ list -> typ option
  19.209 +
  19.210 +type term_parser = SMTLIB2.tree * term list -> term option
  19.211 +
  19.212 +fun id_ord ((id1, _), (id2, _)) = int_ord (id1, id2)
  19.213 +
  19.214 +structure Parsers = Generic_Data
  19.215 +(
  19.216 +  type T = (int * type_parser) list * (int * term_parser) list
  19.217 +  val empty = ([(serial (), core_type_parser)], [(serial (), core_term_parser)])
  19.218 +  val extend = I
  19.219 +  fun merge ((tys1, ts1), (tys2, ts2)) =
  19.220 +    (Ord_List.merge id_ord (tys1, tys2), Ord_List.merge id_ord (ts1, ts2))
  19.221 +)
  19.222 +
  19.223 +fun add_type_parser type_parser =
  19.224 +  Parsers.map (apfst (Ord_List.insert id_ord (serial (), type_parser)))
  19.225 +
  19.226 +fun add_term_parser term_parser =
  19.227 +  Parsers.map (apsnd (Ord_List.insert id_ord (serial (), term_parser)))
  19.228 +
  19.229 +fun get_type_parsers ctxt = map snd (fst (Parsers.get (Context.Proof ctxt)))
  19.230 +fun get_term_parsers ctxt = map snd (snd (Parsers.get (Context.Proof ctxt)))
  19.231 +
  19.232 +fun apply_parsers parsers x =
  19.233 +  let
  19.234 +    fun apply [] = NONE
  19.235 +      | apply (parser :: parsers) =
  19.236 +          (case parser x of
  19.237 +            SOME y => SOME y
  19.238 +          | NONE => apply parsers)
  19.239 +  in apply parsers end
  19.240 +
  19.241 +
  19.242 +
  19.243 +(* proof parser context *)
  19.244 +
  19.245 +datatype shared = Tree of SMTLIB2.tree | Term of term | Proof of z3_node | None
  19.246 +
  19.247 +type 'a context = {
  19.248 +  ctxt: Proof.context,
  19.249 +  id: int,
  19.250 +  syms: shared Symtab.table,
  19.251 +  typs: typ Symtab.table,
  19.252 +  funs: term Symtab.table,
  19.253 +  extra: 'a}
  19.254 +
  19.255 +fun mk_context ctxt id syms typs funs extra: 'a context =
  19.256 +  {ctxt=ctxt, id=id, syms=syms, typs=typs, funs=funs, extra=extra}
  19.257 +
  19.258 +fun empty_context ctxt typs funs = mk_context ctxt 1 Symtab.empty typs funs []
  19.259 +
  19.260 +fun ctxt_of ({ctxt, ...}: 'a context) = ctxt
  19.261 +
  19.262 +fun next_id ({ctxt, id, syms, typs, funs, extra}: 'a context) =
  19.263 +  (id, mk_context ctxt (id + 1) syms typs funs extra)
  19.264 +
  19.265 +fun lookup_binding ({syms, ...}: 'a context) =
  19.266 +  the_default None o Symtab.lookup syms
  19.267 +
  19.268 +fun map_syms f ({ctxt, id, syms, typs, funs, extra}: 'a context) =
  19.269 +  mk_context ctxt id (f syms) typs funs extra
  19.270 +
  19.271 +fun update_binding b = map_syms (Symtab.update b)
  19.272 +
  19.273 +fun with_bindings bs f cx =
  19.274 +  let val bs' = map (lookup_binding cx o fst) bs
  19.275 +  in
  19.276 +    cx
  19.277 +    |> fold update_binding bs
  19.278 +    |> f
  19.279 +    ||> fold2 (fn (name, _) => update_binding o pair name) bs bs'
  19.280 +  end
  19.281 +
  19.282 +fun lookup_typ ({typs, ...}: 'a context) = Symtab.lookup typs
  19.283 +fun lookup_fun ({funs, ...}: 'a context) = Symtab.lookup funs
  19.284 +
  19.285 +fun fresh_fun add name n T ({ctxt, id, syms, typs, funs, extra}: 'a context) =
  19.286 +  let
  19.287 +    val (n', ctxt') = yield_singleton Variable.variant_fixes n ctxt
  19.288 +    val t = Free (n', T)
  19.289 +    val funs' = Symtab.update (name, t) funs
  19.290 +  in (t, mk_context ctxt' id syms typs funs' (add (n', T) extra)) end
  19.291 +
  19.292 +fun declare_fun name n T = snd o fresh_fun cons name n T
  19.293 +fun declare_free name n T = fresh_fun (cons o pair name) name n T
  19.294 +
  19.295 +fun with_fresh_names f ({ctxt, id, syms, typs, funs, extra}: 'a context) =
  19.296 +  let
  19.297 +    fun bind (_, v as (_, T)) t = Logic.all_const T $ Term.absfree v t
  19.298 +
  19.299 +    val needs_inferT = equal Term.dummyT orf Term.is_TVar
  19.300 +    val needs_infer = Term.exists_type (Term.exists_subtype needs_inferT)
  19.301 +    fun infer_types ctxt =
  19.302 +      singleton (Type_Infer_Context.infer_types ctxt) #>
  19.303 +      singleton (Proof_Context.standard_term_check_finish ctxt)
  19.304 +    fun infer ctxt t = if needs_infer t then infer_types ctxt t else t
  19.305 +
  19.306 +    type bindings = (string * (string * typ)) list
  19.307 +    val (t, {ctxt=ctxt', extra=names, ...}: bindings context) =
  19.308 +      f (mk_context ctxt id syms typs funs [])
  19.309 +    val t' = infer ctxt' (fold_rev bind names (HOLogic.mk_Trueprop t))
  19.310 +   
  19.311 +  in ((t', map fst names), mk_context ctxt id syms typs funs extra) end
  19.312 +
  19.313 +
  19.314 +
  19.315 +(* proof parser *)
  19.316 +
  19.317 +exception Z3_PARSE of string * SMTLIB2.tree
  19.318 +
  19.319 +val desymbolize = Name.desymbolize false o perhaps (try (unprefix "?"))
  19.320 +
  19.321 +fun parse_type cx ty Ts =
  19.322 +  (case apply_parsers (get_type_parsers (ctxt_of cx)) (ty, Ts) of
  19.323 +    SOME T => T
  19.324 +  | NONE =>
  19.325 +      (case ty of
  19.326 +        SMTLIB2.Sym name =>
  19.327 +          (case lookup_typ cx name of
  19.328 +            SOME T => T
  19.329 +          | NONE => raise Z3_PARSE ("unknown Z3 type", ty))
  19.330 +      | _ => raise Z3_PARSE ("bad Z3 type format", ty)))
  19.331 +
  19.332 +fun parse_term t ts cx =
  19.333 +  (case apply_parsers (get_term_parsers (ctxt_of cx)) (t, ts) of
  19.334 +    SOME u => (u, cx)
  19.335 +  | NONE =>
  19.336 +      (case t of
  19.337 +        SMTLIB2.Sym name =>
  19.338 +          (case lookup_fun cx name of
  19.339 +            SOME u => (Term.list_comb (u, ts), cx)
  19.340 +          | NONE =>
  19.341 +              if null ts then declare_free name (desymbolize name) Term.dummyT cx
  19.342 +              else raise Z3_PARSE ("bad Z3 term", t))
  19.343 +      | _ => raise Z3_PARSE ("bad Z3 term format", t)))
  19.344 +
  19.345 +fun type_of cx ty =
  19.346 +  (case try (parse_type cx ty) [] of
  19.347 +    SOME T => T
  19.348 +  | NONE =>
  19.349 +      (case ty of
  19.350 +        SMTLIB2.S (ty' :: tys) => parse_type cx ty' (map (type_of cx) tys)
  19.351 +      | _ => raise Z3_PARSE ("bad Z3 type", ty)))
  19.352 +
  19.353 +fun dest_var cx (SMTLIB2.S [SMTLIB2.Sym name, ty]) = (name, (desymbolize name, type_of cx ty))
  19.354 +  | dest_var _ v = raise Z3_PARSE ("bad Z3 quantifier variable format", v)
  19.355 +
  19.356 +fun dest_body (SMTLIB2.S (SMTLIB2.Sym "!" :: body :: _)) = dest_body body
  19.357 +  | dest_body body = body
  19.358 +
  19.359 +fun dest_binding (SMTLIB2.S [SMTLIB2.Sym name, t]) = (name, Tree t)
  19.360 +  | dest_binding b = raise Z3_PARSE ("bad Z3 let binding format", b)
  19.361 +
  19.362 +fun term_of t cx =
  19.363 +  (case t of
  19.364 +    SMTLIB2.S [SMTLIB2.Sym "forall", SMTLIB2.S vars, body] =>
  19.365 +      quant HOLogic.mk_all vars body cx
  19.366 +  | SMTLIB2.S [SMTLIB2.Sym "exists", SMTLIB2.S vars, body] =>
  19.367 +      quant HOLogic.mk_exists vars body cx
  19.368 +  | SMTLIB2.S [SMTLIB2.Sym "let", SMTLIB2.S bindings, body] =>
  19.369 +      with_bindings (map dest_binding bindings) (term_of body) cx
  19.370 +  | SMTLIB2.S (SMTLIB2.Sym "!" :: t :: _) => term_of t cx
  19.371 +  | SMTLIB2.S (f :: args) =>
  19.372 +      cx
  19.373 +      |> fold_map term_of args
  19.374 +      |-> parse_term f
  19.375 +  | SMTLIB2.Sym name =>
  19.376 +      (case lookup_binding cx name of
  19.377 +        Tree u =>
  19.378 +          cx
  19.379 +          |> term_of u
  19.380 +          |-> (fn u' => pair u' o update_binding (name, Term u'))
  19.381 +      | Term u => (u, cx)
  19.382 +      | None => parse_term t [] cx
  19.383 +      | _ => raise Z3_PARSE ("bad Z3 term format", t))
  19.384 +  | _ => parse_term t [] cx)
  19.385 +
  19.386 +and quant q vars body cx =
  19.387 +  let val vs = map (dest_var cx) vars
  19.388 +  in
  19.389 +    cx
  19.390 +    |> with_bindings (map (apsnd (Term o Free)) vs) (term_of (dest_body body))
  19.391 +    |>> fold_rev (fn (_, (n, T)) => fn t => q (n, T, t)) vs
  19.392 +  end
  19.393 +
  19.394 +fun rule_of (SMTLIB2.Sym name) = rule_of_string name
  19.395 +  | rule_of (SMTLIB2.S (SMTLIB2.Sym "_" :: SMTLIB2.Sym name :: args)) =
  19.396 +      (case (name, args) of
  19.397 +        ("th-lemma", SMTLIB2.Sym kind :: _) => Th_Lemma kind
  19.398 +      | _ => rule_of_string name)
  19.399 +  | rule_of r = raise Z3_PARSE ("bad Z3 proof rule format", r)
  19.400 +
  19.401 +fun node_of p cx =
  19.402 +  (case p of
  19.403 +    SMTLIB2.Sym name =>
  19.404 +      (case lookup_binding cx name of
  19.405 +        Proof node => (node, cx)
  19.406 +      | Tree p' =>
  19.407 +          cx
  19.408 +          |> node_of p'
  19.409 +          |-> (fn node => pair node o update_binding (name, Proof node))
  19.410 +      | _ => raise Z3_PARSE ("bad Z3 proof format", p))
  19.411 +  | SMTLIB2.S [SMTLIB2.Sym "let", SMTLIB2.S bindings, p] =>
  19.412 +      with_bindings (map dest_binding bindings) (node_of p) cx
  19.413 +  | SMTLIB2.S (name :: parts) =>
  19.414 +      let
  19.415 +        val (ps, p) = split_last parts
  19.416 +        val r = rule_of name
  19.417 +      in
  19.418 +        cx
  19.419 +        |> fold_map node_of ps
  19.420 +        ||>> with_fresh_names (term_of p)
  19.421 +        ||>> next_id
  19.422 +        |>> (fn ((prems, (t, ns)), id) => mk_node id r prems t ns)
  19.423 +      end
  19.424 +  | _ => raise Z3_PARSE ("bad Z3 proof format", p))
  19.425 +
  19.426 +fun dest_name (SMTLIB2.Sym name) = name
  19.427 +  | dest_name t = raise Z3_PARSE ("bad name", t)
  19.428 +
  19.429 +fun dest_seq (SMTLIB2.S ts) = ts
  19.430 +  | dest_seq t = raise Z3_PARSE ("bad Z3 proof format", t)
  19.431 +
  19.432 +fun parse' (SMTLIB2.S (SMTLIB2.Sym "set-logic" :: _) :: ts) cx = parse' ts cx
  19.433 +  | parse' (SMTLIB2.S [SMTLIB2.Sym "declare-fun", n, tys, ty] :: ts) cx =
  19.434 +      let
  19.435 +        val name = dest_name n
  19.436 +        val Ts = map (type_of cx) (dest_seq tys)
  19.437 +        val T = type_of cx ty
  19.438 +      in parse' ts (declare_fun name (desymbolize name) (Ts ---> T) cx) end
  19.439 +  | parse' (SMTLIB2.S [SMTLIB2.Sym "proof", p] :: _) cx = node_of p cx
  19.440 +  | parse' ts _ = raise Z3_PARSE ("bad Z3 proof declarations", SMTLIB2.S ts)
  19.441 +
  19.442 +fun parse_proof typs funs lines ctxt =
  19.443 +  let
  19.444 +    val ts = dest_seq (SMTLIB2.parse lines)
  19.445 +    val (node, cx) = parse' ts (empty_context ctxt typs funs)
  19.446 +  in (node, ctxt_of cx) end
  19.447 +  handle SMTLIB2.PARSE (l, msg) =>
  19.448 +           error ("parsing error at line " ^ string_of_int l ^ ": " ^ msg)
  19.449 +       | Z3_PARSE (msg, t) =>
  19.450 +           error (msg ^ ": " ^ SMTLIB2.str_of t)
  19.451 +
  19.452 +
  19.453 +
  19.454 +(* handling of bound variables *)
  19.455 +
  19.456 +fun subst_of tyenv =
  19.457 +  let fun add (ix, (S, T)) = cons (TVar (ix, S), T)
  19.458 +  in Vartab.fold add tyenv [] end
  19.459 +
  19.460 +fun substTs_same subst = 
  19.461 +  let val applyT = Same.function (AList.lookup (op =) subst)
  19.462 +  in Term_Subst.map_atypsT_same applyT end
  19.463 +
  19.464 +fun subst_types ctxt env bounds t =
  19.465 +  let
  19.466 +    val match = Sign.typ_match (Proof_Context.theory_of ctxt)
  19.467 +
  19.468 +    val t' = singleton (Variable.polymorphic ctxt) t
  19.469 +    val patTs = map snd (Term.strip_qnt_vars @{const_name all} t')
  19.470 +    val objTs = map (the o Symtab.lookup env) bounds
  19.471 +    val subst = subst_of (fold match (patTs ~~ objTs) Vartab.empty)
  19.472 +  in Same.commit (Term_Subst.map_types_same (substTs_same subst)) t' end
  19.473 +
  19.474 +fun eq_quant (@{const_name HOL.All}, _) (@{const_name HOL.All}, _) = true
  19.475 +  | eq_quant (@{const_name HOL.Ex}, _) (@{const_name HOL.Ex}, _) = true
  19.476 +  | eq_quant _ _ = false
  19.477 +
  19.478 +fun opp_quant (@{const_name HOL.All}, _) (@{const_name HOL.Ex}, _) = true
  19.479 +  | opp_quant (@{const_name HOL.Ex}, _) (@{const_name HOL.All}, _) = true
  19.480 +  | opp_quant _ _ = false
  19.481 +
  19.482 +fun with_quant pred i (Const q1 $ Abs (_, T1, t1), Const q2 $ Abs (_, T2, t2)) =
  19.483 +      if pred q1 q2 andalso T1 = T2 then
  19.484 +        let val t = Var (("", i), T1)
  19.485 +        in SOME (pairself Term.subst_bound ((t, t1), (t, t2))) end
  19.486 +      else NONE
  19.487 +  | with_quant _ _ _ = NONE
  19.488 +
  19.489 +fun dest_quant_pair i (@{term HOL.Not} $ t1, t2) =
  19.490 +      Option.map (apfst HOLogic.mk_not) (with_quant opp_quant i (t1, t2))
  19.491 +  | dest_quant_pair i (t1, t2) = with_quant eq_quant i (t1, t2)
  19.492 +
  19.493 +fun dest_quant i t =
  19.494 +  (case dest_quant_pair i (HOLogic.dest_eq (HOLogic.dest_Trueprop t)) of
  19.495 +    SOME (t1, t2) => HOLogic.mk_Trueprop (HOLogic.mk_eq (t1, t2))
  19.496 +  | NONE => raise TERM ("lift_quant", [t]))
  19.497 +
  19.498 +fun match_types ctxt pat obj =
  19.499 +  (Vartab.empty, Vartab.empty)
  19.500 +  |> Pattern.first_order_match (Proof_Context.theory_of ctxt) (pat, obj)
  19.501 +
  19.502 +fun strip_match ctxt pat i obj =
  19.503 +  (case try (match_types ctxt pat) obj of
  19.504 +    SOME (tyenv, _) => subst_of tyenv
  19.505 +  | NONE => strip_match ctxt pat (i + 1) (dest_quant i obj))
  19.506 +
  19.507 +fun dest_all i (Const (@{const_name all}, _) $ (a as Abs (_, T, _))) =
  19.508 +      dest_all (i + 1) (Term.betapply (a, Var (("", i), T)))
  19.509 +  | dest_all i t = (i, t)
  19.510 +
  19.511 +fun dest_alls t = dest_all (Term.maxidx_of_term t + 1) t
  19.512 +
  19.513 +fun match_rule ctxt env (Z3_Node {bounds=bs', concl=t', ...}) bs t =
  19.514 +  let
  19.515 +    val t'' = singleton (Variable.polymorphic ctxt) t'
  19.516 +    val (i, obj) = dest_alls (subst_types ctxt env bs t)
  19.517 +  in
  19.518 +    (case try (strip_match ctxt (snd (dest_alls t'')) i) obj of
  19.519 +      NONE => NONE
  19.520 +    | SOME subst =>
  19.521 +        let
  19.522 +          val applyT = Same.commit (substTs_same subst)
  19.523 +          val patTs = map snd (Term.strip_qnt_vars @{const_name all} t'')
  19.524 +        in SOME (Symtab.make (bs' ~~ map applyT patTs)) end)
  19.525 +  end
  19.526 +
  19.527 +
  19.528 +
  19.529 +(* linearizing proofs and resolving types of bound variables *)
  19.530 +
  19.531 +fun has_step (tab, _) = Inttab.defined tab
  19.532 +
  19.533 +fun add_step id rule bounds concl is_fix_step ids (tab, sts) =
  19.534 +  let val step = mk_step id rule ids concl bounds is_fix_step
  19.535 +  in (id, (Inttab.update (id, ()) tab, step :: sts)) end
  19.536 +
  19.537 +fun is_fix_rule rule prems =
  19.538 +  member (op =) [Quant_Intro, Nnf_Pos, Nnf_Neg] rule andalso length prems = 1
  19.539 +
  19.540 +fun lin_proof ctxt env (Z3_Node {id, rule, prems, concl, bounds}) steps =
  19.541 +  if has_step steps id then (id, steps)
  19.542 +  else
  19.543 +    let
  19.544 +      val t = subst_types ctxt env bounds concl
  19.545 +      val add = add_step id rule bounds t
  19.546 +      fun rec_apply e b = fold_map (lin_proof ctxt e) prems #-> add b
  19.547 +    in
  19.548 +      if is_fix_rule rule prems then
  19.549 +        (case match_rule ctxt env (hd prems) bounds t of
  19.550 +          NONE => rec_apply env false steps
  19.551 +        | SOME env' => rec_apply env' true steps)
  19.552 +      else rec_apply env false steps
  19.553 +    end
  19.554 +
  19.555 +fun linearize ctxt node =
  19.556 +  rev (snd (snd (lin_proof ctxt Symtab.empty node (Inttab.empty, []))))
  19.557 +
  19.558 +
  19.559 +
  19.560 +(* overall proof parser *)
  19.561 +
  19.562 +fun parse typs funs lines ctxt =
  19.563 +  let val (node, ctxt') = parse_proof typs funs lines ctxt
  19.564 +  in (linearize ctxt' node, ctxt') end
  19.565 +
  19.566 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof_literals.ML	Thu Mar 13 13:18:13 2014 +0100
    20.3 @@ -0,0 +1,357 @@
    20.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof_literals.ML
    20.5 +    Author:     Sascha Boehme, TU Muenchen
    20.6 +
    20.7 +Proof tools related to conjunctions and disjunctions.
    20.8 +*)
    20.9 +
   20.10 +signature Z3_NEW_PROOF_LITERALS =
   20.11 +sig
   20.12 +  (*literal table*)
   20.13 +  type littab = thm Termtab.table
   20.14 +  val make_littab: thm list -> littab
   20.15 +  val insert_lit: thm -> littab -> littab
   20.16 +  val delete_lit: thm -> littab -> littab
   20.17 +  val lookup_lit: littab -> term -> thm option
   20.18 +  val get_first_lit: (term -> bool) -> littab -> thm option
   20.19 +
   20.20 +  (*rules*)
   20.21 +  val true_thm: thm
   20.22 +  val rewrite_true: thm
   20.23 +
   20.24 +  (*properties*)
   20.25 +  val is_conj: term -> bool
   20.26 +  val is_disj: term -> bool
   20.27 +  val exists_lit: bool -> (term -> bool) -> term -> bool
   20.28 +  val negate: cterm -> cterm
   20.29 +
   20.30 +  (*proof tools*)
   20.31 +  val explode: bool -> bool -> bool -> term list -> thm -> thm list
   20.32 +  val join: bool -> littab -> term -> thm
   20.33 +  val prove_conj_disj_eq: cterm -> thm
   20.34 +end
   20.35 +
   20.36 +structure Z3_New_Proof_Literals: Z3_NEW_PROOF_LITERALS =
   20.37 +struct
   20.38 +
   20.39 +
   20.40 +
   20.41 +(* literal table *)
   20.42 +
   20.43 +type littab = thm Termtab.table
   20.44 +
   20.45 +fun make_littab thms =
   20.46 +  fold (Termtab.update o `SMT2_Utils.prop_of) thms Termtab.empty
   20.47 +
   20.48 +fun insert_lit thm = Termtab.update (`SMT2_Utils.prop_of thm)
   20.49 +fun delete_lit thm = Termtab.delete (SMT2_Utils.prop_of thm)
   20.50 +fun lookup_lit lits = Termtab.lookup lits
   20.51 +fun get_first_lit f =
   20.52 +  Termtab.get_first (fn (t, thm) => if f t then SOME thm else NONE)
   20.53 +
   20.54 +
   20.55 +
   20.56 +(* rules *)
   20.57 +
   20.58 +val true_thm = @{lemma "~False" by simp}
   20.59 +val rewrite_true = @{lemma "True == ~ False" by simp}
   20.60 +
   20.61 +
   20.62 +
   20.63 +(* properties and term operations *)
   20.64 +
   20.65 +val is_neg = (fn @{const Not} $ _ => true | _ => false)
   20.66 +fun is_neg' f = (fn @{const Not} $ t => f t | _ => false)
   20.67 +val is_dneg = is_neg' is_neg
   20.68 +val is_conj = (fn @{const HOL.conj} $ _ $ _ => true | _ => false)
   20.69 +val is_disj = (fn @{const HOL.disj} $ _ $ _ => true | _ => false)
   20.70 +
   20.71 +fun dest_disj_term' f = (fn
   20.72 +    @{const Not} $ (@{const HOL.disj} $ t $ u) => SOME (f t, f u)
   20.73 +  | _ => NONE)
   20.74 +
   20.75 +val dest_conj_term = (fn @{const HOL.conj} $ t $ u => SOME (t, u) | _ => NONE)
   20.76 +val dest_disj_term =
   20.77 +  dest_disj_term' (fn @{const Not} $ t => t | t => @{const Not} $ t)
   20.78 +
   20.79 +fun exists_lit is_conj P =
   20.80 +  let
   20.81 +    val dest = if is_conj then dest_conj_term else dest_disj_term
   20.82 +    fun exists t = P t orelse
   20.83 +      (case dest t of
   20.84 +        SOME (t1, t2) => exists t1 orelse exists t2
   20.85 +      | NONE => false)
   20.86 +  in exists end
   20.87 +
   20.88 +val negate = Thm.apply (Thm.cterm_of @{theory} @{const Not})
   20.89 +
   20.90 +
   20.91 +
   20.92 +(* proof tools *)
   20.93 +
   20.94 +(** explosion of conjunctions and disjunctions **)
   20.95 +
   20.96 +local
   20.97 +  val precomp = Z3_New_Proof_Tools.precompose2
   20.98 +
   20.99 +  fun destc ct = Thm.dest_binop (Thm.dest_arg ct)
  20.100 +  val dest_conj1 = precomp destc @{thm conjunct1}
  20.101 +  val dest_conj2 = precomp destc @{thm conjunct2}
  20.102 +  fun dest_conj_rules t =
  20.103 +    dest_conj_term t |> Option.map (K (dest_conj1, dest_conj2))
  20.104 +    
  20.105 +  fun destd f ct = f (Thm.dest_binop (Thm.dest_arg (Thm.dest_arg ct)))
  20.106 +  val dn1 = apfst Thm.dest_arg and dn2 = apsnd Thm.dest_arg
  20.107 +  val dest_disj1 = precomp (destd I) @{lemma "~(P | Q) ==> ~P" by fast}
  20.108 +  val dest_disj2 = precomp (destd dn1) @{lemma "~(~P | Q) ==> P" by fast}
  20.109 +  val dest_disj3 = precomp (destd I) @{lemma "~(P | Q) ==> ~Q" by fast}
  20.110 +  val dest_disj4 = precomp (destd dn2) @{lemma "~(P | ~Q) ==> Q" by fast}
  20.111 +
  20.112 +  fun dest_disj_rules t =
  20.113 +    (case dest_disj_term' is_neg t of
  20.114 +      SOME (true, true) => SOME (dest_disj2, dest_disj4)
  20.115 +    | SOME (true, false) => SOME (dest_disj2, dest_disj3)
  20.116 +    | SOME (false, true) => SOME (dest_disj1, dest_disj4)
  20.117 +    | SOME (false, false) => SOME (dest_disj1, dest_disj3)
  20.118 +    | NONE => NONE)
  20.119 +
  20.120 +  fun destn ct = [Thm.dest_arg (Thm.dest_arg (Thm.dest_arg ct))]
  20.121 +  val dneg_rule = Z3_New_Proof_Tools.precompose destn @{thm notnotD}
  20.122 +in
  20.123 +
  20.124 +(*
  20.125 +  explode a term into literals and collect all rules to be able to deduce
  20.126 +  particular literals afterwards
  20.127 +*)
  20.128 +fun explode_term is_conj =
  20.129 +  let
  20.130 +    val dest = if is_conj then dest_conj_term else dest_disj_term
  20.131 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  20.132 +
  20.133 +    fun add (t, rs) = Termtab.map_default (t, rs)
  20.134 +      (fn rs' => if length rs' < length rs then rs' else rs)
  20.135 +
  20.136 +    fun explode1 rules t =
  20.137 +      (case dest t of
  20.138 +        SOME (t1, t2) =>
  20.139 +          let val (rule1, rule2) = the (dest_rules t)
  20.140 +          in
  20.141 +            explode1 (rule1 :: rules) t1 #>
  20.142 +            explode1 (rule2 :: rules) t2 #>
  20.143 +            add (t, rev rules)
  20.144 +          end
  20.145 +      | NONE => add (t, rev rules))
  20.146 +
  20.147 +    fun explode0 (@{const Not} $ (@{const Not} $ t)) =
  20.148 +          Termtab.make [(t, [dneg_rule])]
  20.149 +      | explode0 t = explode1 [] t Termtab.empty
  20.150 +
  20.151 +  in explode0 end
  20.152 +
  20.153 +(*
  20.154 +  extract a literal by applying previously collected rules
  20.155 +*)
  20.156 +fun extract_lit thm rules = fold Z3_New_Proof_Tools.compose rules thm
  20.157 +
  20.158 +
  20.159 +(*
  20.160 +  explode a theorem into its literals
  20.161 +*)
  20.162 +fun explode is_conj full keep_intermediate stop_lits =
  20.163 +  let
  20.164 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  20.165 +    val tab = fold (Termtab.update o rpair ()) stop_lits Termtab.empty
  20.166 +
  20.167 +    fun explode1 thm =
  20.168 +      if Termtab.defined tab (SMT2_Utils.prop_of thm) then cons thm
  20.169 +      else
  20.170 +        (case dest_rules (SMT2_Utils.prop_of thm) of
  20.171 +          SOME (rule1, rule2) =>
  20.172 +            explode2 rule1 thm #>
  20.173 +            explode2 rule2 thm #>
  20.174 +            keep_intermediate ? cons thm
  20.175 +        | NONE => cons thm)
  20.176 +
  20.177 +    and explode2 dest_rule thm =
  20.178 +      if full orelse
  20.179 +        exists_lit is_conj (Termtab.defined tab) (SMT2_Utils.prop_of thm)
  20.180 +      then explode1 (Z3_New_Proof_Tools.compose dest_rule thm)
  20.181 +      else cons (Z3_New_Proof_Tools.compose dest_rule thm)
  20.182 +
  20.183 +    fun explode0 thm =
  20.184 +      if not is_conj andalso is_dneg (SMT2_Utils.prop_of thm)
  20.185 +      then [Z3_New_Proof_Tools.compose dneg_rule thm]
  20.186 +      else explode1 thm []
  20.187 +
  20.188 +  in explode0 end
  20.189 +
  20.190 +end
  20.191 +
  20.192 +
  20.193 +(** joining of literals to conjunctions or disjunctions **)
  20.194 +
  20.195 +local
  20.196 +  fun on_cprem i f thm = f (Thm.cprem_of thm i)
  20.197 +  fun on_cprop f thm = f (Thm.cprop_of thm)
  20.198 +  fun precomp2 f g thm = (on_cprem 1 f thm, on_cprem 2 g thm, f, g, thm)
  20.199 +  fun comp2 (cv1, cv2, f, g, rule) thm1 thm2 =
  20.200 +    Thm.instantiate ([], [(cv1, on_cprop f thm1), (cv2, on_cprop g thm2)]) rule
  20.201 +    |> Z3_New_Proof_Tools.discharge thm1 |> Z3_New_Proof_Tools.discharge thm2
  20.202 +
  20.203 +  fun d1 ct = Thm.dest_arg ct and d2 ct = Thm.dest_arg (Thm.dest_arg ct)
  20.204 +
  20.205 +  val conj_rule = precomp2 d1 d1 @{thm conjI}
  20.206 +  fun comp_conj ((_, thm1), (_, thm2)) = comp2 conj_rule thm1 thm2
  20.207 +
  20.208 +  val disj1 = precomp2 d2 d2 @{lemma "~P ==> ~Q ==> ~(P | Q)" by fast}
  20.209 +  val disj2 = precomp2 d2 d1 @{lemma "~P ==> Q ==> ~(P | ~Q)" by fast}
  20.210 +  val disj3 = precomp2 d1 d2 @{lemma "P ==> ~Q ==> ~(~P | Q)" by fast}
  20.211 +  val disj4 = precomp2 d1 d1 @{lemma "P ==> Q ==> ~(~P | ~Q)" by fast}
  20.212 +
  20.213 +  fun comp_disj ((false, thm1), (false, thm2)) = comp2 disj1 thm1 thm2
  20.214 +    | comp_disj ((false, thm1), (true, thm2)) = comp2 disj2 thm1 thm2
  20.215 +    | comp_disj ((true, thm1), (false, thm2)) = comp2 disj3 thm1 thm2
  20.216 +    | comp_disj ((true, thm1), (true, thm2)) = comp2 disj4 thm1 thm2
  20.217 +
  20.218 +  fun dest_conj (@{const HOL.conj} $ t $ u) = ((false, t), (false, u))
  20.219 +    | dest_conj t = raise TERM ("dest_conj", [t])
  20.220 +
  20.221 +  val neg = (fn @{const Not} $ t => (true, t) | t => (false, @{const Not} $ t))
  20.222 +  fun dest_disj (@{const Not} $ (@{const HOL.disj} $ t $ u)) = (neg t, neg u)
  20.223 +    | dest_disj t = raise TERM ("dest_disj", [t])
  20.224 +
  20.225 +  val precomp = Z3_New_Proof_Tools.precompose
  20.226 +  val dnegE = precomp (single o d2 o d1) @{thm notnotD}
  20.227 +  val dnegI = precomp (single o d1) @{lemma "P ==> ~~P" by fast}
  20.228 +  fun as_dneg f t = f (@{const Not} $ (@{const Not} $ t))
  20.229 +
  20.230 +  val precomp2 = Z3_New_Proof_Tools.precompose2
  20.231 +  fun dni f = apsnd f o Thm.dest_binop o f o d1
  20.232 +  val negIffE = precomp2 (dni d1) @{lemma "~(P = (~Q)) ==> Q = P" by fast}
  20.233 +  val negIffI = precomp2 (dni I) @{lemma "P = Q ==> ~(Q = (~P))" by fast}
  20.234 +  val iff_const = @{const HOL.eq (bool)}
  20.235 +  fun as_negIff f (@{const HOL.eq (bool)} $ t $ u) =
  20.236 +        f (@{const Not} $ (iff_const $ u $ (@{const Not} $ t)))
  20.237 +    | as_negIff _ _ = NONE
  20.238 +in
  20.239 +
  20.240 +fun join is_conj littab t =
  20.241 +  let
  20.242 +    val comp = if is_conj then comp_conj else comp_disj
  20.243 +    val dest = if is_conj then dest_conj else dest_disj
  20.244 +
  20.245 +    val lookup = lookup_lit littab
  20.246 +
  20.247 +    fun lookup_rule t =
  20.248 +      (case t of
  20.249 +        @{const Not} $ (@{const Not} $ t) =>
  20.250 +          (Z3_New_Proof_Tools.compose dnegI, lookup t)
  20.251 +      | @{const Not} $ (@{const HOL.eq (bool)} $ t $ (@{const Not} $ u)) =>
  20.252 +          (Z3_New_Proof_Tools.compose negIffI, lookup (iff_const $ u $ t))
  20.253 +      | @{const Not} $ ((eq as Const (@{const_name HOL.eq}, _)) $ t $ u) =>
  20.254 +          let fun rewr lit = lit COMP @{thm not_sym}
  20.255 +          in (rewr, lookup (@{const Not} $ (eq $ u $ t))) end
  20.256 +      | _ =>
  20.257 +          (case as_dneg lookup t of
  20.258 +            NONE => (Z3_New_Proof_Tools.compose negIffE, as_negIff lookup t)
  20.259 +          | x => (Z3_New_Proof_Tools.compose dnegE, x)))
  20.260 +
  20.261 +    fun join1 (s, t) =
  20.262 +      (case lookup t of
  20.263 +        SOME lit => (s, lit)
  20.264 +      | NONE => 
  20.265 +          (case lookup_rule t of
  20.266 +            (rewrite, SOME lit) => (s, rewrite lit)
  20.267 +          | (_, NONE) => (s, comp (pairself join1 (dest t)))))
  20.268 +
  20.269 +  in snd (join1 (if is_conj then (false, t) else (true, t))) end
  20.270 +
  20.271 +end
  20.272 +
  20.273 +
  20.274 +(** proving equality of conjunctions or disjunctions **)
  20.275 +
  20.276 +fun iff_intro thm1 thm2 = thm2 COMP (thm1 COMP @{thm iffI})
  20.277 +
  20.278 +local
  20.279 +  val cp1 = @{lemma "(~P) = (~Q) ==> P = Q" by simp}
  20.280 +  val cp2 = @{lemma "(~P) = Q ==> P = (~Q)" by fastforce}
  20.281 +  val cp3 = @{lemma "P = (~Q) ==> (~P) = Q" by simp}
  20.282 +in
  20.283 +fun contrapos1 prove (ct, cu) = prove (negate ct, negate cu) COMP cp1
  20.284 +fun contrapos2 prove (ct, cu) = prove (negate ct, Thm.dest_arg cu) COMP cp2
  20.285 +fun contrapos3 prove (ct, cu) = prove (Thm.dest_arg ct, negate cu) COMP cp3
  20.286 +end
  20.287 +
  20.288 +local
  20.289 +  val contra_rule = @{lemma "P ==> ~P ==> False" by (rule notE)}
  20.290 +  fun contra_left conj thm =
  20.291 +    let
  20.292 +      val rules = explode_term conj (SMT2_Utils.prop_of thm)
  20.293 +      fun contra_lits (t, rs) =
  20.294 +        (case t of
  20.295 +          @{const Not} $ u => Termtab.lookup rules u |> Option.map (pair rs)
  20.296 +        | _ => NONE)
  20.297 +    in
  20.298 +      (case Termtab.lookup rules @{const False} of
  20.299 +        SOME rs => extract_lit thm rs
  20.300 +      | NONE =>
  20.301 +          the (Termtab.get_first contra_lits rules)
  20.302 +          |> pairself (extract_lit thm)
  20.303 +          |> (fn (nlit, plit) => nlit COMP (plit COMP contra_rule)))
  20.304 +    end
  20.305 +
  20.306 +  val falseE_v = Thm.dest_arg (Thm.dest_arg (Thm.cprop_of @{thm FalseE}))
  20.307 +  fun contra_right ct = Thm.instantiate ([], [(falseE_v, ct)]) @{thm FalseE}
  20.308 +in
  20.309 +fun contradict conj ct =
  20.310 +  iff_intro (Z3_New_Proof_Tools.under_assumption (contra_left conj) ct)
  20.311 +    (contra_right ct)
  20.312 +end
  20.313 +
  20.314 +local
  20.315 +  fun prove_eq l r (cl, cr) =
  20.316 +    let
  20.317 +      fun explode' is_conj = explode is_conj true (l <> r) []
  20.318 +      fun make_tab is_conj thm = make_littab (true_thm :: explode' is_conj thm)
  20.319 +      fun prove is_conj ct tab = join is_conj tab (Thm.term_of ct)
  20.320 +
  20.321 +      val thm1 = Z3_New_Proof_Tools.under_assumption (prove r cr o make_tab l) cl
  20.322 +      val thm2 = Z3_New_Proof_Tools.under_assumption (prove l cl o make_tab r) cr
  20.323 +    in iff_intro thm1 thm2 end
  20.324 +
  20.325 +  datatype conj_disj = CONJ | DISJ | NCON | NDIS
  20.326 +  fun kind_of t =
  20.327 +    if is_conj t then SOME CONJ
  20.328 +    else if is_disj t then SOME DISJ
  20.329 +    else if is_neg' is_conj t then SOME NCON
  20.330 +    else if is_neg' is_disj t then SOME NDIS
  20.331 +    else NONE
  20.332 +in
  20.333 +
  20.334 +fun prove_conj_disj_eq ct =
  20.335 +  let val cp as (cl, cr) = Thm.dest_binop (Thm.dest_arg ct)
  20.336 +  in
  20.337 +    (case (kind_of (Thm.term_of cl), Thm.term_of cr) of
  20.338 +      (SOME CONJ, @{const False}) => contradict true cl
  20.339 +    | (SOME DISJ, @{const Not} $ @{const False}) =>
  20.340 +        contrapos2 (contradict false o fst) cp
  20.341 +    | (kl, _) =>
  20.342 +        (case (kl, kind_of (Thm.term_of cr)) of
  20.343 +          (SOME CONJ, SOME CONJ) => prove_eq true true cp
  20.344 +        | (SOME CONJ, SOME NDIS) => prove_eq true false cp
  20.345 +        | (SOME CONJ, _) => prove_eq true true cp
  20.346 +        | (SOME DISJ, SOME DISJ) => contrapos1 (prove_eq false false) cp
  20.347 +        | (SOME DISJ, SOME NCON) => contrapos2 (prove_eq false true) cp
  20.348 +        | (SOME DISJ, _) => contrapos1 (prove_eq false false) cp
  20.349 +        | (SOME NCON, SOME NCON) => contrapos1 (prove_eq true true) cp
  20.350 +        | (SOME NCON, SOME DISJ) => contrapos3 (prove_eq true false) cp
  20.351 +        | (SOME NCON, NONE) => contrapos3 (prove_eq true false) cp
  20.352 +        | (SOME NDIS, SOME NDIS) => prove_eq false false cp
  20.353 +        | (SOME NDIS, SOME CONJ) => prove_eq false true cp
  20.354 +        | (SOME NDIS, NONE) => prove_eq false true cp
  20.355 +        | _ => raise CTERM ("prove_conj_disj_eq", [ct])))
  20.356 +  end
  20.357 +
  20.358 +end
  20.359 +
  20.360 +end
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof_methods.ML	Thu Mar 13 13:18:13 2014 +0100
    21.3 @@ -0,0 +1,667 @@
    21.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof.ML
    21.5 +    Author:     Sascha Boehme, TU Muenchen
    21.6 +    Author:     Jasmin Blanchette, TU Muenchen
    21.7 +
    21.8 +Proof methods for replaying Z3 proofs.
    21.9 +*)
   21.10 +
   21.11 +signature Z3_NEW_PROOF_METHODS =
   21.12 +sig
   21.13 +  (*abstraction*)
   21.14 +  type abs_context = int * term Termtab.table
   21.15 +  type 'a abstracter = term -> abs_context -> 'a * abs_context
   21.16 +  val add_arith_abstracter: (term abstracter -> term option abstracter) ->
   21.17 +    Context.generic -> Context.generic
   21.18 +
   21.19 +  (*theory lemma methods*)
   21.20 +  type th_lemma_method = Proof.context -> thm list -> term -> thm
   21.21 +  val add_th_lemma_method: string * th_lemma_method -> Context.generic ->
   21.22 +    Context.generic
   21.23 +
   21.24 +  (*methods for Z3 proof rules*)
   21.25 +  type z3_method = Proof.context -> thm list -> term -> thm
   21.26 +  val true_axiom: z3_method
   21.27 +  val mp: z3_method
   21.28 +  val refl: z3_method
   21.29 +  val symm: z3_method
   21.30 +  val trans: z3_method
   21.31 +  val cong: z3_method
   21.32 +  val quant_intro: z3_method
   21.33 +  val distrib: z3_method
   21.34 +  val and_elim: z3_method
   21.35 +  val not_or_elim: z3_method
   21.36 +  val rewrite: z3_method
   21.37 +  val rewrite_star: z3_method
   21.38 +  val pull_quant: z3_method
   21.39 +  val push_quant: z3_method
   21.40 +  val elim_unused: z3_method
   21.41 +  val dest_eq_res: z3_method
   21.42 +  val quant_inst: z3_method
   21.43 +  val lemma: z3_method
   21.44 +  val unit_res: z3_method
   21.45 +  val iff_true: z3_method
   21.46 +  val iff_false: z3_method
   21.47 +  val comm: z3_method
   21.48 +  val def_axiom: z3_method
   21.49 +  val apply_def: z3_method
   21.50 +  val iff_oeq: z3_method
   21.51 +  val nnf_pos: z3_method
   21.52 +  val nnf_neg: z3_method
   21.53 +  val mp_oeq: z3_method
   21.54 +  val th_lemma: string -> z3_method
   21.55 +  val is_assumption: Z3_New_Proof.z3_rule -> bool
   21.56 +  val method_for: Z3_New_Proof.z3_rule -> z3_method
   21.57 +end
   21.58 +
   21.59 +structure Z3_New_Proof_Methods: Z3_NEW_PROOF_METHODS =
   21.60 +struct
   21.61 +
   21.62 +type z3_method = Proof.context -> thm list -> term -> thm
   21.63 +
   21.64 +
   21.65 +
   21.66 +(* utility functions *)
   21.67 +
   21.68 +val trace = SMT2_Config.trace_msg
   21.69 +
   21.70 +fun pretty_thm ctxt thm = Syntax.pretty_term ctxt (Thm.concl_of thm)
   21.71 +
   21.72 +fun pretty_goal ctxt msg rule thms t =
   21.73 +  let
   21.74 +    val full_msg = msg ^ ": " ^ quote (Z3_New_Proof.string_of_rule rule)
   21.75 +    val assms =
   21.76 +      if null thms then []
   21.77 +      else [Pretty.big_list "assumptions:" (map (pretty_thm ctxt) thms)]
   21.78 +    val concl = Pretty.big_list "proposition:" [Syntax.pretty_term ctxt t]
   21.79 +  in Pretty.big_list full_msg (assms @ [concl]) end
   21.80 +
   21.81 +fun replay_error ctxt msg rule thms t = error (Pretty.string_of (pretty_goal ctxt msg rule thms t))
   21.82 +
   21.83 +fun replay_rule_error ctxt = replay_error ctxt "Failed to replay Z3 proof step"
   21.84 +
   21.85 +fun trace_goal ctxt rule thms t =
   21.86 +  trace ctxt (fn () => Pretty.string_of (pretty_goal ctxt "Goal" rule thms t))
   21.87 +
   21.88 +fun as_prop (t as Const (@{const_name Trueprop}, _) $ _) = t
   21.89 +  | as_prop t = HOLogic.mk_Trueprop t
   21.90 +
   21.91 +fun dest_prop (Const (@{const_name Trueprop}, _) $ t) = t
   21.92 +  | dest_prop t = t
   21.93 +
   21.94 +fun dest_thm thm = dest_prop (Thm.concl_of thm)
   21.95 +
   21.96 +fun certify_prop ctxt t = SMT2_Utils.certify ctxt (as_prop t)
   21.97 +
   21.98 +fun try_provers ctxt rule [] thms t = replay_rule_error ctxt rule thms t
   21.99 +  | try_provers ctxt rule ((name, prover) :: named_provers) thms t =
  21.100 +      (case (trace ctxt (K ("Trying prover " ^ quote name)); try prover t) of
  21.101 +        SOME thm => thm
  21.102 +      | NONE => try_provers ctxt rule named_provers thms t)
  21.103 +
  21.104 +fun match ctxt pat t =
  21.105 +  (Vartab.empty, Vartab.empty)
  21.106 +  |> Pattern.first_order_match (Proof_Context.theory_of ctxt) (pat, t)
  21.107 +
  21.108 +fun gen_certify_inst sel mk cert ctxt thm t =
  21.109 +  let
  21.110 +    val inst = match ctxt (dest_thm thm) (dest_prop t)
  21.111 +    fun cert_inst (ix, (a, b)) = (cert (mk (ix, a)), cert b)
  21.112 +  in Vartab.fold (cons o cert_inst) (sel inst) [] end
  21.113 +
  21.114 +fun match_instantiateT ctxt t thm =
  21.115 +  if Term.exists_type (Term.exists_subtype Term.is_TVar) (dest_thm thm) then
  21.116 +    let val certT = Thm.ctyp_of (Proof_Context.theory_of ctxt)
  21.117 +    in Thm.instantiate (gen_certify_inst fst TVar certT ctxt thm t, []) thm end
  21.118 +  else thm
  21.119 +
  21.120 +fun match_instantiate ctxt t thm =
  21.121 +  let
  21.122 +    val cert = SMT2_Utils.certify ctxt
  21.123 +    val thm' = match_instantiateT ctxt t thm
  21.124 +  in Thm.instantiate ([], gen_certify_inst snd Var cert ctxt thm' t) thm' end
  21.125 +
  21.126 +fun apply_rule ctxt t =
  21.127 +  (case Z3_New_Proof_Rules.apply ctxt (certify_prop ctxt t) of
  21.128 +    SOME thm => thm
  21.129 +  | NONE => raise Fail "apply_rule")
  21.130 +
  21.131 +fun discharge _ [] thm = thm
  21.132 +  | discharge i (rule :: rules) thm = discharge (i + Thm.nprems_of rule) rules (rule RSN (i, thm))
  21.133 +
  21.134 +fun by_tac ctxt thms ns ts t tac =
  21.135 +  Goal.prove ctxt [] (map as_prop ts) (as_prop t)
  21.136 +    (fn {context, prems} => HEADGOAL (tac context prems))
  21.137 +  |> Drule.generalize ([], ns)
  21.138 +  |> discharge 1 thms
  21.139 +
  21.140 +fun prove ctxt t tac = by_tac ctxt [] [] [] t (K o tac)
  21.141 +
  21.142 +fun prop_tac ctxt prems =
  21.143 +  Method.insert_tac prems THEN' (Classical.fast_tac ctxt ORELSE' Clasimp.force_tac ctxt)
  21.144 +
  21.145 +fun quant_tac ctxt = Blast.blast_tac ctxt
  21.146 +
  21.147 +
  21.148 +
  21.149 +(* plug-ins *)
  21.150 +
  21.151 +type abs_context = int * term Termtab.table
  21.152 +
  21.153 +type 'a abstracter = term -> abs_context -> 'a * abs_context
  21.154 +
  21.155 +type th_lemma_method = Proof.context -> thm list -> term -> thm
  21.156 +
  21.157 +fun id_ord ((id1, _), (id2, _)) = int_ord (id1, id2)
  21.158 +
  21.159 +structure Plugins = Generic_Data
  21.160 +(
  21.161 +  type T =
  21.162 +    (int * (term abstracter -> term option abstracter)) list *
  21.163 +    th_lemma_method Symtab.table
  21.164 +  val empty = ([], Symtab.empty)
  21.165 +  val extend = I
  21.166 +  fun merge ((abss1, ths1), (abss2, ths2)) = (
  21.167 +    Ord_List.merge id_ord (abss1, abss2),
  21.168 +    Symtab.merge (K true) (ths1, ths2))
  21.169 +)
  21.170 +
  21.171 +fun add_arith_abstracter abs = Plugins.map (apfst (Ord_List.insert id_ord (serial (), abs)))
  21.172 +fun get_arith_abstracters ctxt = map snd (fst (Plugins.get (Context.Proof ctxt)))
  21.173 +
  21.174 +fun add_th_lemma_method method = Plugins.map (apsnd (Symtab.update_new method))
  21.175 +fun get_th_lemma_method ctxt = snd (Plugins.get (Context.Proof ctxt))
  21.176 +
  21.177 +
  21.178 +
  21.179 +(* abstraction *)
  21.180 +
  21.181 +fun prove_abstract ctxt thms t tac f =
  21.182 +  let
  21.183 +    val ((prems, concl), (_, ts)) = f (1, Termtab.empty)
  21.184 +    val ns = Termtab.fold (fn (_, v) => cons (fst (Term.dest_Free v))) ts []
  21.185 +  in
  21.186 +    by_tac ctxt [] ns prems concl tac
  21.187 +    |> match_instantiate ctxt t
  21.188 +    |> discharge 1 thms
  21.189 +  end
  21.190 +
  21.191 +fun prove_abstract' ctxt t tac f =
  21.192 +  prove_abstract ctxt [] t tac (f #>> pair [])
  21.193 +
  21.194 +fun lookup_term (_, terms) t = Termtab.lookup terms t
  21.195 +
  21.196 +fun abstract_sub t f cx =
  21.197 +  (case lookup_term cx t of
  21.198 +    SOME v => (v, cx)
  21.199 +  | NONE => f cx)
  21.200 +
  21.201 +fun mk_fresh_free t (i, terms) =
  21.202 +  let val v = Free ("t" ^ string_of_int i, fastype_of t)
  21.203 +  in (v, (i + 1, Termtab.update (t, v) terms)) end
  21.204 +
  21.205 +fun apply_abstracters _ [] _ cx = (NONE, cx)
  21.206 +  | apply_abstracters abs (abstracter :: abstracters) t cx =
  21.207 +      (case abstracter abs t cx of
  21.208 +        (NONE, _) => apply_abstracters abs abstracters t cx
  21.209 +      | x as (SOME _, _) => x)
  21.210 +
  21.211 +fun abstract_term (t as _ $ _) = abstract_sub t (mk_fresh_free t)
  21.212 +  | abstract_term (t as Abs _) = abstract_sub t (mk_fresh_free t)
  21.213 +  | abstract_term t = pair t
  21.214 +
  21.215 +fun abstract_bin abs f t t1 t2 = abstract_sub t (abs t1 ##>> abs t2 #>> f)
  21.216 +
  21.217 +fun abstract_ter abs f t t1 t2 t3 =
  21.218 +  abstract_sub t (abs t1 ##>> abs t2 ##>> abs t3 #>> (Parse.triple1 #> f))
  21.219 +
  21.220 +fun abstract_lit (@{const HOL.Not} $ t) = abstract_term t #>> HOLogic.mk_not
  21.221 +  | abstract_lit t = abstract_term t
  21.222 +
  21.223 +fun abstract_not abs (t as @{const HOL.Not} $ t1) =
  21.224 +      abstract_sub t (abs t1 #>> HOLogic.mk_not)
  21.225 +  | abstract_not _ t = abstract_lit t
  21.226 +
  21.227 +fun abstract_conj (t as @{const HOL.conj} $ t1 $ t2) =
  21.228 +      abstract_bin abstract_conj HOLogic.mk_conj t t1 t2
  21.229 +  | abstract_conj t = abstract_lit t
  21.230 +
  21.231 +fun abstract_disj (t as @{const HOL.disj} $ t1 $ t2) =
  21.232 +      abstract_bin abstract_disj HOLogic.mk_disj t t1 t2
  21.233 +  | abstract_disj t = abstract_lit t
  21.234 +
  21.235 +fun abstract_prop (t as (c as @{const If (bool)}) $ t1 $ t2 $ t3) =
  21.236 +      abstract_ter abstract_prop (fn (t1, t2, t3) => c $ t1 $ t2 $ t3) t t1 t2 t3
  21.237 +  | abstract_prop (t as @{const HOL.disj} $ t1 $ t2) =
  21.238 +      abstract_bin abstract_prop HOLogic.mk_disj t t1 t2
  21.239 +  | abstract_prop (t as @{const HOL.conj} $ t1 $ t2) =
  21.240 +      abstract_bin abstract_prop HOLogic.mk_conj t t1 t2
  21.241 +  | abstract_prop (t as @{const HOL.implies} $ t1 $ t2) =
  21.242 +      abstract_bin abstract_prop HOLogic.mk_imp t t1 t2
  21.243 +  | abstract_prop (t as @{term "HOL.eq :: bool => _"} $ t1 $ t2) =
  21.244 +      abstract_bin abstract_prop HOLogic.mk_eq t t1 t2
  21.245 +  | abstract_prop t = abstract_not abstract_prop t
  21.246 +
  21.247 +fun abstract_arith ctxt u =
  21.248 +  let
  21.249 +    fun abs (t as (c as Const _) $ Abs (s, T, t')) =
  21.250 +          abstract_sub t (abs t' #>> (fn u' => c $ Abs (s, T, u')))
  21.251 +      | abs (t as (c as Const (@{const_name If}, _)) $ t1 $ t2 $ t3) =
  21.252 +          abstract_ter abs (fn (t1, t2, t3) => c $ t1 $ t2 $ t3) t t1 t2 t3
  21.253 +      | abs (t as @{const HOL.Not} $ t1) = abstract_sub t (abs t1 #>> HOLogic.mk_not)
  21.254 +      | abs (t as @{const HOL.disj} $ t1 $ t2) =
  21.255 +          abstract_sub t (abs t1 ##>> abs t2 #>> HOLogic.mk_disj)
  21.256 +      | abs (t as (c as Const (@{const_name uminus_class.uminus}, _)) $ t1) =
  21.257 +          abstract_sub t (abs t1 #>> (fn u => c $ u))
  21.258 +      | abs (t as (c as Const (@{const_name plus_class.plus}, _)) $ t1 $ t2) =
  21.259 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.260 +      | abs (t as (c as Const (@{const_name minus_class.minus}, _)) $ t1 $ t2) =
  21.261 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.262 +      | abs (t as (c as Const (@{const_name times_class.times}, _)) $ t1 $ t2) =
  21.263 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.264 +      | abs (t as (c as Const (@{const_name z3div}, _)) $ t1 $ t2) =
  21.265 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.266 +      | abs (t as (c as Const (@{const_name z3mod}, _)) $ t1 $ t2) =
  21.267 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.268 +      | abs (t as (c as Const (@{const_name HOL.eq}, _)) $ t1 $ t2) =
  21.269 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.270 +      | abs (t as (c as Const (@{const_name ord_class.less}, _)) $ t1 $ t2) =
  21.271 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.272 +      | abs (t as (c as Const (@{const_name ord_class.less_eq}, _)) $ t1 $ t2) =
  21.273 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  21.274 +      | abs t = abstract_sub t (fn cx =>
  21.275 +          if can HOLogic.dest_number t then (t, cx)
  21.276 +          else
  21.277 +            (case apply_abstracters abs (get_arith_abstracters ctxt) t cx of
  21.278 +              (SOME u, cx') => (u, cx')
  21.279 +            | (NONE, _) => abstract_term t cx))
  21.280 +  in abs u end
  21.281 +
  21.282 +
  21.283 +
  21.284 +(* truth axiom *)
  21.285 +
  21.286 +fun true_axiom _ _ _ = @{thm TrueI}
  21.287 +
  21.288 +
  21.289 +
  21.290 +(* modus ponens *)
  21.291 +
  21.292 +fun mp _ [p, p_eq_q] _ = discharge 1 [p_eq_q, p] iffD1
  21.293 +  | mp ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Modus_Ponens thms t
  21.294 +
  21.295 +val mp_oeq = mp
  21.296 +
  21.297 +
  21.298 +
  21.299 +(* reflexivity *)
  21.300 +
  21.301 +fun refl ctxt _ t = match_instantiate ctxt t @{thm refl}
  21.302 +
  21.303 +
  21.304 +
  21.305 +(* symmetry *)
  21.306 +
  21.307 +fun symm _ [thm] _ = thm RS @{thm sym}
  21.308 +  | symm ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Reflexivity thms t
  21.309 +
  21.310 +
  21.311 +
  21.312 +(* transitivity *)
  21.313 +
  21.314 +fun trans _ [thm1, thm2] _ = thm1 RSN (1, thm2 RSN (2, @{thm trans}))
  21.315 +  | trans ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Transitivity thms t
  21.316 +
  21.317 +
  21.318 +
  21.319 +(* congruence *)
  21.320 +
  21.321 +fun ctac prems i st = st |> (
  21.322 +  resolve_tac (@{thm refl} :: prems) i
  21.323 +  ORELSE (cong_tac i THEN ctac prems (i + 1) THEN ctac prems i))
  21.324 +
  21.325 +fun cong_basic ctxt thms t =
  21.326 +  let val st = Thm.trivial (certify_prop ctxt t)
  21.327 +  in
  21.328 +    (case Seq.pull (ctac thms 1 st) of
  21.329 +      SOME (thm, _) => thm
  21.330 +    | NONE => raise THM ("cong", 0, thms @ [st]))
  21.331 +  end
  21.332 +
  21.333 +val cong_dest_rules = @{lemma
  21.334 +  "(~ P | Q) & (P | ~ Q) ==> P = Q"
  21.335 +  "(P | ~ Q) & (~ P | Q) ==> P = Q"
  21.336 +  by fast+}
  21.337 +
  21.338 +fun cong_full ctxt thms t = prove ctxt t (fn ctxt' =>
  21.339 +  Method.insert_tac thms
  21.340 +  THEN' (Classical.fast_tac ctxt'
  21.341 +    ORELSE' dresolve_tac cong_dest_rules
  21.342 +    THEN' Classical.fast_tac ctxt'))
  21.343 +
  21.344 +fun cong ctxt thms = try_provers ctxt Z3_New_Proof.Monotonicity [
  21.345 +  ("basic", cong_basic ctxt thms),
  21.346 +  ("full", cong_full ctxt thms)] thms
  21.347 +
  21.348 +
  21.349 +
  21.350 +(* quantifier introduction *)
  21.351 +
  21.352 +val quant_intro_rules = @{lemma
  21.353 +  "(!!x. P x = Q x) ==> (ALL x. P x) = (ALL x. Q x)"
  21.354 +  "(!!x. P x = Q x) ==> (EX x. P x) = (EX x. Q x)"
  21.355 +  "(!!x. (~ P x) = Q x) ==> (~ (EX x. P x)) = (ALL x. Q x)"
  21.356 +  "(!!x. (~ P x) = Q x) ==> (~ (ALL x. P x)) = (EX x. Q x)"
  21.357 +  by fast+}
  21.358 +
  21.359 +fun quant_intro ctxt [thm] t =
  21.360 +    prove ctxt t (K (REPEAT_ALL_NEW (resolve_tac (thm :: quant_intro_rules))))
  21.361 +  | quant_intro ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Quant_Intro thms t
  21.362 +
  21.363 +
  21.364 +
  21.365 +(* distributivity of conjunctions and disjunctions *)
  21.366 +
  21.367 +(* TODO: there are no tests with this proof rule *)
  21.368 +fun distrib ctxt _ t =
  21.369 +  prove_abstract' ctxt t prop_tac (abstract_prop (dest_prop t))
  21.370 +
  21.371 +
  21.372 +
  21.373 +(* elimination of conjunctions *)
  21.374 +
  21.375 +fun and_elim ctxt [thm] t =
  21.376 +      prove_abstract ctxt [thm] t prop_tac (
  21.377 +        abstract_lit (dest_prop t) ##>>
  21.378 +        abstract_conj (dest_thm thm) #>>
  21.379 +        apfst single o swap)
  21.380 +  | and_elim ctxt thms t = replay_rule_error ctxt Z3_New_Proof.And_Elim thms t
  21.381 +
  21.382 +
  21.383 +
  21.384 +(* elimination of negated disjunctions *)
  21.385 +
  21.386 +fun not_or_elim ctxt [thm] t =
  21.387 +      prove_abstract ctxt [thm] t prop_tac (
  21.388 +        abstract_lit (dest_prop t) ##>>
  21.389 +        abstract_not abstract_disj (dest_thm thm) #>>
  21.390 +        apfst single o swap)
  21.391 +  | not_or_elim ctxt thms t =
  21.392 +      replay_rule_error ctxt Z3_New_Proof.Not_Or_Elim thms t
  21.393 +
  21.394 +
  21.395 +
  21.396 +(* rewriting *)
  21.397 +
  21.398 +fun abstract_eq f1 f2 (Const (@{const_name HOL.eq}, _) $ t1 $ t2) =
  21.399 +      f1 t1 ##>> f2 t2 #>> HOLogic.mk_eq
  21.400 +  | abstract_eq _ _ t = abstract_term t
  21.401 +
  21.402 +fun prove_prop_rewrite ctxt t =
  21.403 +  prove_abstract' ctxt t prop_tac (
  21.404 +    abstract_eq abstract_prop abstract_prop (dest_prop t))
  21.405 +
  21.406 +fun arith_rewrite_tac ctxt _ =
  21.407 +  TRY o Simplifier.simp_tac ctxt
  21.408 +  THEN_ALL_NEW (Arith_Data.arith_tac ctxt ORELSE' Clasimp.force_tac ctxt)
  21.409 +
  21.410 +fun prove_arith_rewrite ctxt t =
  21.411 +  prove_abstract' ctxt t arith_rewrite_tac (
  21.412 +    abstract_eq (abstract_arith ctxt) (abstract_arith ctxt) (dest_prop t))
  21.413 +
  21.414 +fun rewrite ctxt _ = try_provers ctxt Z3_New_Proof.Rewrite [
  21.415 +  ("rules", apply_rule ctxt),
  21.416 +  ("prop_rewrite", prove_prop_rewrite ctxt),
  21.417 +  ("arith_rewrite", prove_arith_rewrite ctxt)] []
  21.418 +
  21.419 +fun rewrite_star ctxt = rewrite ctxt
  21.420 +
  21.421 +
  21.422 +
  21.423 +(* pulling quantifiers *)
  21.424 +
  21.425 +fun pull_quant ctxt _ t = prove ctxt t quant_tac
  21.426 +
  21.427 +
  21.428 +
  21.429 +(* pushing quantifiers *)
  21.430 +
  21.431 +fun push_quant _ _ _ = raise Fail "unsupported" (* FIXME *)
  21.432 +
  21.433 +
  21.434 +
  21.435 +(* elimination of unused bound variables *)
  21.436 +
  21.437 +val elim_all = @{lemma "P = Q ==> (ALL x. P) = Q" by fast}
  21.438 +val elim_ex = @{lemma "P = Q ==> (EX x. P) = Q" by fast}
  21.439 +
  21.440 +fun elim_unused_tac i st = (
  21.441 +  match_tac [@{thm refl}]
  21.442 +  ORELSE' (match_tac [elim_all, elim_ex] THEN' elim_unused_tac)
  21.443 +  ORELSE' (
  21.444 +    match_tac [@{thm iff_allI}, @{thm iff_exI}]
  21.445 +    THEN' elim_unused_tac)) i st
  21.446 +
  21.447 +fun elim_unused ctxt _ t = prove ctxt t (fn _ => elim_unused_tac)
  21.448 +
  21.449 +
  21.450 +
  21.451 +(* destructive equality resolution *)
  21.452 +
  21.453 +fun dest_eq_res _ _ _ = raise Fail "dest_eq_res" (* FIXME *)
  21.454 +
  21.455 +
  21.456 +
  21.457 +(* quantifier instantiation *)
  21.458 +
  21.459 +val quant_inst_rule = @{lemma "~P x | Q ==> ~(ALL x. P x) | Q" by fast}
  21.460 +
  21.461 +fun quant_inst ctxt _ t = prove ctxt t (fn _ => 
  21.462 +  REPEAT_ALL_NEW (rtac quant_inst_rule)
  21.463 +  THEN' rtac @{thm excluded_middle})
  21.464 +
  21.465 +
  21.466 +
  21.467 +(* propositional lemma *)
  21.468 +
  21.469 +exception LEMMA of unit
  21.470 +
  21.471 +val intro_hyp_rule1 = @{lemma "(~P ==> Q) ==> P | Q" by fast}
  21.472 +val intro_hyp_rule2 = @{lemma "(P ==> Q) ==> ~P | Q" by fast}
  21.473 +
  21.474 +fun norm_lemma thm =
  21.475 +  (thm COMP_INCR intro_hyp_rule1)
  21.476 +  handle THM _ => thm COMP_INCR intro_hyp_rule2
  21.477 +
  21.478 +fun negated_prop (@{const HOL.Not} $ t) = HOLogic.mk_Trueprop t
  21.479 +  | negated_prop t = HOLogic.mk_Trueprop (HOLogic.mk_not t)
  21.480 +
  21.481 +fun intro_hyps tab (t as @{const HOL.disj} $ t1 $ t2) cx =
  21.482 +      lookup_intro_hyps tab t (fold (intro_hyps tab) [t1, t2]) cx
  21.483 +  | intro_hyps tab t cx =
  21.484 +      lookup_intro_hyps tab t (fn _ => raise LEMMA ()) cx
  21.485 +
  21.486 +and lookup_intro_hyps tab t f (cx as (thm, terms)) =
  21.487 +  (case Termtab.lookup tab (negated_prop t) of
  21.488 +    NONE => f cx
  21.489 +  | SOME hyp => (norm_lemma (Thm.implies_intr hyp thm), t :: terms))
  21.490 +
  21.491 +fun lemma ctxt (thms as [thm]) t =
  21.492 +    (let
  21.493 +       val tab = Termtab.make (map (`Thm.term_of) (#hyps (Thm.crep_thm thm)))
  21.494 +       val (thm', terms) = intro_hyps tab (dest_prop t) (thm, [])
  21.495 +     in
  21.496 +       prove_abstract ctxt [thm'] t prop_tac (
  21.497 +         fold (snd oo abstract_lit) terms #>
  21.498 +         abstract_disj (dest_thm thm') #>> single ##>>
  21.499 +         abstract_disj (dest_prop t))
  21.500 +     end
  21.501 +     handle LEMMA () => replay_error ctxt "Bad proof state" Z3_New_Proof.Lemma thms t)
  21.502 +  | lemma ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Lemma thms t
  21.503 +
  21.504 +
  21.505 +
  21.506 +(* unit resolution *)
  21.507 +
  21.508 +fun abstract_unit (t as (@{const HOL.Not} $ (@{const HOL.disj} $ t1 $ t2))) =
  21.509 +      abstract_sub t (abstract_unit t1 ##>> abstract_unit t2 #>>
  21.510 +        HOLogic.mk_not o HOLogic.mk_disj)
  21.511 +  | abstract_unit (t as (@{const HOL.disj} $ t1 $ t2)) =
  21.512 +      abstract_sub t (abstract_unit t1 ##>> abstract_unit t2 #>>
  21.513 +        HOLogic.mk_disj)
  21.514 +  | abstract_unit t = abstract_lit t
  21.515 +
  21.516 +fun unit_res ctxt thms t =
  21.517 +  prove_abstract ctxt thms t prop_tac (
  21.518 +    fold_map (abstract_unit o dest_thm) thms ##>>
  21.519 +    abstract_unit (dest_prop t) #>>
  21.520 +    (fn (prems, concl) => (prems, concl)))
  21.521 +
  21.522 +
  21.523 +
  21.524 +(* iff-true *)
  21.525 +
  21.526 +val iff_true_rule = @{lemma "P ==> P = True" by fast}
  21.527 +
  21.528 +fun iff_true _ [thm] _ = thm RS iff_true_rule
  21.529 +  | iff_true ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Iff_True thms t
  21.530 +
  21.531 +
  21.532 +
  21.533 +(* iff-false *)
  21.534 +
  21.535 +val iff_false_rule = @{lemma "~P ==> P = False" by fast}
  21.536 +
  21.537 +fun iff_false _ [thm] _ = thm RS iff_false_rule
  21.538 +  | iff_false ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Iff_False thms t
  21.539 +
  21.540 +
  21.541 +
  21.542 +(* commutativity *)
  21.543 +
  21.544 +fun comm ctxt _ t = match_instantiate ctxt t @{thm eq_commute}
  21.545 +
  21.546 +
  21.547 +
  21.548 +(* definitional axioms *)
  21.549 +
  21.550 +fun def_axiom_disj ctxt t =
  21.551 +  (case dest_prop t of
  21.552 +    @{const HOL.disj} $ u1 $ u2 =>
  21.553 +      prove_abstract' ctxt t prop_tac (
  21.554 +        abstract_prop u2 ##>> abstract_prop u1 #>> HOLogic.mk_disj o swap)
  21.555 +  | u => prove_abstract' ctxt t prop_tac (abstract_prop u))
  21.556 +
  21.557 +fun def_axiom ctxt _ = try_provers ctxt Z3_New_Proof.Def_Axiom [
  21.558 +  ("rules", apply_rule ctxt),
  21.559 +  ("disj", def_axiom_disj ctxt)] []
  21.560 +
  21.561 +
  21.562 +
  21.563 +(* application of definitions *)
  21.564 +
  21.565 +fun apply_def _ [thm] _ = thm (* TODO: cover also the missing cases *)
  21.566 +  | apply_def ctxt thms t = replay_rule_error ctxt Z3_New_Proof.Apply_Def thms t
  21.567 +
  21.568 +
  21.569 +
  21.570 +(* iff-oeq *)
  21.571 +
  21.572 +fun iff_oeq _ _ _ = raise Fail "iff_oeq" (* FIXME *)
  21.573 +
  21.574 +
  21.575 +
  21.576 +(* negation normal form *)
  21.577 +
  21.578 +fun nnf_prop ctxt thms t =
  21.579 +  prove_abstract ctxt thms t prop_tac (
  21.580 +    fold_map (abstract_prop o dest_thm) thms ##>>
  21.581 +    abstract_prop (dest_prop t))
  21.582 +
  21.583 +fun nnf ctxt rule thms = try_provers ctxt rule [
  21.584 +  ("prop", nnf_prop ctxt thms),
  21.585 +  ("quant", quant_intro ctxt [hd thms])] thms
  21.586 +
  21.587 +fun nnf_pos ctxt = nnf ctxt Z3_New_Proof.Nnf_Pos
  21.588 +fun nnf_neg ctxt = nnf ctxt Z3_New_Proof.Nnf_Neg
  21.589 +
  21.590 +
  21.591 +
  21.592 +(* theory lemmas *)
  21.593 +
  21.594 +fun arith_th_lemma_tac ctxt prems =
  21.595 +  Method.insert_tac prems
  21.596 +  THEN' SELECT_GOAL (Local_Defs.unfold_tac ctxt @{thms z3div_def z3mod_def})
  21.597 +  THEN' Arith_Data.arith_tac ctxt
  21.598 +
  21.599 +fun arith_th_lemma ctxt thms t =
  21.600 +  prove_abstract ctxt thms t arith_th_lemma_tac (
  21.601 +    fold_map (abstract_arith ctxt o dest_thm) thms ##>>
  21.602 +    abstract_arith ctxt (dest_prop t))
  21.603 +
  21.604 +val _ = Theory.setup (Context.theory_map (add_th_lemma_method ("arith", arith_th_lemma)))
  21.605 +
  21.606 +fun th_lemma name ctxt thms =
  21.607 +  (case Symtab.lookup (get_th_lemma_method ctxt) name of
  21.608 +    SOME method => method ctxt thms
  21.609 +  | NONE => replay_error ctxt "Bad theory" (Z3_New_Proof.Th_Lemma name) thms)
  21.610 +
  21.611 +
  21.612 +
  21.613 +(* mapping of rules to methods *)
  21.614 +
  21.615 +fun is_assumption Z3_New_Proof.Asserted = true
  21.616 +  | is_assumption Z3_New_Proof.Goal = true
  21.617 +  | is_assumption Z3_New_Proof.Hypothesis = true
  21.618 +  | is_assumption Z3_New_Proof.Intro_Def = true
  21.619 +  | is_assumption Z3_New_Proof.Skolemize = true
  21.620 +  | is_assumption _ = false
  21.621 +
  21.622 +fun unsupported rule ctxt = replay_error ctxt "Unsupported" rule
  21.623 +fun assumed rule ctxt = replay_error ctxt "Assumed" rule
  21.624 +
  21.625 +fun choose Z3_New_Proof.True_Axiom = true_axiom
  21.626 +  | choose (r as Z3_New_Proof.Asserted) = assumed r
  21.627 +  | choose (r as Z3_New_Proof.Goal) = assumed r
  21.628 +  | choose Z3_New_Proof.Modus_Ponens = mp
  21.629 +  | choose Z3_New_Proof.Reflexivity = refl
  21.630 +  | choose Z3_New_Proof.Symmetry = symm
  21.631 +  | choose Z3_New_Proof.Transitivity = trans
  21.632 +  | choose (r as Z3_New_Proof.Transitivity_Star) = unsupported r
  21.633 +  | choose Z3_New_Proof.Monotonicity = cong
  21.634 +  | choose Z3_New_Proof.Quant_Intro = quant_intro
  21.635 +  | choose Z3_New_Proof.Distributivity = distrib
  21.636 +  | choose Z3_New_Proof.And_Elim = and_elim
  21.637 +  | choose Z3_New_Proof.Not_Or_Elim = not_or_elim
  21.638 +  | choose Z3_New_Proof.Rewrite = rewrite
  21.639 +  | choose Z3_New_Proof.Rewrite_Star = rewrite_star
  21.640 +  | choose Z3_New_Proof.Pull_Quant = pull_quant
  21.641 +  | choose (r as Z3_New_Proof.Pull_Quant_Star) = unsupported r
  21.642 +  | choose Z3_New_Proof.Push_Quant = push_quant
  21.643 +  | choose Z3_New_Proof.Elim_Unused_Vars = elim_unused
  21.644 +  | choose Z3_New_Proof.Dest_Eq_Res = dest_eq_res
  21.645 +  | choose Z3_New_Proof.Quant_Inst = quant_inst
  21.646 +  | choose (r as Z3_New_Proof.Hypothesis) = assumed r
  21.647 +  | choose Z3_New_Proof.Lemma = lemma
  21.648 +  | choose Z3_New_Proof.Unit_Resolution = unit_res
  21.649 +  | choose Z3_New_Proof.Iff_True = iff_true
  21.650 +  | choose Z3_New_Proof.Iff_False = iff_false
  21.651 +  | choose Z3_New_Proof.Commutativity = comm
  21.652 +  | choose Z3_New_Proof.Def_Axiom = def_axiom
  21.653 +  | choose (r as Z3_New_Proof.Intro_Def) = assumed r
  21.654 +  | choose Z3_New_Proof.Apply_Def = apply_def
  21.655 +  | choose Z3_New_Proof.Iff_Oeq = iff_oeq
  21.656 +  | choose Z3_New_Proof.Nnf_Pos = nnf_pos
  21.657 +  | choose Z3_New_Proof.Nnf_Neg = nnf_neg
  21.658 +  | choose (r as Z3_New_Proof.Nnf_Star) = unsupported r
  21.659 +  | choose (r as Z3_New_Proof.Cnf_Star) = unsupported r
  21.660 +  | choose (r as Z3_New_Proof.Skolemize) = assumed r
  21.661 +  | choose Z3_New_Proof.Modus_Ponens_Oeq = mp_oeq
  21.662 +  | choose (Z3_New_Proof.Th_Lemma name) = th_lemma name
  21.663 +
  21.664 +fun with_tracing rule method ctxt thms t =
  21.665 +  let val _ = trace_goal ctxt rule thms t
  21.666 +  in method ctxt thms t end
  21.667 +
  21.668 +fun method_for rule = with_tracing rule (choose rule)
  21.669 +
  21.670 +end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof_replay.ML	Thu Mar 13 13:18:13 2014 +0100
    22.3 @@ -0,0 +1,194 @@
    22.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof_replay.ML
    22.5 +    Author:     Sascha Boehme, TU Muenchen
    22.6 +    Author:     Jasmin Blanchette, TU Muenchen
    22.7 +
    22.8 +Z3 proof replay.
    22.9 +*)
   22.10 +
   22.11 +signature Z3_NEW_PROOF_REPLAY =
   22.12 +sig
   22.13 +  val replay: Proof.context -> SMT2_Translate.replay_data -> string list -> int list * thm
   22.14 +end
   22.15 +
   22.16 +structure Z3_New_Proof_Replay: Z3_NEW_PROOF_REPLAY =
   22.17 +struct
   22.18 +
   22.19 +fun params_of t = Term.strip_qnt_vars @{const_name all} t
   22.20 +
   22.21 +fun varify ctxt thm =
   22.22 +  let
   22.23 +    val maxidx = Thm.maxidx_of thm + 1
   22.24 +    val vs = params_of (Thm.prop_of thm)
   22.25 +    val vars = map_index (fn (i, (n, T)) => Var ((n, i + maxidx), T)) vs
   22.26 +  in Drule.forall_elim_list (map (SMT2_Utils.certify ctxt) vars) thm end
   22.27 +
   22.28 +fun add_paramTs names t =
   22.29 +  fold2 (fn n => fn (_, T) => AList.update (op =) (n, T)) names (params_of t)
   22.30 +
   22.31 +fun new_fixes ctxt nTs =
   22.32 +  let
   22.33 +    val (ns, ctxt') = Variable.variant_fixes (replicate (length nTs) "") ctxt
   22.34 +    fun mk (n, T) n' = (n, SMT2_Utils.certify ctxt' (Free (n', T)))
   22.35 +  in (ctxt', Symtab.make (map2 mk nTs ns)) end
   22.36 +
   22.37 +fun forall_elim_term ct (Const (@{const_name all}, _) $ (a as Abs _)) =
   22.38 +      Term.betapply (a, Thm.term_of ct)
   22.39 +  | forall_elim_term _ qt = raise TERM ("forall_elim'", [qt])
   22.40 +
   22.41 +fun apply_fixes elim env = fold (elim o the o Symtab.lookup env)
   22.42 +
   22.43 +val apply_fixes_prem = uncurry o apply_fixes Thm.forall_elim
   22.44 +val apply_fixes_concl = apply_fixes forall_elim_term
   22.45 +
   22.46 +fun export_fixes env names = Drule.forall_intr_list (map (the o Symtab.lookup env) names)
   22.47 +
   22.48 +fun under_fixes f ctxt (prems, nthms) names concl =
   22.49 +  let
   22.50 +    val thms1 = map (varify ctxt) prems
   22.51 +    val (ctxt', env) =
   22.52 +      add_paramTs names concl []
   22.53 +      |> fold (uncurry add_paramTs o apsnd Thm.prop_of) nthms
   22.54 +      |> new_fixes ctxt
   22.55 +    val thms2 = map (apply_fixes_prem env) nthms
   22.56 +    val t = apply_fixes_concl env names concl
   22.57 +  in export_fixes env names (f ctxt' (thms1 @ thms2) t) end
   22.58 +
   22.59 +fun replay_thm ctxt assumed nthms
   22.60 +    (Z3_New_Proof.Z3_Step {id, rule, concl, fixes, is_fix_step, ...}) =
   22.61 +(tracing ("replay_thm: " ^ @{make_string} (id, rule) ^ " " ^ Syntax.string_of_term ctxt concl);
   22.62 +  if Z3_New_Proof_Methods.is_assumption rule then
   22.63 +    (case Inttab.lookup assumed id of
   22.64 +      SOME (_, thm) => thm
   22.65 +    | NONE => Thm.assume (SMT2_Utils.certify ctxt concl))
   22.66 +  else
   22.67 +    under_fixes (Z3_New_Proof_Methods.method_for rule) ctxt
   22.68 +      (if is_fix_step then (map snd nthms, []) else ([], nthms)) fixes concl
   22.69 +) (*###*)
   22.70 +
   22.71 +fun replay_step ctxt assumed (step as Z3_New_Proof.Z3_Step {id, prems, fixes, ...}) proofs =
   22.72 +  let val nthms = map (the o Inttab.lookup proofs) prems
   22.73 +  in Inttab.update (id, (fixes, replay_thm ctxt assumed nthms step)) proofs end
   22.74 +
   22.75 +local
   22.76 +  val remove_trigger = mk_meta_eq @{thm SMT2.trigger_def}
   22.77 +  val remove_weight = mk_meta_eq @{thm SMT2.weight_def}
   22.78 +  val remove_fun_app = mk_meta_eq @{thm SMT2.fun_app_def}
   22.79 +
   22.80 +  fun rewrite_conv _ [] = Conv.all_conv
   22.81 +    | rewrite_conv ctxt eqs = Simplifier.full_rewrite (empty_simpset ctxt addsimps eqs)
   22.82 +
   22.83 +  val prep_rules = [@{thm Let_def}, remove_trigger, remove_weight,
   22.84 +    remove_fun_app, Z3_New_Proof_Literals.rewrite_true]
   22.85 +
   22.86 +  fun rewrite _ [] = I
   22.87 +    | rewrite ctxt eqs = Conv.fconv_rule (rewrite_conv ctxt eqs)
   22.88 +
   22.89 +  fun lookup_assm assms_net ct =
   22.90 +    Z3_New_Proof_Tools.net_instances assms_net ct
   22.91 +    |> map (fn ithm as (_, thm) => (ithm, Thm.cprop_of thm aconvc ct))
   22.92 +in
   22.93 +
   22.94 +fun add_asserted outer_ctxt rewrite_rules assms steps ctxt =
   22.95 +  let
   22.96 +    val eqs = map (rewrite ctxt [Z3_New_Proof_Literals.rewrite_true]) rewrite_rules
   22.97 +    val eqs' = union Thm.eq_thm eqs prep_rules
   22.98 +
   22.99 +    val assms_net =
  22.100 +      assms
  22.101 +      |> map (apsnd (rewrite ctxt eqs'))
  22.102 +      |> map (apsnd (Conv.fconv_rule Thm.eta_conversion))
  22.103 +      |> Z3_New_Proof_Tools.thm_net_of snd 
  22.104 +
  22.105 +    fun revert_conv ctxt = rewrite_conv ctxt eqs' then_conv Thm.eta_conversion
  22.106 +
  22.107 +    fun assume thm ctxt =
  22.108 +      let
  22.109 +        val ct = Thm.cprem_of thm 1
  22.110 +        val (thm', ctxt') = yield_singleton Assumption.add_assumes ct ctxt
  22.111 +      in (thm' RS thm, ctxt') end
  22.112 +
  22.113 +    fun add1 id fixes thm1 ((i, th), exact) ((is, thms), (ctxt, ptab)) =
  22.114 +      let
  22.115 +        val (thm, ctxt') = if exact then (Thm.implies_elim thm1 th, ctxt) else assume thm1 ctxt
  22.116 +        val thms' = if exact then thms else th :: thms
  22.117 +      in 
  22.118 +        ((insert (op =) i is, thms'),
  22.119 +          (ctxt', Inttab.update (id, (fixes, thm)) ptab))
  22.120 +      end
  22.121 +
  22.122 +    fun add (Z3_New_Proof.Z3_Step {id, rule, concl, fixes, ...})
  22.123 +        (cx as ((is, thms), (ctxt, ptab))) =
  22.124 +      if Z3_New_Proof_Methods.is_assumption rule andalso rule <> Z3_New_Proof.Hypothesis then
  22.125 +        let
  22.126 +          val ct = SMT2_Utils.certify ctxt concl
  22.127 +          val thm1 =
  22.128 +            Thm.trivial ct
  22.129 +            |> Conv.fconv_rule (Conv.arg1_conv (revert_conv outer_ctxt))
  22.130 +          val thm2 = singleton (Variable.export ctxt outer_ctxt) thm1
  22.131 +        in
  22.132 +          (case lookup_assm assms_net (Thm.cprem_of thm2 1) of
  22.133 +            [] =>
  22.134 +              let val (thm, ctxt') = assume thm1 ctxt
  22.135 +              in ((is, thms), (ctxt', Inttab.update (id, (fixes, thm)) ptab)) end
  22.136 +          | ithms => fold (add1 id fixes thm1) ithms cx)
  22.137 +        end
  22.138 +      else
  22.139 +        cx
  22.140 +  in fold add steps (([], []), (ctxt, Inttab.empty)) end
  22.141 +
  22.142 +end
  22.143 +
  22.144 +(* |- (EX x. P x) = P c     |- ~ (ALL x. P x) = ~ P c *)
  22.145 +local
  22.146 +  val sk_rules = @{lemma
  22.147 +    "c = (SOME x. P x) ==> (EX x. P x) = P c"
  22.148 +    "c = (SOME x. ~ P x) ==> (~ (ALL x. P x)) = (~ P c)"
  22.149 +    by (metis someI_ex)+}
  22.150 +in
  22.151 +
  22.152 +fun discharge_sk_tac i st =
  22.153 +  (rtac @{thm trans} i
  22.154 +   THEN resolve_tac sk_rules i
  22.155 +   THEN (rtac @{thm refl} ORELSE' discharge_sk_tac) (i+1)
  22.156 +   THEN rtac @{thm refl} i) st
  22.157 +
  22.158 +end
  22.159 +
  22.160 +fun make_discharge_rules rules = rules @ [@{thm allI}, @{thm refl},
  22.161 +  @{thm reflexive}, Z3_New_Proof_Literals.true_thm]
  22.162 +
  22.163 +val intro_def_rules = @{lemma
  22.164 +  "(~ P | P) & (P | ~ P)"
  22.165 +  "(P | ~ P) & (~ P | P)"
  22.166 +  by fast+}
  22.167 +
  22.168 +fun discharge_assms_tac rules =
  22.169 +  REPEAT (HEADGOAL (resolve_tac (intro_def_rules @ rules) ORELSE' SOLVED' discharge_sk_tac))
  22.170 +  
  22.171 +fun discharge_assms ctxt rules thm =
  22.172 +  (if Thm.nprems_of thm = 0 then
  22.173 +     thm
  22.174 +   else
  22.175 +     (case Seq.pull (discharge_assms_tac rules thm) of
  22.176 +       SOME (thm', _) => thm'
  22.177 +     | NONE => raise THM ("failed to discharge premise", 1, [thm])))
  22.178 +  |> Goal.norm_result ctxt
  22.179 +
  22.180 +fun discharge rules outer_ctxt inner_ctxt =
  22.181 +  singleton (Proof_Context.export inner_ctxt outer_ctxt)
  22.182 +  #> discharge_assms outer_ctxt (make_discharge_rules rules)
  22.183 +
  22.184 +fun replay outer_ctxt
  22.185 +    ({context=ctxt, typs, terms, rewrite_rules, assms} : SMT2_Translate.replay_data) output =
  22.186 +  let
  22.187 +    val (steps, ctxt1) = Z3_New_Proof.parse typs terms output ctxt
  22.188 +    val ctxt2 = put_simpset (Z3_New_Proof_Tools.make_simpset ctxt1 []) ctxt1
  22.189 +    val ((is, rules), (ctxt3, assumed)) = add_asserted outer_ctxt rewrite_rules assms steps ctxt2
  22.190 +    val proofs = fold (replay_step ctxt3 assumed) steps assumed
  22.191 +    val (_, Z3_New_Proof.Z3_Step {id, ...}) = split_last steps
  22.192 +  in
  22.193 +    if Config.get ctxt3 SMT2_Config.filter_only_facts then (is, TrueI)
  22.194 +    else ([], Inttab.lookup proofs id |> the |> snd |> discharge rules outer_ctxt ctxt3)
  22.195 +  end
  22.196 +
  22.197 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof_rules.ML	Thu Mar 13 13:18:13 2014 +0100
    23.3 @@ -0,0 +1,56 @@
    23.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof_rules.ML
    23.5 +    Author:     Sascha Boehme, TU Muenchen
    23.6 +
    23.7 +Custom rules for Z3 proof replay.
    23.8 +*)
    23.9 +
   23.10 +signature Z3_NEW_PROOF_RULES =
   23.11 +sig
   23.12 +  val apply: Proof.context -> cterm -> thm option
   23.13 +end
   23.14 +
   23.15 +structure Z3_New_Proof_Rules: Z3_NEW_PROOF_RULES =
   23.16 +struct
   23.17 +
   23.18 +val eq = Thm.eq_thm
   23.19 +
   23.20 +structure Data = Generic_Data
   23.21 +(
   23.22 +  type T = thm Net.net
   23.23 +  val empty = Net.empty
   23.24 +  val extend = I
   23.25 +  val merge = Net.merge eq
   23.26 +)
   23.27 +
   23.28 +fun maybe_instantiate ct thm =
   23.29 +  try Thm.first_order_match (Thm.cprop_of thm, ct)
   23.30 +  |> Option.map (fn inst => Thm.instantiate inst thm)
   23.31 +
   23.32 +fun apply ctxt ct =
   23.33 +  let
   23.34 +    val net = Data.get (Context.Proof ctxt)
   23.35 +    val xthms = Net.match_term net (Thm.term_of ct)
   23.36 +
   23.37 +    fun select ct = map_filter (maybe_instantiate ct) xthms 
   23.38 +    fun select' ct =
   23.39 +      let val thm = Thm.trivial ct
   23.40 +      in map_filter (try (fn rule => rule COMP thm)) xthms end
   23.41 +
   23.42 +  in try hd (case select ct of [] => select' ct | xthms' => xthms') end
   23.43 +
   23.44 +val prep = `Thm.prop_of
   23.45 +
   23.46 +fun ins thm net = Net.insert_term eq (prep thm) net handle Net.INSERT => net
   23.47 +fun del thm net = Net.delete_term eq (prep thm) net handle Net.DELETE => net
   23.48 +
   23.49 +val add = Thm.declaration_attribute (Data.map o ins)
   23.50 +val del = Thm.declaration_attribute (Data.map o del)
   23.51 +
   23.52 +val name = Binding.name "z3_new_rule"
   23.53 +
   23.54 +val description = "declaration of Z3 proof rules"
   23.55 +
   23.56 +val _ = Theory.setup (Attrib.setup name (Attrib.add_del add del) description #>
   23.57 +  Global_Theory.add_thms_dynamic (name, Net.content o Data.get))
   23.58 +
   23.59 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Tools/SMT2/z3_new_proof_tools.ML	Thu Mar 13 13:18:13 2014 +0100
    24.3 @@ -0,0 +1,156 @@
    24.4 +(*  Title:      HOL/Tools/SMT2/z3_new_proof_tools.ML
    24.5 +    Author:     Sascha Boehme, TU Muenchen
    24.6 +
    24.7 +Helper functions required for Z3 proof replay.
    24.8 +*)
    24.9 +
   24.10 +signature Z3_NEW_PROOF_TOOLS =
   24.11 +sig
   24.12 +  (*theorem nets*)
   24.13 +  val thm_net_of: ('a -> thm) -> 'a list -> 'a Net.net
   24.14 +  val net_instances: (int * thm) Net.net -> cterm -> (int * thm) list
   24.15 +
   24.16 +  (*proof combinators*)
   24.17 +  val under_assumption: (thm -> thm) -> cterm -> thm
   24.18 +  val discharge: thm -> thm -> thm
   24.19 +
   24.20 +  (*a faster COMP*)
   24.21 +  type compose_data
   24.22 +  val precompose: (cterm -> cterm list) -> thm -> compose_data
   24.23 +  val precompose2: (cterm -> cterm * cterm) -> thm -> compose_data
   24.24 +  val compose: compose_data -> thm -> thm
   24.25 +
   24.26 +  (*simpset*)
   24.27 +  val add_simproc: Simplifier.simproc -> Context.generic -> Context.generic
   24.28 +  val make_simpset: Proof.context -> thm list -> simpset
   24.29 +end
   24.30 +
   24.31 +structure Z3_New_Proof_Tools: Z3_NEW_PROOF_TOOLS =
   24.32 +struct
   24.33 +
   24.34 +
   24.35 +
   24.36 +(* theorem nets *)
   24.37 +
   24.38 +fun thm_net_of f xthms =
   24.39 +  let fun insert xthm = Net.insert_term (K false) (Thm.prop_of (f xthm), xthm)
   24.40 +  in fold insert xthms Net.empty end
   24.41 +
   24.42 +fun maybe_instantiate ct thm =
   24.43 +  try Thm.first_order_match (Thm.cprop_of thm, ct)
   24.44 +  |> Option.map (fn inst => Thm.instantiate inst thm)
   24.45 +
   24.46 +local
   24.47 +  fun instances_from_net match f net ct =
   24.48 +    let
   24.49 +      val lookup = if match then Net.match_term else Net.unify_term
   24.50 +      val xthms = lookup net (Thm.term_of ct)
   24.51 +      fun select ct = map_filter (f (maybe_instantiate ct)) xthms 
   24.52 +      fun select' ct =
   24.53 +        let val thm = Thm.trivial ct
   24.54 +        in map_filter (f (try (fn rule => rule COMP thm))) xthms end
   24.55 +    in (case select ct of [] => select' ct | xthms' => xthms') end
   24.56 +in
   24.57 +
   24.58 +fun net_instances net =
   24.59 +  instances_from_net false (fn f => fn (i, thm) => Option.map (pair i) (f thm))
   24.60 +    net
   24.61 +
   24.62 +end
   24.63 +
   24.64 +
   24.65 +
   24.66 +(* proof combinators *)
   24.67 +
   24.68 +fun under_assumption f ct =
   24.69 +  let val ct' = SMT2_Utils.mk_cprop ct
   24.70 +  in Thm.implies_intr ct' (f (Thm.assume ct')) end
   24.71 +
   24.72 +fun discharge p pq = Thm.implies_elim pq p
   24.73 +
   24.74 +
   24.75 +
   24.76 +(* a faster COMP *)
   24.77 +
   24.78 +type compose_data = cterm list * (cterm -> cterm list) * thm
   24.79 +
   24.80 +fun list2 (x, y) = [x, y]
   24.81 +
   24.82 +fun precompose f rule = (f (Thm.cprem_of rule 1), f, rule)
   24.83 +fun precompose2 f rule = precompose (list2 o f) rule
   24.84 +
   24.85 +fun compose (cvs, f, rule) thm =
   24.86 +  discharge thm (Thm.instantiate ([], cvs ~~ f (Thm.cprop_of thm)) rule)
   24.87 +
   24.88 +
   24.89 +
   24.90 +(* simpset *)
   24.91 +
   24.92 +local
   24.93 +  val antisym_le1 = mk_meta_eq @{thm order_class.antisym_conv}
   24.94 +  val antisym_le2 = mk_meta_eq @{thm linorder_class.antisym_conv2}
   24.95 +  val antisym_less1 = mk_meta_eq @{thm linorder_class.antisym_conv1}
   24.96 +  val antisym_less2 = mk_meta_eq @{thm linorder_class.antisym_conv3}
   24.97 +
   24.98 +  fun eq_prop t thm = HOLogic.mk_Trueprop t aconv Thm.prop_of thm
   24.99 +  fun dest_binop ((c as Const _) $ t $ u) = (c, t, u)
  24.100 +    | dest_binop t = raise TERM ("dest_binop", [t])
  24.101 +
  24.102 +  fun prove_antisym_le ctxt t =
  24.103 +    let
  24.104 +      val (le, r, s) = dest_binop t
  24.105 +      val less = Const (@{const_name less}, Term.fastype_of le)
  24.106 +      val prems = Simplifier.prems_of ctxt
  24.107 +    in
  24.108 +      (case find_first (eq_prop (le $ s $ r)) prems of
  24.109 +        NONE =>
  24.110 +          find_first (eq_prop (HOLogic.mk_not (less $ r $ s))) prems
  24.111 +          |> Option.map (fn thm => thm RS antisym_less1)
  24.112 +      | SOME thm => SOME (thm RS antisym_le1))
  24.113 +    end
  24.114 +    handle THM _ => NONE
  24.115 +
  24.116 +  fun prove_antisym_less ctxt t =
  24.117 +    let
  24.118 +      val (less, r, s) = dest_binop (HOLogic.dest_not t)
  24.119 +      val le = Const (@{const_name less_eq}, Term.fastype_of less)
  24.120 +      val prems = Simplifier.prems_of ctxt
  24.121 +    in
  24.122 +      (case find_first (eq_prop (le $ r $ s)) prems of
  24.123 +        NONE =>
  24.124 +          find_first (eq_prop (HOLogic.mk_not (less $ s $ r))) prems
  24.125 +          |> Option.map (fn thm => thm RS antisym_less2)
  24.126 +      | SOME thm => SOME (thm RS antisym_le2))
  24.127 +  end
  24.128 +  handle THM _ => NONE
  24.129 +
  24.130 +  val basic_simpset =
  24.131 +    simpset_of (put_simpset HOL_ss @{context}
  24.132 +      addsimps @{thms field_simps times_divide_eq_right times_divide_eq_left arith_special
  24.133 +        arith_simps rel_simps array_rules z3div_def z3mod_def}
  24.134 +      addsimprocs [@{simproc binary_int_div}, @{simproc binary_int_mod},
  24.135 +        Simplifier.simproc_global @{theory} "fast_int_arith" [
  24.136 +          "(m::int) < n", "(m::int) <= n", "(m::int) = n"] Lin_Arith.simproc,
  24.137 +        Simplifier.simproc_global @{theory} "antisym_le" ["(x::'a::order) <= y"] prove_antisym_le,
  24.138 +        Simplifier.simproc_global @{theory} "antisym_less" ["~ (x::'a::linorder) < y"]
  24.139 +          prove_antisym_less])
  24.140 +
  24.141 +  structure Simpset = Generic_Data
  24.142 +  (
  24.143 +    type T = simpset
  24.144 +    val empty = basic_simpset
  24.145 +    val extend = I
  24.146 +    val merge = Simplifier.merge_ss
  24.147 +  )
  24.148 +in
  24.149 +
  24.150 +fun add_simproc simproc context =
  24.151 +  Simpset.map (simpset_map (Context.proof_of context)
  24.152 +    (fn ctxt => ctxt addsimprocs [simproc])) context
  24.153 +
  24.154 +fun make_simpset ctxt rules =
  24.155 +  simpset_of (put_simpset (Simpset.get (Context.Proof ctxt)) ctxt addsimps rules)
  24.156 +
  24.157 +end
  24.158 +
  24.159 +end
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/Tools/SMT2/z3_new_real.ML	Thu Mar 13 13:18:13 2014 +0100
    25.3 @@ -0,0 +1,32 @@
    25.4 +(*  Title:      HOL/Tools/SMT2/z3_new_real.ML
    25.5 +    Author:     Sascha Boehme, TU Muenchen
    25.6 +
    25.7 +Z3 setup for reals.
    25.8 +*)
    25.9 +
   25.10 +structure Z3_New_Real: sig end =
   25.11 +struct
   25.12 +
   25.13 +fun real_type_parser (SMTLIB2.Sym "Real", []) = SOME @{typ Real.real}
   25.14 +  | real_type_parser _ = NONE
   25.15 +
   25.16 +fun real_term_parser (SMTLIB2.Dec (i, 0), []) = SOME (HOLogic.mk_number @{typ Real.real} i)
   25.17 +  | real_term_parser (SMTLIB2.Sym "/", [t1, t2]) =
   25.18 +      SOME (@{term "inverse_class.divide :: real => _"} $ t1 $ t2)
   25.19 +  | real_term_parser (SMTLIB2.Sym "to_real", [t]) = SOME (@{term "Real.real :: int => _"} $ t)
   25.20 +  | real_term_parser _ = NONE
   25.21 +
   25.22 +fun abstract abs t =
   25.23 +  (case t of
   25.24 +    (c as @{term "inverse_class.divide :: real => _"}) $ t1 $ t2 =>
   25.25 +      abs t1 ##>> abs t2 #>> (fn (u1, u2) => SOME (c $ u1 $ u2))
   25.26 +  | (c as @{term "Real.real :: int => _"}) $ t =>
   25.27 +      abs t #>> (fn u => SOME (c $ u))
   25.28 +  | _ => pair NONE)
   25.29 +
   25.30 +val _ = Theory.setup (Context.theory_map (
   25.31 +  Z3_New_Proof.add_type_parser real_type_parser #>
   25.32 +  Z3_New_Proof.add_term_parser real_term_parser #>
   25.33 +  Z3_New_Proof_Methods.add_arith_abstracter abstract))
   25.34 +
   25.35 +end
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/Word/Tools/smt2_word.ML	Thu Mar 13 13:18:13 2014 +0100
    26.3 @@ -0,0 +1,144 @@
    26.4 +(*  Title:      HOL/Word/Tools/smt2_word.ML
    26.5 +    Author:     Sascha Boehme, TU Muenchen
    26.6 +
    26.7 +SMT setup for words.
    26.8 +*)
    26.9 +
   26.10 +structure SMT2_Word: sig end =
   26.11 +struct
   26.12 +
   26.13 +open Word_Lib
   26.14 +
   26.15 +(* SMT-LIB logic *)
   26.16 +
   26.17 +fun smtlib_logic ts =
   26.18 +  if exists (Term.exists_type (Term.exists_subtype is_wordT)) ts
   26.19 +  then SOME "QF_AUFBV"
   26.20 +  else NONE
   26.21 +
   26.22 +
   26.23 +(* SMT-LIB builtins *)
   26.24 +
   26.25 +local
   26.26 +  val smtlib2C = SMTLIB2_Interface.smtlib2C
   26.27 +
   26.28 +  val wordT = @{typ "'a::len word"}
   26.29 +
   26.30 +  fun index1 s i = "(_ " ^ s ^ " " ^ string_of_int i ^ ")"
   26.31 +  fun index2 s i j = "(_ " ^ s ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ ")"
   26.32 +
   26.33 +  fun word_typ (Type (@{type_name word}, [T])) = Option.map (index1 "BitVec") (try dest_binT T)
   26.34 +    | word_typ _ = NONE
   26.35 +
   26.36 +  fun word_num (Type (@{type_name word}, [T])) k =
   26.37 +        Option.map (index1 ("bv" ^ string_of_int k)) (try dest_binT T)
   26.38 +    | word_num _ _ = NONE
   26.39 +
   26.40 +  fun if_fixed pred m n T ts =
   26.41 +    let val (Us, U) = Term.strip_type T
   26.42 +    in
   26.43 +      if pred (U, Us) then
   26.44 +        SOME (n, length Us, ts, Term.list_comb o pair (Const (m, T)))
   26.45 +      else NONE
   26.46 +    end
   26.47 +
   26.48 +  fun if_fixed_all m = if_fixed (forall (can dest_wordT) o (op ::)) m
   26.49 +  fun if_fixed_args m = if_fixed (forall (can dest_wordT) o snd) m
   26.50 +
   26.51 +  fun add_word_fun f (t, n) =
   26.52 +    let val (m, _) = Term.dest_Const t
   26.53 +    in SMT2_Builtin.add_builtin_fun smtlib2C (Term.dest_Const t, K (f m n)) end
   26.54 +
   26.55 +  fun hd2 xs = hd (tl xs)
   26.56 +
   26.57 +  fun mk_nat i = @{const nat} $ HOLogic.mk_number @{typ nat} i
   26.58 +
   26.59 +  fun dest_nat (@{const nat} $ n) = snd (HOLogic.dest_number n)
   26.60 +    | dest_nat t = raise TERM ("not a natural number", [t])
   26.61 +
   26.62 +  fun mk_shift c [t, u] = Const c $ t $ mk_nat (snd (HOLogic.dest_number u))
   26.63 +    | mk_shift c ts = raise TERM ("bad arguments", Const c :: ts)
   26.64 +
   26.65 +  fun shift m n T ts =
   26.66 +    let val U = Term.domain_type T
   26.67 +    in
   26.68 +      (case (can dest_wordT U, try (dest_nat o hd2) ts) of
   26.69 +        (true, SOME i) =>
   26.70 +          SOME (n, 2, [hd ts, HOLogic.mk_number U i], mk_shift (m, T))
   26.71 +      | _ => NONE)   (* FIXME: also support non-numerical shifts *)
   26.72 +    end
   26.73 +
   26.74 +  fun mk_extract c i ts = Term.list_comb (Const c, mk_nat i :: ts)
   26.75 +
   26.76 +  fun extract m n T ts =
   26.77 +    let val U = Term.range_type (Term.range_type T)
   26.78 +    in
   26.79 +      (case (try (dest_nat o hd) ts, try dest_wordT U) of
   26.80 +        (SOME lb, SOME i) =>
   26.81 +          SOME (index2 n (i + lb - 1) lb, 1, tl ts, mk_extract (m, T) lb)
   26.82 +      | _ => NONE)
   26.83 +    end
   26.84 +
   26.85 +  fun mk_extend c ts = Term.list_comb (Const c, ts)
   26.86 +
   26.87 +  fun extend m n T ts =
   26.88 +    let val (U1, U2) = Term.dest_funT T
   26.89 +    in
   26.90 +      (case (try dest_wordT U1, try dest_wordT U2) of
   26.91 +        (SOME i, SOME j) =>
   26.92 +          if j-i >= 0 then SOME (index1 n (j-i), 1, ts, mk_extend (m, T))
   26.93 +          else NONE
   26.94 +      | _ => NONE)
   26.95 +    end
   26.96 +
   26.97 +  fun mk_rotate c i ts = Term.list_comb (Const c, mk_nat i :: ts)
   26.98 +
   26.99 +  fun rotate m n T ts =
  26.100 +    let val U = Term.domain_type (Term.range_type T)
  26.101 +    in
  26.102 +      (case (can dest_wordT U, try (dest_nat o hd) ts) of
  26.103 +        (true, SOME i) => SOME (index1 n i, 1, tl ts, mk_rotate (m, T) i)
  26.104 +      | _ => NONE)
  26.105 +    end
  26.106 +in
  26.107 +
  26.108 +val setup_builtins =
  26.109 +  SMT2_Builtin.add_builtin_typ smtlib2C (wordT, word_typ, word_num) #>
  26.110 +  fold (add_word_fun if_fixed_all) [
  26.111 +    (@{term "uminus :: 'a::len word => _"}, "bvneg"),
  26.112 +    (@{term "plus :: 'a::len word => _"}, "bvadd"),
  26.113 +    (@{term "minus :: 'a::len word => _"}, "bvsub"),
  26.114 +    (@{term "times :: 'a::len word => _"}, "bvmul"),
  26.115 +    (@{term "bitNOT :: 'a::len word => _"}, "bvnot"),
  26.116 +    (@{term "bitAND :: 'a::len word => _"}, "bvand"),
  26.117 +    (@{term "bitOR :: 'a::len word => _"}, "bvor"),
  26.118 +    (@{term "bitXOR :: 'a::len word => _"}, "bvxor"),
  26.119 +    (@{term "word_cat :: 'a::len word => _"}, "concat") ] #>
  26.120 +  fold (add_word_fun shift) [
  26.121 +    (@{term "shiftl :: 'a::len word => _ "}, "bvshl"),
  26.122 +    (@{term "shiftr :: 'a::len word => _"}, "bvlshr"),
  26.123 +    (@{term "sshiftr :: 'a::len word => _"}, "bvashr") ] #>
  26.124 +  add_word_fun extract
  26.125 +    (@{term "slice :: _ => 'a::len word => _"}, "extract") #>
  26.126 +  fold (add_word_fun extend) [
  26.127 +    (@{term "ucast :: 'a::len word => _"}, "zero_extend"),
  26.128 +    (@{term "scast :: 'a::len word => _"}, "sign_extend") ] #>
  26.129 +  fold (add_word_fun rotate) [
  26.130 +    (@{term word_rotl}, "rotate_left"),
  26.131 +    (@{term word_rotr}, "rotate_right") ] #>
  26.132 +  fold (add_word_fun if_fixed_args) [
  26.133 +    (@{term "less :: 'a::len word => _"}, "bvult"),
  26.134 +    (@{term "less_eq :: 'a::len word => _"}, "bvule"),
  26.135 +    (@{term word_sless}, "bvslt"),
  26.136 +    (@{term word_sle}, "bvsle") ]
  26.137 +
  26.138 +end
  26.139 +
  26.140 +
  26.141 +(* setup *)
  26.142 +
  26.143 +val _ = Theory.setup (Context.theory_map (
  26.144 +  SMTLIB2_Interface.add_logic (20, smtlib_logic) #>
  26.145 +  setup_builtins))
  26.146 +
  26.147 +end
    27.1 --- a/src/HOL/Word/Word.thy	Thu Mar 13 08:56:08 2014 +0100
    27.2 +++ b/src/HOL/Word/Word.thy	Thu Mar 13 13:18:13 2014 +0100
    27.3 @@ -4738,6 +4738,7 @@
    27.4  ML_file "Tools/word_lib.ML"
    27.5  ML_file "Tools/smt_word.ML"
    27.6  setup SMT_Word.setup
    27.7 +ML_file "Tools/smt2_word.ML"
    27.8  
    27.9  hide_const (open) Word
   27.10