renamed new SMT module from 'SMT2' to 'SMT'
authorblanchet
Thu Aug 28 00:40:38 2014 +0200 (2014-08-28)
changeset 580613d060f43accb
parent 58060 835b5443b978
child 58062 f4d8987656b9
renamed new SMT module from 'SMT2' to 'SMT'
src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML
src/HOL/Real.thy
src/HOL/SMT.thy
src/HOL/SMT2.thy
src/HOL/SMT_Examples/Boogie.thy
src/HOL/SMT_Examples/SMT_Examples.thy
src/HOL/SMT_Examples/SMT_Tests.thy
src/HOL/SMT_Examples/SMT_Word_Examples.thy
src/HOL/SMT_Examples/boogie.ML
src/HOL/Sledgehammer.thy
src/HOL/TPTP/mash_eval.ML
src/HOL/Tools/SMT/smt_builtin.ML
src/HOL/Tools/SMT/smt_config.ML
src/HOL/Tools/SMT/smt_datatypes.ML
src/HOL/Tools/SMT/smt_failure.ML
src/HOL/Tools/SMT/smt_normalize.ML
src/HOL/Tools/SMT/smt_real.ML
src/HOL/Tools/SMT/smt_solver.ML
src/HOL/Tools/SMT/smt_systems.ML
src/HOL/Tools/SMT/smt_translate.ML
src/HOL/Tools/SMT/smt_util.ML
src/HOL/Tools/SMT/smtlib.ML
src/HOL/Tools/SMT/smtlib_interface.ML
src/HOL/Tools/SMT/smtlib_isar.ML
src/HOL/Tools/SMT/smtlib_proof.ML
src/HOL/Tools/SMT/verit_isar.ML
src/HOL/Tools/SMT/verit_proof.ML
src/HOL/Tools/SMT/verit_proof_parse.ML
src/HOL/Tools/SMT/z3_interface.ML
src/HOL/Tools/SMT/z3_isar.ML
src/HOL/Tools/SMT/z3_proof.ML
src/HOL/Tools/SMT/z3_real.ML
src/HOL/Tools/SMT/z3_replay.ML
src/HOL/Tools/SMT/z3_replay_literals.ML
src/HOL/Tools/SMT/z3_replay_methods.ML
src/HOL/Tools/SMT/z3_replay_rules.ML
src/HOL/Tools/SMT/z3_replay_util.ML
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_solver.ML
src/HOL/Tools/SMT2/smt2_systems.ML
src/HOL/Tools/SMT2/smt2_translate.ML
src/HOL/Tools/SMT2/smt2_util.ML
src/HOL/Tools/SMT2/smtlib2.ML
src/HOL/Tools/SMT2/smtlib2_interface.ML
src/HOL/Tools/SMT2/smtlib2_isar.ML
src/HOL/Tools/SMT2/smtlib2_proof.ML
src/HOL/Tools/SMT2/verit_isar.ML
src/HOL/Tools/SMT2/verit_proof.ML
src/HOL/Tools/SMT2/verit_proof_parse.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_real.ML
src/HOL/Tools/SMT2/z3_new_replay.ML
src/HOL/Tools/SMT2/z3_new_replay_literals.ML
src/HOL/Tools/SMT2/z3_new_replay_methods.ML
src/HOL/Tools/SMT2/z3_new_replay_rules.ML
src/HOL/Tools/SMT2/z3_new_replay_util.ML
src/HOL/Tools/Sledgehammer/sledgehammer_isar.ML
src/HOL/Tools/Sledgehammer/sledgehammer_proof_methods.ML
src/HOL/Tools/Sledgehammer/sledgehammer_prover.ML
src/HOL/Tools/Sledgehammer/sledgehammer_prover_minimize.ML
src/HOL/Tools/Sledgehammer/sledgehammer_prover_smt.ML
src/HOL/Tools/Sledgehammer/sledgehammer_prover_smt2.ML
src/HOL/Word/Tools/smt2_word.ML
src/HOL/Word/Tools/smt_word.ML
src/HOL/Word/Word.thy
     1.1 --- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Thu Aug 28 00:40:38 2014 +0200
     1.2 +++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML	Thu Aug 28 00:40:38 2014 +0200
     1.3 @@ -359,7 +359,7 @@
     1.4          Config.put Sledgehammer_Prover_ATP.atp_dest_dir dir
     1.5          #> Config.put Sledgehammer_Prover_ATP.atp_problem_prefix
     1.6            ("prob_" ^ str0 (Position.line_of pos) ^ "__")
     1.7 -        #> Config.put SMT2_Config.debug_files
     1.8 +        #> Config.put SMT_Config.debug_files
     1.9            (dir ^ "/" ^ Name.desymbolize (SOME false) (ATP_Util.timestamp ()) ^ "_"
    1.10            ^ serial_string ())
    1.11        | set_file_name NONE = I
    1.12 @@ -541,9 +541,9 @@
    1.13            ORELSE' sledge_tac 0.2 ATP_Proof.eN "poly_guards??"
    1.14            ORELSE' sledge_tac 0.2 ATP_Proof.spassN "mono_native"
    1.15            ORELSE' sledge_tac 0.2 ATP_Proof.z3_tptpN "poly_tags??"
    1.16 -          ORELSE' SMT2_Solver.smt2_tac ctxt thms
    1.17 +          ORELSE' SMT_Solver.smt_tac ctxt thms
    1.18          else if !meth = "smt" then
    1.19 -          SMT2_Solver.smt2_tac ctxt thms
    1.20 +          SMT_Solver.smt_tac ctxt thms
    1.21          else if full then
    1.22            Metis_Tactic.metis_tac [ATP_Proof_Reconstruct.full_typesN]
    1.23              ATP_Proof_Reconstruct.default_metis_lam_trans ctxt thms
     2.1 --- a/src/HOL/Real.thy	Thu Aug 28 00:40:38 2014 +0200
     2.2 +++ b/src/HOL/Real.thy	Thu Aug 28 00:40:38 2014 +0200
     2.3 @@ -2180,10 +2180,10 @@
     2.4  
     2.5  subsection {* Setup for SMT *}
     2.6  
     2.7 -ML_file "Tools/SMT2/smt2_real.ML"
     2.8 -ML_file "Tools/SMT2/z3_new_real.ML"
     2.9 +ML_file "Tools/SMT/smt_real.ML"
    2.10 +ML_file "Tools/SMT/z3_real.ML"
    2.11  
    2.12 -lemma [z3_new_rule]:
    2.13 +lemma [z3_rule]:
    2.14    "0 + (x::real) = x"
    2.15    "x + 0 = x"
    2.16    "0 * x = 0"
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/SMT.thy	Thu Aug 28 00:40:38 2014 +0200
     3.3 @@ -0,0 +1,379 @@
     3.4 +(*  Title:      HOL/SMT.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 SMT
    3.11 +imports Divides
    3.12 +keywords "smt_status" :: diag
    3.13 +begin
    3.14 +
    3.15 +subsection {* Triggers for quantifier instantiation *}
    3.16 +
    3.17 +text {*
    3.18 +Some SMT solvers support patterns as a quantifier instantiation
    3.19 +heuristics. Patterns may either be positive terms (tagged by "pat")
    3.20 +triggering quantifier instantiations -- when the solver finds a
    3.21 +term matching a positive pattern, it instantiates the corresponding
    3.22 +quantifier accordingly -- or negative terms (tagged by "nopat")
    3.23 +inhibiting quantifier instantiations. A list of patterns
    3.24 +of the same kind is called a multipattern, and all patterns in a
    3.25 +multipattern are considered conjunctively for quantifier instantiation.
    3.26 +A list of multipatterns is called a trigger, and their multipatterns
    3.27 +act disjunctively during quantifier instantiation. Each multipattern
    3.28 +should mention at least all quantified variables of the preceding
    3.29 +quantifier block.
    3.30 +*}
    3.31 +
    3.32 +typedecl 'a symb_list
    3.33 +
    3.34 +consts
    3.35 +  Symb_Nil :: "'a symb_list"
    3.36 +  Symb_Cons :: "'a \<Rightarrow> 'a symb_list \<Rightarrow> 'a symb_list"
    3.37 +
    3.38 +typedecl pattern
    3.39 +
    3.40 +consts
    3.41 +  pat :: "'a \<Rightarrow> pattern"
    3.42 +  nopat :: "'a \<Rightarrow> pattern"
    3.43 +
    3.44 +definition trigger :: "pattern symb_list symb_list \<Rightarrow> bool \<Rightarrow> bool" where
    3.45 +  "trigger _ P = P"
    3.46 +
    3.47 +
    3.48 +subsection {* Higher-order encoding *}
    3.49 +
    3.50 +text {*
    3.51 +Application is made explicit for constants occurring with varying
    3.52 +numbers of arguments. This is achieved by the introduction of the
    3.53 +following constant.
    3.54 +*}
    3.55 +
    3.56 +definition fun_app :: "'a \<Rightarrow> 'a" where "fun_app f = f"
    3.57 +
    3.58 +text {*
    3.59 +Some solvers support a theory of arrays which can be used to encode
    3.60 +higher-order functions. The following set of lemmas specifies the
    3.61 +properties of such (extensional) arrays.
    3.62 +*}
    3.63 +
    3.64 +lemmas array_rules = ext fun_upd_apply fun_upd_same fun_upd_other  fun_upd_upd fun_app_def
    3.65 +
    3.66 +
    3.67 +subsection {* Normalization *}
    3.68 +
    3.69 +lemma case_bool_if[abs_def]: "case_bool x y P = (if P then x else y)"
    3.70 +  by simp
    3.71 +
    3.72 +lemmas Ex1_def_raw = Ex1_def[abs_def]
    3.73 +lemmas Ball_def_raw = Ball_def[abs_def]
    3.74 +lemmas Bex_def_raw = Bex_def[abs_def]
    3.75 +lemmas abs_if_raw = abs_if[abs_def]
    3.76 +lemmas min_def_raw = min_def[abs_def]
    3.77 +lemmas max_def_raw = max_def[abs_def]
    3.78 +
    3.79 +
    3.80 +subsection {* Integer division and modulo for Z3 *}
    3.81 +
    3.82 +text {*
    3.83 +The following Z3-inspired definitions are overspecified for the case where @{text "l = 0"}. This
    3.84 +Schönheitsfehler is corrected in the @{text div_as_z3div} and @{text mod_as_z3mod} theorems.
    3.85 +*}
    3.86 +
    3.87 +definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
    3.88 +  "z3div k l = (if l \<ge> 0 then k div l else - (k div - l))"
    3.89 +
    3.90 +definition z3mod :: "int \<Rightarrow> int \<Rightarrow> int" where
    3.91 +  "z3mod k l = k mod (if l \<ge> 0 then l else - l)"
    3.92 +
    3.93 +lemma div_as_z3div:
    3.94 +  "\<forall>k l. k div l = (if l = 0 then 0 else if l > 0 then z3div k l else z3div (- k) (- l))"
    3.95 +  by (simp add: z3div_def)
    3.96 +
    3.97 +lemma mod_as_z3mod:
    3.98 +  "\<forall>k l. k mod l = (if l = 0 then k else if l > 0 then z3mod k l else - z3mod (- k) (- l))"
    3.99 +  by (simp add: z3mod_def)
   3.100 +
   3.101 +
   3.102 +subsection {* Setup *}
   3.103 +
   3.104 +ML_file "Tools/SMT/smt_util.ML"
   3.105 +ML_file "Tools/SMT/smt_failure.ML"
   3.106 +ML_file "Tools/SMT/smt_config.ML"
   3.107 +ML_file "Tools/SMT/smt_builtin.ML"
   3.108 +ML_file "Tools/SMT/smt_datatypes.ML"
   3.109 +ML_file "Tools/SMT/smt_normalize.ML"
   3.110 +ML_file "Tools/SMT/smt_translate.ML"
   3.111 +ML_file "Tools/SMT/smtlib.ML"
   3.112 +ML_file "Tools/SMT/smtlib_interface.ML"
   3.113 +ML_file "Tools/SMT/smtlib_proof.ML"
   3.114 +ML_file "Tools/SMT/smtlib_isar.ML"
   3.115 +ML_file "Tools/SMT/z3_proof.ML"
   3.116 +ML_file "Tools/SMT/z3_isar.ML"
   3.117 +ML_file "Tools/SMT/smt_solver.ML"
   3.118 +ML_file "Tools/SMT/z3_interface.ML"
   3.119 +ML_file "Tools/SMT/z3_replay_util.ML"
   3.120 +ML_file "Tools/SMT/z3_replay_literals.ML"
   3.121 +ML_file "Tools/SMT/z3_replay_rules.ML"
   3.122 +ML_file "Tools/SMT/z3_replay_methods.ML"
   3.123 +ML_file "Tools/SMT/z3_replay.ML"
   3.124 +ML_file "Tools/SMT/verit_proof.ML"
   3.125 +ML_file "Tools/SMT/verit_isar.ML"
   3.126 +ML_file "Tools/SMT/verit_proof_parse.ML"
   3.127 +ML_file "Tools/SMT/smt_systems.ML"
   3.128 +
   3.129 +method_setup smt = {*
   3.130 +  Scan.optional Attrib.thms [] >>
   3.131 +    (fn thms => fn ctxt =>
   3.132 +      METHOD (fn facts => HEADGOAL (SMT_Solver.smt_tac ctxt (thms @ facts))))
   3.133 +*} "apply an SMT solver to the current goal (based on SMT-LIB 2)"
   3.134 +
   3.135 +
   3.136 +subsection {* Configuration *}
   3.137 +
   3.138 +text {*
   3.139 +The current configuration can be printed by the command
   3.140 +@{text smt_status}, which shows the values of most options.
   3.141 +*}
   3.142 +
   3.143 +
   3.144 +subsection {* General configuration options *}
   3.145 +
   3.146 +text {*
   3.147 +The option @{text smt_solver} can be used to change the target SMT
   3.148 +solver. The possible values can be obtained from the @{text smt_status}
   3.149 +command.
   3.150 +
   3.151 +Due to licensing restrictions, Z3 is not enabled by default. Z3 is free
   3.152 +for non-commercial applications and can be enabled by setting Isabelle
   3.153 +system option @{text z3_non_commercial} to @{text yes}.
   3.154 +*}
   3.155 +
   3.156 +declare [[smt_solver = z3]]
   3.157 +
   3.158 +text {*
   3.159 +Since SMT solvers are potentially nonterminating, there is a timeout
   3.160 +(given in seconds) to restrict their runtime.
   3.161 +*}
   3.162 +
   3.163 +declare [[smt_timeout = 20]]
   3.164 +
   3.165 +text {*
   3.166 +SMT solvers apply randomized heuristics. In case a problem is not
   3.167 +solvable by an SMT solver, changing the following option might help.
   3.168 +*}
   3.169 +
   3.170 +declare [[smt_random_seed = 1]]
   3.171 +
   3.172 +text {*
   3.173 +In general, the binding to SMT solvers runs as an oracle, i.e, the SMT
   3.174 +solvers are fully trusted without additional checks. The following
   3.175 +option can cause the SMT solver to run in proof-producing mode, giving
   3.176 +a checkable certificate. This is currently only implemented for Z3.
   3.177 +*}
   3.178 +
   3.179 +declare [[smt_oracle = false]]
   3.180 +
   3.181 +text {*
   3.182 +Each SMT solver provides several commandline options to tweak its
   3.183 +behaviour. They can be passed to the solver by setting the following
   3.184 +options.
   3.185 +*}
   3.186 +
   3.187 +declare [[cvc3_options = ""]]
   3.188 +declare [[cvc4_options = ""]]
   3.189 +declare [[veriT_options = ""]]
   3.190 +declare [[z3_options = ""]]
   3.191 +
   3.192 +text {*
   3.193 +The SMT method provides an inference mechanism to detect simple triggers
   3.194 +in quantified formulas, which might increase the number of problems
   3.195 +solvable by SMT solvers (note: triggers guide quantifier instantiations
   3.196 +in the SMT solver). To turn it on, set the following option.
   3.197 +*}
   3.198 +
   3.199 +declare [[smt_infer_triggers = false]]
   3.200 +
   3.201 +text {*
   3.202 +Enable the following option to use built-in support for div/mod, datatypes,
   3.203 +and records in Z3. Currently, this is implemented only in oracle mode.
   3.204 +*}
   3.205 +
   3.206 +declare [[z3_extensions = false]]
   3.207 +
   3.208 +
   3.209 +subsection {* Certificates *}
   3.210 +
   3.211 +text {*
   3.212 +By setting the option @{text smt_certificates} to the name of a file,
   3.213 +all following applications of an SMT solver a cached in that file.
   3.214 +Any further application of the same SMT solver (using the very same
   3.215 +configuration) re-uses the cached certificate instead of invoking the
   3.216 +solver. An empty string disables caching certificates.
   3.217 +
   3.218 +The filename should be given as an explicit path. It is good
   3.219 +practice to use the name of the current theory (with ending
   3.220 +@{text ".certs"} instead of @{text ".thy"}) as the certificates file.
   3.221 +Certificate files should be used at most once in a certain theory context,
   3.222 +to avoid race conditions with other concurrent accesses.
   3.223 +*}
   3.224 +
   3.225 +declare [[smt_certificates = ""]]
   3.226 +
   3.227 +text {*
   3.228 +The option @{text smt_read_only_certificates} controls whether only
   3.229 +stored certificates are should be used or invocation of an SMT solver
   3.230 +is allowed. When set to @{text true}, no SMT solver will ever be
   3.231 +invoked and only the existing certificates found in the configured
   3.232 +cache are used;  when set to @{text false} and there is no cached
   3.233 +certificate for some proposition, then the configured SMT solver is
   3.234 +invoked.
   3.235 +*}
   3.236 +
   3.237 +declare [[smt_read_only_certificates = false]]
   3.238 +
   3.239 +
   3.240 +subsection {* Tracing *}
   3.241 +
   3.242 +text {*
   3.243 +The SMT method, when applied, traces important information. To
   3.244 +make it entirely silent, set the following option to @{text false}.
   3.245 +*}
   3.246 +
   3.247 +declare [[smt_verbose = true]]
   3.248 +
   3.249 +text {*
   3.250 +For tracing the generated problem file given to the SMT solver as
   3.251 +well as the returned result of the solver, the option
   3.252 +@{text smt_trace} should be set to @{text true}.
   3.253 +*}
   3.254 +
   3.255 +declare [[smt_trace = false]]
   3.256 +
   3.257 +
   3.258 +subsection {* Schematic rules for Z3 proof reconstruction *}
   3.259 +
   3.260 +text {*
   3.261 +Several prof rules of Z3 are not very well documented. There are two
   3.262 +lemma groups which can turn failing Z3 proof reconstruction attempts
   3.263 +into succeeding ones: the facts in @{text z3_rule} are tried prior to
   3.264 +any implemented reconstruction procedure for all uncertain Z3 proof
   3.265 +rules;  the facts in @{text z3_simp} are only fed to invocations of
   3.266 +the simplifier when reconstructing theory-specific proof steps.
   3.267 +*}
   3.268 +
   3.269 +lemmas [z3_rule] =
   3.270 +  refl eq_commute conj_commute disj_commute simp_thms nnf_simps
   3.271 +  ring_distribs field_simps times_divide_eq_right times_divide_eq_left
   3.272 +  if_True if_False not_not
   3.273 +
   3.274 +lemma [z3_rule]:
   3.275 +  "(P \<and> Q) = (\<not> (\<not> P \<or> \<not> Q))"
   3.276 +  "(P \<and> Q) = (\<not> (\<not> Q \<or> \<not> P))"
   3.277 +  "(\<not> P \<and> Q) = (\<not> (P \<or> \<not> Q))"
   3.278 +  "(\<not> P \<and> Q) = (\<not> (\<not> Q \<or> P))"
   3.279 +  "(P \<and> \<not> Q) = (\<not> (\<not> P \<or> Q))"
   3.280 +  "(P \<and> \<not> Q) = (\<not> (Q \<or> \<not> P))"
   3.281 +  "(\<not> P \<and> \<not> Q) = (\<not> (P \<or> Q))"
   3.282 +  "(\<not> P \<and> \<not> Q) = (\<not> (Q \<or> P))"
   3.283 +  by auto
   3.284 +
   3.285 +lemma [z3_rule]:
   3.286 +  "(P \<longrightarrow> Q) = (Q \<or> \<not> P)"
   3.287 +  "(\<not> P \<longrightarrow> Q) = (P \<or> Q)"
   3.288 +  "(\<not> P \<longrightarrow> Q) = (Q \<or> P)"
   3.289 +  "(True \<longrightarrow> P) = P"
   3.290 +  "(P \<longrightarrow> True) = True"
   3.291 +  "(False \<longrightarrow> P) = True"
   3.292 +  "(P \<longrightarrow> P) = True"
   3.293 +  by auto
   3.294 +
   3.295 +lemma [z3_rule]:
   3.296 +  "((P = Q) \<longrightarrow> R) = (R | (Q = (\<not> P)))"
   3.297 +  by auto
   3.298 +
   3.299 +lemma [z3_rule]:
   3.300 +  "(\<not> True) = False"
   3.301 +  "(\<not> False) = True"
   3.302 +  "(x = x) = True"
   3.303 +  "(P = True) = P"
   3.304 +  "(True = P) = P"
   3.305 +  "(P = False) = (\<not> P)"
   3.306 +  "(False = P) = (\<not> P)"
   3.307 +  "((\<not> P) = P) = False"
   3.308 +  "(P = (\<not> P)) = False"
   3.309 +  "((\<not> P) = (\<not> Q)) = (P = Q)"
   3.310 +  "\<not> (P = (\<not> Q)) = (P = Q)"
   3.311 +  "\<not> ((\<not> P) = Q) = (P = Q)"
   3.312 +  "(P \<noteq> Q) = (Q = (\<not> P))"
   3.313 +  "(P = Q) = ((\<not> P \<or> Q) \<and> (P \<or> \<not> Q))"
   3.314 +  "(P \<noteq> Q) = ((\<not> P \<or> \<not> Q) \<and> (P \<or> Q))"
   3.315 +  by auto
   3.316 +
   3.317 +lemma [z3_rule]:
   3.318 +  "(if P then P else \<not> P) = True"
   3.319 +  "(if \<not> P then \<not> P else P) = True"
   3.320 +  "(if P then True else False) = P"
   3.321 +  "(if P then False else True) = (\<not> P)"
   3.322 +  "(if P then Q else True) = ((\<not> P) \<or> Q)"
   3.323 +  "(if P then Q else True) = (Q \<or> (\<not> P))"
   3.324 +  "(if P then Q else \<not> Q) = (P = Q)"
   3.325 +  "(if P then Q else \<not> Q) = (Q = P)"
   3.326 +  "(if P then \<not> Q else Q) = (P = (\<not> Q))"
   3.327 +  "(if P then \<not> Q else Q) = ((\<not> Q) = P)"
   3.328 +  "(if \<not> P then x else y) = (if P then y else x)"
   3.329 +  "(if P then (if Q then x else y) else x) = (if P \<and> (\<not> Q) then y else x)"
   3.330 +  "(if P then (if Q then x else y) else x) = (if (\<not> Q) \<and> P then y else x)"
   3.331 +  "(if P then (if Q then x else y) else y) = (if P \<and> Q then x else y)"
   3.332 +  "(if P then (if Q then x else y) else y) = (if Q \<and> P then x else y)"
   3.333 +  "(if P then x else if P then y else z) = (if P then x else z)"
   3.334 +  "(if P then x else if Q then x else y) = (if P \<or> Q then x else y)"
   3.335 +  "(if P then x else if Q then x else y) = (if Q \<or> P then x else y)"
   3.336 +  "(if P then x = y else x = z) = (x = (if P then y else z))"
   3.337 +  "(if P then x = y else y = z) = (y = (if P then x else z))"
   3.338 +  "(if P then x = y else z = y) = (y = (if P then x else z))"
   3.339 +  by auto
   3.340 +
   3.341 +lemma [z3_rule]:
   3.342 +  "0 + (x::int) = x"
   3.343 +  "x + 0 = x"
   3.344 +  "x + x = 2 * x"
   3.345 +  "0 * x = 0"
   3.346 +  "1 * x = x"
   3.347 +  "x + y = y + x"
   3.348 +  by (auto simp add: mult_2)
   3.349 +
   3.350 +lemma [z3_rule]:  (* for def-axiom *)
   3.351 +  "P = Q \<or> P \<or> Q"
   3.352 +  "P = Q \<or> \<not> P \<or> \<not> Q"
   3.353 +  "(\<not> P) = Q \<or> \<not> P \<or> Q"
   3.354 +  "(\<not> P) = Q \<or> P \<or> \<not> Q"
   3.355 +  "P = (\<not> Q) \<or> \<not> P \<or> Q"
   3.356 +  "P = (\<not> Q) \<or> P \<or> \<not> Q"
   3.357 +  "P \<noteq> Q \<or> P \<or> \<not> Q"
   3.358 +  "P \<noteq> Q \<or> \<not> P \<or> Q"
   3.359 +  "P \<noteq> (\<not> Q) \<or> P \<or> Q"
   3.360 +  "(\<not> P) \<noteq> Q \<or> P \<or> Q"
   3.361 +  "P \<or> Q \<or> P \<noteq> (\<not> Q)"
   3.362 +  "P \<or> Q \<or> (\<not> P) \<noteq> Q"
   3.363 +  "P \<or> \<not> Q \<or> P \<noteq> Q"
   3.364 +  "\<not> P \<or> Q \<or> P \<noteq> Q"
   3.365 +  "P \<or> y = (if P then x else y)"
   3.366 +  "P \<or> (if P then x else y) = y"
   3.367 +  "\<not> P \<or> x = (if P then x else y)"
   3.368 +  "\<not> P \<or> (if P then x else y) = x"
   3.369 +  "P \<or> R \<or> \<not> (if P then Q else R)"
   3.370 +  "\<not> P \<or> Q \<or> \<not> (if P then Q else R)"
   3.371 +  "\<not> (if P then Q else R) \<or> \<not> P \<or> Q"
   3.372 +  "\<not> (if P then Q else R) \<or> P \<or> R"
   3.373 +  "(if P then Q else R) \<or> \<not> P \<or> \<not> Q"
   3.374 +  "(if P then Q else R) \<or> P \<or> \<not> R"
   3.375 +  "(if P then \<not> Q else R) \<or> \<not> P \<or> Q"
   3.376 +  "(if P then Q else \<not> R) \<or> P \<or> R"
   3.377 +  by auto
   3.378 +
   3.379 +hide_type (open) symb_list pattern
   3.380 +hide_const (open) Symb_Nil Symb_Cons trigger pat nopat fun_app z3div z3mod
   3.381 +
   3.382 +end
     4.1 --- a/src/HOL/SMT2.thy	Thu Aug 28 00:40:38 2014 +0200
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,378 +0,0 @@
     4.4 -(*  Title:      HOL/SMT2.thy
     4.5 -    Author:     Sascha Boehme, TU Muenchen
     4.6 -*)
     4.7 -
     4.8 -header {* Bindings to Satisfiability Modulo Theories (SMT) solvers based on SMT-LIB 2 *}
     4.9 -
    4.10 -theory SMT2
    4.11 -imports Divides
    4.12 -keywords "smt2_status" :: diag
    4.13 -begin
    4.14 -
    4.15 -subsection {* Triggers for quantifier instantiation *}
    4.16 -
    4.17 -text {*
    4.18 -Some SMT solvers support patterns as a quantifier instantiation
    4.19 -heuristics. Patterns may either be positive terms (tagged by "pat")
    4.20 -triggering quantifier instantiations -- when the solver finds a
    4.21 -term matching a positive pattern, it instantiates the corresponding
    4.22 -quantifier accordingly -- or negative terms (tagged by "nopat")
    4.23 -inhibiting quantifier instantiations. A list of patterns
    4.24 -of the same kind is called a multipattern, and all patterns in a
    4.25 -multipattern are considered conjunctively for quantifier instantiation.
    4.26 -A list of multipatterns is called a trigger, and their multipatterns
    4.27 -act disjunctively during quantifier instantiation. Each multipattern
    4.28 -should mention at least all quantified variables of the preceding
    4.29 -quantifier block.
    4.30 -*}
    4.31 -
    4.32 -typedecl 'a symb_list
    4.33 -
    4.34 -consts
    4.35 -  Symb_Nil :: "'a symb_list"
    4.36 -  Symb_Cons :: "'a \<Rightarrow> 'a symb_list \<Rightarrow> 'a symb_list"
    4.37 -
    4.38 -typedecl pattern
    4.39 -
    4.40 -consts
    4.41 -  pat :: "'a \<Rightarrow> pattern"
    4.42 -  nopat :: "'a \<Rightarrow> pattern"
    4.43 -
    4.44 -definition trigger :: "pattern symb_list symb_list \<Rightarrow> bool \<Rightarrow> bool" where
    4.45 -  "trigger _ P = P"
    4.46 -
    4.47 -
    4.48 -subsection {* Higher-order encoding *}
    4.49 -
    4.50 -text {*
    4.51 -Application is made explicit for constants occurring with varying
    4.52 -numbers of arguments. This is achieved by the introduction of the
    4.53 -following constant.
    4.54 -*}
    4.55 -
    4.56 -definition fun_app :: "'a \<Rightarrow> 'a" where "fun_app f = f"
    4.57 -
    4.58 -text {*
    4.59 -Some solvers support a theory of arrays which can be used to encode
    4.60 -higher-order functions. The following set of lemmas specifies the
    4.61 -properties of such (extensional) arrays.
    4.62 -*}
    4.63 -
    4.64 -lemmas array_rules = ext fun_upd_apply fun_upd_same fun_upd_other  fun_upd_upd fun_app_def
    4.65 -
    4.66 -
    4.67 -subsection {* Normalization *}
    4.68 -
    4.69 -lemma case_bool_if[abs_def]: "case_bool x y P = (if P then x else y)"
    4.70 -  by simp
    4.71 -
    4.72 -lemmas Ex1_def_raw = Ex1_def[abs_def]
    4.73 -lemmas Ball_def_raw = Ball_def[abs_def]
    4.74 -lemmas Bex_def_raw = Bex_def[abs_def]
    4.75 -lemmas abs_if_raw = abs_if[abs_def]
    4.76 -lemmas min_def_raw = min_def[abs_def]
    4.77 -lemmas max_def_raw = max_def[abs_def]
    4.78 -
    4.79 -
    4.80 -subsection {* Integer division and modulo for Z3 *}
    4.81 -
    4.82 -text {*
    4.83 -The following Z3-inspired definitions are overspecified for the case where @{text "l = 0"}. This
    4.84 -Schönheitsfehler is corrected in the @{text div_as_z3div} and @{text mod_as_z3mod} theorems.
    4.85 -*}
    4.86 -
    4.87 -definition z3div :: "int \<Rightarrow> int \<Rightarrow> int" where
    4.88 -  "z3div k l = (if l \<ge> 0 then k div l else - (k div - l))"
    4.89 -
    4.90 -definition z3mod :: "int \<Rightarrow> int \<Rightarrow> int" where
    4.91 -  "z3mod k l = k mod (if l \<ge> 0 then l else - l)"
    4.92 -
    4.93 -lemma div_as_z3div:
    4.94 -  "\<forall>k l. k div l = (if l = 0 then 0 else if l > 0 then z3div k l else z3div (- k) (- l))"
    4.95 -  by (simp add: z3div_def)
    4.96 -
    4.97 -lemma mod_as_z3mod:
    4.98 -  "\<forall>k l. k mod l = (if l = 0 then k else if l > 0 then z3mod k l else - z3mod (- k) (- l))"
    4.99 -  by (simp add: z3mod_def)
   4.100 -
   4.101 -
   4.102 -subsection {* Setup *}
   4.103 -
   4.104 -ML_file "Tools/SMT2/smt2_util.ML"
   4.105 -ML_file "Tools/SMT2/smt2_failure.ML"
   4.106 -ML_file "Tools/SMT2/smt2_config.ML"
   4.107 -ML_file "Tools/SMT2/smt2_builtin.ML"
   4.108 -ML_file "Tools/SMT2/smt2_datatypes.ML"
   4.109 -ML_file "Tools/SMT2/smt2_normalize.ML"
   4.110 -ML_file "Tools/SMT2/smt2_translate.ML"
   4.111 -ML_file "Tools/SMT2/smtlib2.ML"
   4.112 -ML_file "Tools/SMT2/smtlib2_interface.ML"
   4.113 -ML_file "Tools/SMT2/smtlib2_proof.ML"
   4.114 -ML_file "Tools/SMT2/smtlib2_isar.ML"
   4.115 -ML_file "Tools/SMT2/z3_new_proof.ML"
   4.116 -ML_file "Tools/SMT2/z3_new_isar.ML"
   4.117 -ML_file "Tools/SMT2/smt2_solver.ML"
   4.118 -ML_file "Tools/SMT2/z3_new_interface.ML"
   4.119 -ML_file "Tools/SMT2/z3_new_replay_util.ML"
   4.120 -ML_file "Tools/SMT2/z3_new_replay_literals.ML"
   4.121 -ML_file "Tools/SMT2/z3_new_replay_rules.ML"
   4.122 -ML_file "Tools/SMT2/z3_new_replay_methods.ML"
   4.123 -ML_file "Tools/SMT2/z3_new_replay.ML"
   4.124 -ML_file "Tools/SMT2/verit_proof.ML"
   4.125 -ML_file "Tools/SMT2/verit_isar.ML"
   4.126 -ML_file "Tools/SMT2/verit_proof_parse.ML"
   4.127 -ML_file "Tools/SMT2/smt2_systems.ML"
   4.128 -
   4.129 -method_setup smt2 = {*
   4.130 -  Scan.optional Attrib.thms [] >>
   4.131 -    (fn thms => fn ctxt =>
   4.132 -      METHOD (fn facts => HEADGOAL (SMT2_Solver.smt2_tac ctxt (thms @ facts))))
   4.133 -*} "apply an SMT solver to the current goal (based on SMT-LIB 2)"
   4.134 -
   4.135 -
   4.136 -subsection {* Configuration *}
   4.137 -
   4.138 -text {*
   4.139 -The current configuration can be printed by the command
   4.140 -@{text smt2_status}, which shows the values of most options.
   4.141 -*}
   4.142 -
   4.143 -
   4.144 -subsection {* General configuration options *}
   4.145 -
   4.146 -text {*
   4.147 -The option @{text smt2_solver} can be used to change the target SMT
   4.148 -solver. The possible values can be obtained from the @{text smt2_status}
   4.149 -command.
   4.150 -
   4.151 -Due to licensing restrictions, Z3 is not enabled by default. Z3 is free
   4.152 -for non-commercial applications and can be enabled by setting Isabelle
   4.153 -system option @{text z3_non_commercial} to @{text yes}.
   4.154 -*}
   4.155 -
   4.156 -declare [[smt2_solver = z3]]
   4.157 -
   4.158 -text {*
   4.159 -Since SMT solvers are potentially nonterminating, there is a timeout
   4.160 -(given in seconds) to restrict their runtime.
   4.161 -*}
   4.162 -
   4.163 -declare [[smt2_timeout = 20]]
   4.164 -
   4.165 -text {*
   4.166 -SMT solvers apply randomized heuristics. In case a problem is not
   4.167 -solvable by an SMT solver, changing the following option might help.
   4.168 -*}
   4.169 -
   4.170 -declare [[smt2_random_seed = 1]]
   4.171 -
   4.172 -text {*
   4.173 -In general, the binding to SMT solvers runs as an oracle, i.e, the SMT
   4.174 -solvers are fully trusted without additional checks. The following
   4.175 -option can cause the SMT solver to run in proof-producing mode, giving
   4.176 -a checkable certificate. This is currently only implemented for Z3.
   4.177 -*}
   4.178 -
   4.179 -declare [[smt2_oracle = false]]
   4.180 -
   4.181 -text {*
   4.182 -Each SMT solver provides several commandline options to tweak its
   4.183 -behaviour. They can be passed to the solver by setting the following
   4.184 -options.
   4.185 -*}
   4.186 -
   4.187 -declare [[cvc3_new_options = ""]]
   4.188 -declare [[cvc4_new_options = ""]]
   4.189 -declare [[z3_new_options = ""]]
   4.190 -
   4.191 -text {*
   4.192 -The SMT method provides an inference mechanism to detect simple triggers
   4.193 -in quantified formulas, which might increase the number of problems
   4.194 -solvable by SMT solvers (note: triggers guide quantifier instantiations
   4.195 -in the SMT solver). To turn it on, set the following option.
   4.196 -*}
   4.197 -
   4.198 -declare [[smt2_infer_triggers = false]]
   4.199 -
   4.200 -text {*
   4.201 -Enable the following option to use built-in support for div/mod, datatypes,
   4.202 -and records in Z3. Currently, this is implemented only in oracle mode.
   4.203 -*}
   4.204 -
   4.205 -declare [[z3_new_extensions = false]]
   4.206 -
   4.207 -
   4.208 -subsection {* Certificates *}
   4.209 -
   4.210 -text {*
   4.211 -By setting the option @{text smt2_certificates} to the name of a file,
   4.212 -all following applications of an SMT solver a cached in that file.
   4.213 -Any further application of the same SMT solver (using the very same
   4.214 -configuration) re-uses the cached certificate instead of invoking the
   4.215 -solver. An empty string disables caching certificates.
   4.216 -
   4.217 -The filename should be given as an explicit path. It is good
   4.218 -practice to use the name of the current theory (with ending
   4.219 -@{text ".certs"} instead of @{text ".thy"}) as the certificates file.
   4.220 -Certificate files should be used at most once in a certain theory context,
   4.221 -to avoid race conditions with other concurrent accesses.
   4.222 -*}
   4.223 -
   4.224 -declare [[smt2_certificates = ""]]
   4.225 -
   4.226 -text {*
   4.227 -The option @{text smt2_read_only_certificates} controls whether only
   4.228 -stored certificates are should be used or invocation of an SMT solver
   4.229 -is allowed. When set to @{text true}, no SMT solver will ever be
   4.230 -invoked and only the existing certificates found in the configured
   4.231 -cache are used;  when set to @{text false} and there is no cached
   4.232 -certificate for some proposition, then the configured SMT solver is
   4.233 -invoked.
   4.234 -*}
   4.235 -
   4.236 -declare [[smt2_read_only_certificates = false]]
   4.237 -
   4.238 -
   4.239 -subsection {* Tracing *}
   4.240 -
   4.241 -text {*
   4.242 -The SMT method, when applied, traces important information. To
   4.243 -make it entirely silent, set the following option to @{text false}.
   4.244 -*}
   4.245 -
   4.246 -declare [[smt2_verbose = true]]
   4.247 -
   4.248 -text {*
   4.249 -For tracing the generated problem file given to the SMT solver as
   4.250 -well as the returned result of the solver, the option
   4.251 -@{text smt2_trace} should be set to @{text true}.
   4.252 -*}
   4.253 -
   4.254 -declare [[smt2_trace = false]]
   4.255 -
   4.256 -
   4.257 -subsection {* Schematic rules for Z3 proof reconstruction *}
   4.258 -
   4.259 -text {*
   4.260 -Several prof rules of Z3 are not very well documented. There are two
   4.261 -lemma groups which can turn failing Z3 proof reconstruction attempts
   4.262 -into succeeding ones: the facts in @{text z3_rule} are tried prior to
   4.263 -any implemented reconstruction procedure for all uncertain Z3 proof
   4.264 -rules;  the facts in @{text z3_simp} are only fed to invocations of
   4.265 -the simplifier when reconstructing theory-specific proof steps.
   4.266 -*}
   4.267 -
   4.268 -lemmas [z3_new_rule] =
   4.269 -  refl eq_commute conj_commute disj_commute simp_thms nnf_simps
   4.270 -  ring_distribs field_simps times_divide_eq_right times_divide_eq_left
   4.271 -  if_True if_False not_not
   4.272 -
   4.273 -lemma [z3_new_rule]:
   4.274 -  "(P \<and> Q) = (\<not> (\<not> P \<or> \<not> Q))"
   4.275 -  "(P \<and> Q) = (\<not> (\<not> Q \<or> \<not> P))"
   4.276 -  "(\<not> P \<and> Q) = (\<not> (P \<or> \<not> Q))"
   4.277 -  "(\<not> P \<and> Q) = (\<not> (\<not> Q \<or> P))"
   4.278 -  "(P \<and> \<not> Q) = (\<not> (\<not> P \<or> Q))"
   4.279 -  "(P \<and> \<not> Q) = (\<not> (Q \<or> \<not> P))"
   4.280 -  "(\<not> P \<and> \<not> Q) = (\<not> (P \<or> Q))"
   4.281 -  "(\<not> P \<and> \<not> Q) = (\<not> (Q \<or> P))"
   4.282 -  by auto
   4.283 -
   4.284 -lemma [z3_new_rule]:
   4.285 -  "(P \<longrightarrow> Q) = (Q \<or> \<not> P)"
   4.286 -  "(\<not> P \<longrightarrow> Q) = (P \<or> Q)"
   4.287 -  "(\<not> P \<longrightarrow> Q) = (Q \<or> P)"
   4.288 -  "(True \<longrightarrow> P) = P"
   4.289 -  "(P \<longrightarrow> True) = True"
   4.290 -  "(False \<longrightarrow> P) = True"
   4.291 -  "(P \<longrightarrow> P) = True"
   4.292 -  by auto
   4.293 -
   4.294 -lemma [z3_new_rule]:
   4.295 -  "((P = Q) \<longrightarrow> R) = (R | (Q = (\<not> P)))"
   4.296 -  by auto
   4.297 -
   4.298 -lemma [z3_new_rule]:
   4.299 -  "(\<not> True) = False"
   4.300 -  "(\<not> False) = True"
   4.301 -  "(x = x) = True"
   4.302 -  "(P = True) = P"
   4.303 -  "(True = P) = P"
   4.304 -  "(P = False) = (\<not> P)"
   4.305 -  "(False = P) = (\<not> P)"
   4.306 -  "((\<not> P) = P) = False"
   4.307 -  "(P = (\<not> P)) = False"
   4.308 -  "((\<not> P) = (\<not> Q)) = (P = Q)"
   4.309 -  "\<not> (P = (\<not> Q)) = (P = Q)"
   4.310 -  "\<not> ((\<not> P) = Q) = (P = Q)"
   4.311 -  "(P \<noteq> Q) = (Q = (\<not> P))"
   4.312 -  "(P = Q) = ((\<not> P \<or> Q) \<and> (P \<or> \<not> Q))"
   4.313 -  "(P \<noteq> Q) = ((\<not> P \<or> \<not> Q) \<and> (P \<or> Q))"
   4.314 -  by auto
   4.315 -
   4.316 -lemma [z3_new_rule]:
   4.317 -  "(if P then P else \<not> P) = True"
   4.318 -  "(if \<not> P then \<not> P else P) = True"
   4.319 -  "(if P then True else False) = P"
   4.320 -  "(if P then False else True) = (\<not> P)"
   4.321 -  "(if P then Q else True) = ((\<not> P) \<or> Q)"
   4.322 -  "(if P then Q else True) = (Q \<or> (\<not> P))"
   4.323 -  "(if P then Q else \<not> Q) = (P = Q)"
   4.324 -  "(if P then Q else \<not> Q) = (Q = P)"
   4.325 -  "(if P then \<not> Q else Q) = (P = (\<not> Q))"
   4.326 -  "(if P then \<not> Q else Q) = ((\<not> Q) = P)"
   4.327 -  "(if \<not> P then x else y) = (if P then y else x)"
   4.328 -  "(if P then (if Q then x else y) else x) = (if P \<and> (\<not> Q) then y else x)"
   4.329 -  "(if P then (if Q then x else y) else x) = (if (\<not> Q) \<and> P then y else x)"
   4.330 -  "(if P then (if Q then x else y) else y) = (if P \<and> Q then x else y)"
   4.331 -  "(if P then (if Q then x else y) else y) = (if Q \<and> P then x else y)"
   4.332 -  "(if P then x else if P then y else z) = (if P then x else z)"
   4.333 -  "(if P then x else if Q then x else y) = (if P \<or> Q then x else y)"
   4.334 -  "(if P then x else if Q then x else y) = (if Q \<or> P then x else y)"
   4.335 -  "(if P then x = y else x = z) = (x = (if P then y else z))"
   4.336 -  "(if P then x = y else y = z) = (y = (if P then x else z))"
   4.337 -  "(if P then x = y else z = y) = (y = (if P then x else z))"
   4.338 -  by auto
   4.339 -
   4.340 -lemma [z3_new_rule]:
   4.341 -  "0 + (x::int) = x"
   4.342 -  "x + 0 = x"
   4.343 -  "x + x = 2 * x"
   4.344 -  "0 * x = 0"
   4.345 -  "1 * x = x"
   4.346 -  "x + y = y + x"
   4.347 -  by (auto simp add: mult_2)
   4.348 -
   4.349 -lemma [z3_new_rule]:  (* for def-axiom *)
   4.350 -  "P = Q \<or> P \<or> Q"
   4.351 -  "P = Q \<or> \<not> P \<or> \<not> Q"
   4.352 -  "(\<not> P) = Q \<or> \<not> P \<or> Q"
   4.353 -  "(\<not> P) = Q \<or> P \<or> \<not> Q"
   4.354 -  "P = (\<not> Q) \<or> \<not> P \<or> Q"
   4.355 -  "P = (\<not> Q) \<or> P \<or> \<not> Q"
   4.356 -  "P \<noteq> Q \<or> P \<or> \<not> Q"
   4.357 -  "P \<noteq> Q \<or> \<not> P \<or> Q"
   4.358 -  "P \<noteq> (\<not> Q) \<or> P \<or> Q"
   4.359 -  "(\<not> P) \<noteq> Q \<or> P \<or> Q"
   4.360 -  "P \<or> Q \<or> P \<noteq> (\<not> Q)"
   4.361 -  "P \<or> Q \<or> (\<not> P) \<noteq> Q"
   4.362 -  "P \<or> \<not> Q \<or> P \<noteq> Q"
   4.363 -  "\<not> P \<or> Q \<or> P \<noteq> Q"
   4.364 -  "P \<or> y = (if P then x else y)"
   4.365 -  "P \<or> (if P then x else y) = y"
   4.366 -  "\<not> P \<or> x = (if P then x else y)"
   4.367 -  "\<not> P \<or> (if P then x else y) = x"
   4.368 -  "P \<or> R \<or> \<not> (if P then Q else R)"
   4.369 -  "\<not> P \<or> Q \<or> \<not> (if P then Q else R)"
   4.370 -  "\<not> (if P then Q else R) \<or> \<not> P \<or> Q"
   4.371 -  "\<not> (if P then Q else R) \<or> P \<or> R"
   4.372 -  "(if P then Q else R) \<or> \<not> P \<or> \<not> Q"
   4.373 -  "(if P then Q else R) \<or> P \<or> \<not> R"
   4.374 -  "(if P then \<not> Q else R) \<or> \<not> P \<or> Q"
   4.375 -  "(if P then Q else \<not> R) \<or> P \<or> R"
   4.376 -  by auto
   4.377 -
   4.378 -hide_type (open) symb_list pattern
   4.379 -hide_const (open) Symb_Nil Symb_Cons trigger pat nopat fun_app z3div z3mod
   4.380 -
   4.381 -end
     5.1 --- a/src/HOL/SMT_Examples/Boogie.thy	Thu Aug 28 00:40:38 2014 +0200
     5.2 +++ b/src/HOL/SMT_Examples/Boogie.thy	Thu Aug 28 00:40:38 2014 +0200
     5.3 @@ -51,22 +51,22 @@
     5.4  
     5.5  section {* Verification condition proofs *}
     5.6  
     5.7 -declare [[smt2_oracle = false]]
     5.8 -declare [[smt2_read_only_certificates = true]]
     5.9 +declare [[smt_oracle = false]]
    5.10 +declare [[smt_read_only_certificates = true]]
    5.11  
    5.12  
    5.13 -declare [[smt2_certificates = "Boogie_Max.certs2"]]
    5.14 +declare [[smt_certificates = "Boogie_Max.certs2"]]
    5.15  
    5.16  boogie_file Boogie_Max
    5.17  
    5.18  
    5.19 -declare [[smt2_certificates = "Boogie_Dijkstra.certs2"]]
    5.20 +declare [[smt_certificates = "Boogie_Dijkstra.certs2"]]
    5.21  
    5.22  boogie_file Boogie_Dijkstra
    5.23  
    5.24  
    5.25 -declare [[z3_new_extensions = true]]
    5.26 -declare [[smt2_certificates = "VCC_Max.certs2"]]
    5.27 +declare [[z3_extensions = true]]
    5.28 +declare [[smt_certificates = "VCC_Max.certs2"]]
    5.29  
    5.30  boogie_file VCC_Max
    5.31  
     6.1 --- a/src/HOL/SMT_Examples/SMT_Examples.thy	Thu Aug 28 00:40:38 2014 +0200
     6.2 +++ b/src/HOL/SMT_Examples/SMT_Examples.thy	Thu Aug 28 00:40:38 2014 +0200
     6.3 @@ -8,19 +8,19 @@
     6.4  imports Complex_Main
     6.5  begin
     6.6  
     6.7 -declare [[smt2_certificates = "SMT_Examples.certs2"]]
     6.8 -declare [[smt2_read_only_certificates = true]]
     6.9 +declare [[smt_certificates = "SMT_Examples.certs2"]]
    6.10 +declare [[smt_read_only_certificates = true]]
    6.11  
    6.12  
    6.13  section {* Propositional and first-order logic *}
    6.14  
    6.15 -lemma "True" by smt2
    6.16 -lemma "p \<or> \<not>p" by smt2
    6.17 -lemma "(p \<and> True) = p" by smt2
    6.18 -lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by smt2
    6.19 -lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by smt2
    6.20 -lemma "(p1 \<and> p2) \<or> p3 \<longrightarrow> (p1 \<longrightarrow> (p3 \<and> p2) \<or> (p1 \<and> p3)) \<or> p1" by smt2
    6.21 -lemma "P = P = P = P = P = P = P = P = P = P" by smt2
    6.22 +lemma "True" by smt
    6.23 +lemma "p \<or> \<not>p" by smt
    6.24 +lemma "(p \<and> True) = p" by smt
    6.25 +lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by smt
    6.26 +lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by smt
    6.27 +lemma "(p1 \<and> p2) \<or> p3 \<longrightarrow> (p1 \<longrightarrow> (p3 \<and> p2) \<or> (p1 \<and> p3)) \<or> p1" by smt
    6.28 +lemma "P = P = P = P = P = P = P = P = P = P" by smt
    6.29  
    6.30  lemma
    6.31    assumes "a \<or> b \<or> c \<or> d"
    6.32 @@ -30,12 +30,12 @@
    6.33        and "\<not> (d \<or> False) \<or> c"
    6.34        and "\<not> (c \<or> (\<not> p \<and> (p \<or> (q \<and> \<not> q))))"
    6.35    shows False
    6.36 -  using assms by smt2
    6.37 +  using assms by smt
    6.38  
    6.39  axiomatization symm_f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
    6.40    symm_f: "symm_f x y = symm_f y x"
    6.41  
    6.42 -lemma "a = a \<and> symm_f a b = symm_f b a" by (smt2 symm_f)
    6.43 +lemma "a = a \<and> symm_f a b = symm_f b a" by (smt symm_f)
    6.44  
    6.45  (*
    6.46  Taken from ~~/src/HOL/ex/SAT_Examples.thy.
    6.47 @@ -227,55 +227,55 @@
    6.48    and "~x29 \<or> ~x58"
    6.49    and "~x28 \<or> ~x58"
    6.50    shows False
    6.51 -  using assms by smt2
    6.52 +  using assms by smt
    6.53  
    6.54  lemma "\<forall>x::int. P x \<longrightarrow> (\<forall>y::int. P x \<or> P y)"
    6.55 -  by smt2
    6.56 +  by smt
    6.57  
    6.58  lemma
    6.59    assumes "(\<forall>x y. P x y = x)"
    6.60    shows "(\<exists>y. P x y) = P x c"
    6.61 -  using assms by smt2
    6.62 +  using assms by smt
    6.63  
    6.64  lemma
    6.65    assumes "(\<forall>x y. P x y = x)"
    6.66    and "(\<forall>x. \<exists>y. P x y) = (\<forall>x. P x c)"
    6.67    shows "(EX y. P x y) = P x c"
    6.68 -  using assms by smt2
    6.69 +  using assms by smt
    6.70  
    6.71  lemma
    6.72    assumes "if P x then \<not>(\<exists>y. P y) else (\<forall>y. \<not>P y)"
    6.73    shows "P x \<longrightarrow> P y"
    6.74 -  using assms by smt2
    6.75 +  using assms by smt
    6.76  
    6.77  
    6.78  section {* Arithmetic *}
    6.79  
    6.80  subsection {* Linear arithmetic over integers and reals *}
    6.81  
    6.82 -lemma "(3::int) = 3" by smt2
    6.83 -lemma "(3::real) = 3" by smt2
    6.84 -lemma "(3 :: int) + 1 = 4" by smt2
    6.85 -lemma "x + (y + z) = y + (z + (x::int))" by smt2
    6.86 -lemma "max (3::int) 8 > 5" by smt2
    6.87 -lemma "abs (x :: real) + abs y \<ge> abs (x + y)" by smt2
    6.88 -lemma "P ((2::int) < 3) = P True" by smt2
    6.89 -lemma "x + 3 \<ge> 4 \<or> x < (1::int)" by smt2
    6.90 +lemma "(3::int) = 3" by smt
    6.91 +lemma "(3::real) = 3" by smt
    6.92 +lemma "(3 :: int) + 1 = 4" by smt
    6.93 +lemma "x + (y + z) = y + (z + (x::int))" by smt
    6.94 +lemma "max (3::int) 8 > 5" by smt
    6.95 +lemma "abs (x :: real) + abs y \<ge> abs (x + y)" by smt
    6.96 +lemma "P ((2::int) < 3) = P True" by smt
    6.97 +lemma "x + 3 \<ge> 4 \<or> x < (1::int)" by smt
    6.98  
    6.99  lemma
   6.100    assumes "x \<ge> (3::int)" and "y = x + 4"
   6.101    shows "y - x > 0"
   6.102 -  using assms by smt2
   6.103 +  using assms by smt
   6.104  
   6.105 -lemma "let x = (2 :: int) in x + x \<noteq> 5" by smt2
   6.106 +lemma "let x = (2 :: int) in x + x \<noteq> 5" by smt
   6.107  
   6.108  lemma
   6.109    fixes x :: real
   6.110    assumes "3 * x + 7 * a < 4" and "3 < 2 * x"
   6.111    shows "a < 0"
   6.112 -  using assms by smt2
   6.113 +  using assms by smt
   6.114  
   6.115 -lemma "(0 \<le> y + -1 * x \<or> \<not> 0 \<le> x \<or> 0 \<le> (x::int)) = (\<not> False)" by smt2
   6.116 +lemma "(0 \<le> y + -1 * x \<or> \<not> 0 \<le> x \<or> 0 \<le> (x::int)) = (\<not> False)" by smt
   6.117  
   6.118  lemma "
   6.119    (n < m \<and> m < n') \<or> (n < m \<and> m = n') \<or> (n < n' \<and> n' < m) \<or>
   6.120 @@ -285,7 +285,7 @@
   6.121    (m < n \<and> n < n') \<or> (m < n \<and> n' = n) \<or> (m < n' \<and> n' < n) \<or>
   6.122    (m = n \<and> n < n') \<or> (m = n' \<and> n' < n) \<or>
   6.123    (n' = m \<and> m = (n::int))"
   6.124 -  by smt2
   6.125 +  by smt
   6.126  
   6.127  text{*
   6.128  The following example was taken from HOL/ex/PresburgerEx.thy, where it says:
   6.129 @@ -307,79 +307,79 @@
   6.130           x6 = abs x5 - x4; x7 = abs x6 - x5; x8 = abs x7 - x6;
   6.131           x9 = abs x8 - x7; x10 = abs x9 - x8; x11 = abs x10 - x9 \<rbrakk>
   6.132   \<Longrightarrow> x1 = x10 \<and> x2 = (x11::int)"
   6.133 -  by smt2
   6.134 +  by smt
   6.135  
   6.136  
   6.137 -lemma "let P = 2 * x + 1 > x + (x::real) in P \<or> False \<or> P" by smt2
   6.138 +lemma "let P = 2 * x + 1 > x + (x::real) in P \<or> False \<or> P" by smt
   6.139  
   6.140  lemma "x + (let y = x mod 2 in 2 * y + 1) \<ge> x + (1::int)"
   6.141 -  using [[z3_new_extensions]] by smt2
   6.142 +  using [[z3_extensions]] by smt
   6.143  
   6.144  lemma "x + (let y = x mod 2 in y + y) < x + (3::int)"
   6.145 -  using [[z3_new_extensions]] by smt2
   6.146 +  using [[z3_extensions]] by smt
   6.147  
   6.148  lemma
   6.149    assumes "x \<noteq> (0::real)"
   6.150    shows "x + x \<noteq> (let P = (abs x > 1) in if P \<or> \<not> P then 4 else 2) * x"
   6.151 -  using assms [[z3_new_extensions]] by smt2
   6.152 +  using assms [[z3_extensions]] by smt
   6.153  
   6.154  lemma
   6.155    assumes "(n + m) mod 2 = 0" and "n mod 4 = 3"
   6.156    shows "n mod 2 = 1 \<and> m mod 2 = (1::int)"
   6.157 -  using assms [[z3_new_extensions]] by smt2
   6.158 +  using assms [[z3_extensions]] by smt
   6.159  
   6.160  
   6.161  subsection {* Linear arithmetic with quantifiers *}
   6.162  
   6.163 -lemma "~ (\<exists>x::int. False)" by smt2
   6.164 -lemma "~ (\<exists>x::real. False)" by smt2
   6.165 +lemma "~ (\<exists>x::int. False)" by smt
   6.166 +lemma "~ (\<exists>x::real. False)" by smt
   6.167  
   6.168 -lemma "\<exists>x::int. 0 < x" by smt2
   6.169 +lemma "\<exists>x::int. 0 < x" by smt
   6.170  
   6.171  lemma "\<exists>x::real. 0 < x"
   6.172 -  using [[smt2_oracle=true]] (* no Z3 proof *)
   6.173 -  by smt2
   6.174 +  using [[smt_oracle=true]] (* no Z3 proof *)
   6.175 +  by smt
   6.176  
   6.177 -lemma "\<forall>x::int. \<exists>y. y > x" by smt2
   6.178 +lemma "\<forall>x::int. \<exists>y. y > x" by smt
   6.179  
   6.180 -lemma "\<forall>x y::int. (x = 0 \<and> y = 1) \<longrightarrow> x \<noteq> y" by smt2
   6.181 -lemma "\<exists>x::int. \<forall>y. x < y \<longrightarrow> y < 0 \<or> y >= 0" by smt2
   6.182 -lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by smt2
   6.183 -lemma "\<forall>x y::int. (2 * x + 1) \<noteq> (2 * y)" by smt2
   6.184 -lemma "\<forall>x y::int. x + y > 2 \<or> x + y = 2 \<or> x + y < 2" by smt2
   6.185 -lemma "\<forall>x::int. if x > 0 then x + 1 > 0 else 1 > x" by smt2
   6.186 -lemma "if (ALL x::int. x < 0 \<or> x > 0) then False else True" by smt2
   6.187 -lemma "(if (ALL x::int. x < 0 \<or> x > 0) then -1 else 3) > (0::int)" by smt2
   6.188 -lemma "~ (\<exists>x y z::int. 4 * x + -6 * y = (1::int))" by smt2
   6.189 -lemma "\<exists>x::int. \<forall>x y. 0 < x \<and> 0 < y \<longrightarrow> (0::int) < x + y" by smt2
   6.190 -lemma "\<exists>u::int. \<forall>(x::int) y::real. 0 < x \<and> 0 < y \<longrightarrow> -1 < x" by smt2
   6.191 -lemma "\<exists>x::int. (\<forall>y. y \<ge> x \<longrightarrow> y > 0) \<longrightarrow> x > 0" by smt2
   6.192 +lemma "\<forall>x y::int. (x = 0 \<and> y = 1) \<longrightarrow> x \<noteq> y" by smt
   6.193 +lemma "\<exists>x::int. \<forall>y. x < y \<longrightarrow> y < 0 \<or> y >= 0" by smt
   6.194 +lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by smt
   6.195 +lemma "\<forall>x y::int. (2 * x + 1) \<noteq> (2 * y)" by smt
   6.196 +lemma "\<forall>x y::int. x + y > 2 \<or> x + y = 2 \<or> x + y < 2" by smt
   6.197 +lemma "\<forall>x::int. if x > 0 then x + 1 > 0 else 1 > x" by smt
   6.198 +lemma "if (ALL x::int. x < 0 \<or> x > 0) then False else True" by smt
   6.199 +lemma "(if (ALL x::int. x < 0 \<or> x > 0) then -1 else 3) > (0::int)" by smt
   6.200 +lemma "~ (\<exists>x y z::int. 4 * x + -6 * y = (1::int))" by smt
   6.201 +lemma "\<exists>x::int. \<forall>x y. 0 < x \<and> 0 < y \<longrightarrow> (0::int) < x + y" by smt
   6.202 +lemma "\<exists>u::int. \<forall>(x::int) y::real. 0 < x \<and> 0 < y \<longrightarrow> -1 < x" by smt
   6.203 +lemma "\<exists>x::int. (\<forall>y. y \<ge> x \<longrightarrow> y > 0) \<longrightarrow> x > 0" by smt
   6.204  lemma "\<forall>x::int.
   6.205 -  SMT2.trigger (SMT2.Symb_Cons (SMT2.Symb_Cons (SMT2.pat x) SMT2.Symb_Nil) SMT2.Symb_Nil)
   6.206 -    (x < a \<longrightarrow> 2 * x < 2 * a)" by smt2
   6.207 -lemma "\<forall>(a::int) b::int. 0 < b \<or> b < 1" by smt2
   6.208 +  SMT.trigger (SMT.Symb_Cons (SMT.Symb_Cons (SMT.pat x) SMT.Symb_Nil) SMT.Symb_Nil)
   6.209 +    (x < a \<longrightarrow> 2 * x < 2 * a)" by smt
   6.210 +lemma "\<forall>(a::int) b::int. 0 < b \<or> b < 1" by smt
   6.211  
   6.212  
   6.213  subsection {* Non-linear arithmetic over integers and reals *}
   6.214  
   6.215  lemma "a > (0::int) \<Longrightarrow> a*b > 0 \<Longrightarrow> b > 0"
   6.216 -  using [[smt2_oracle, z3_new_extensions]]
   6.217 -  by smt2
   6.218 +  using [[smt_oracle, z3_extensions]]
   6.219 +  by smt
   6.220  
   6.221  lemma  "(a::int) * (x + 1 + y) = a * x + a * (y + 1)"
   6.222 -  using [[z3_new_extensions]]
   6.223 -  by smt2
   6.224 +  using [[z3_extensions]]
   6.225 +  by smt
   6.226  
   6.227  lemma "((x::real) * (1 + y) - x * (1 - y)) = (2 * x * y)"
   6.228 -  using [[z3_new_extensions]]
   6.229 -  by smt2
   6.230 +  using [[z3_extensions]]
   6.231 +  by smt
   6.232  
   6.233  lemma
   6.234    "(U::int) + (1 + p) * (b + e) + p * d =
   6.235     U + (2 * (1 + p) * (b + e) + (1 + p) * d + d * p) - (1 + p) * (b + d + e)"
   6.236 -  using [[z3_new_extensions]] by smt2
   6.237 +  using [[z3_extensions]] by smt
   6.238  
   6.239 -lemma [z3_new_rule]:
   6.240 +lemma [z3_rule]:
   6.241    fixes x :: "int"
   6.242    assumes "x * y \<le> 0" and "\<not> y \<le> 0" and "\<not> x \<le> 0"
   6.243    shows False
   6.244 @@ -389,40 +389,40 @@
   6.245  section {* Pairs *}
   6.246  
   6.247  lemma "fst (x, y) = a \<Longrightarrow> x = a"
   6.248 -  using fst_conv by smt2
   6.249 +  using fst_conv by smt
   6.250  
   6.251  lemma "p1 = (x, y) \<and> p2 = (y, x) \<Longrightarrow> fst p1 = snd p2"
   6.252 -  using fst_conv snd_conv by smt2
   6.253 +  using fst_conv snd_conv by smt
   6.254  
   6.255  
   6.256  section {* Higher-order problems and recursion *}
   6.257  
   6.258  lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> (f (i1 := v1, i2 := v2)) i = f i"
   6.259 -  using fun_upd_same fun_upd_apply by smt2
   6.260 +  using fun_upd_same fun_upd_apply by smt
   6.261  
   6.262  lemma "(f g (x::'a::type) = (g x \<and> True)) \<or> (f g x = True) \<or> (g x = True)"
   6.263 -  by smt2
   6.264 +  by smt
   6.265  
   6.266  lemma "id x = x \<and> id True = True"
   6.267 -  by (smt2 id_def)
   6.268 +  by (smt id_def)
   6.269  
   6.270  lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> ((f (i1 := v1)) (i2 := v2)) i = f i"
   6.271 -  using fun_upd_same fun_upd_apply by smt2
   6.272 +  using fun_upd_same fun_upd_apply by smt
   6.273  
   6.274  lemma
   6.275    "f (\<exists>x. g x) \<Longrightarrow> True"
   6.276    "f (\<forall>x. g x) \<Longrightarrow> True"
   6.277 -  by smt2+
   6.278 +  by smt+
   6.279  
   6.280 -lemma True using let_rsp by smt2
   6.281 -lemma "le = op \<le> \<Longrightarrow> le (3::int) 42" by smt2
   6.282 -lemma "map (\<lambda>i::int. i + 1) [0, 1] = [1, 2]" by (smt2 list.map)
   6.283 -lemma "(ALL x. P x) \<or> ~ All P" by smt2
   6.284 +lemma True using let_rsp by smt
   6.285 +lemma "le = op \<le> \<Longrightarrow> le (3::int) 42" by smt
   6.286 +lemma "map (\<lambda>i::int. i + 1) [0, 1] = [1, 2]" by (smt list.map)
   6.287 +lemma "(ALL x. P x) \<or> ~ All P" by smt
   6.288  
   6.289  fun dec_10 :: "int \<Rightarrow> int" where
   6.290    "dec_10 n = (if n < 10 then n else dec_10 (n - 10))"
   6.291  
   6.292 -lemma "dec_10 (4 * dec_10 4) = 6" by (smt2 dec_10.simps)
   6.293 +lemma "dec_10 (4 * dec_10 4) = 6" by (smt dec_10.simps)
   6.294  
   6.295  axiomatization
   6.296    eval_dioph :: "int list \<Rightarrow> int list \<Rightarrow> int"
   6.297 @@ -437,9 +437,9 @@
   6.298    "(eval_dioph ks xs = l) =
   6.299     (eval_dioph ks (map (\<lambda>x. x mod 2) xs) mod 2 = l mod 2 \<and>
   6.300      eval_dioph ks (map (\<lambda>x. x div 2) xs) = (l - eval_dioph ks (map (\<lambda>x. x mod 2) xs)) div 2)"
   6.301 -  using [[smt2_oracle = true]] (*FIXME*)
   6.302 -  using [[z3_new_extensions]]
   6.303 -  by (smt2 eval_dioph_mod[where n=2] eval_dioph_div_mult[where n=2])
   6.304 +  using [[smt_oracle = true]] (*FIXME*)
   6.305 +  using [[z3_extensions]]
   6.306 +  by (smt eval_dioph_mod[where n=2] eval_dioph_div_mult[where n=2])
   6.307  
   6.308  
   6.309  context complete_lattice
   6.310 @@ -449,7 +449,7 @@
   6.311    assumes "Sup {a | i::bool. True} \<le> Sup {b | i::bool. True}"
   6.312    and "Sup {b | i::bool. True} \<le> Sup {a | i::bool. True}"
   6.313    shows "Sup {a | i::bool. True} \<le> Sup {a | i::bool. True}"
   6.314 -  using assms by (smt2 order_trans)
   6.315 +  using assms by (smt order_trans)
   6.316  
   6.317  end
   6.318  
   6.319 @@ -460,7 +460,7 @@
   6.320  
   6.321  lemma poly_Pred: "Pred x \<and> (Pred [x] \<or> \<not> Pred [x])" by (simp add: Pred_def)
   6.322  
   6.323 -lemma "Pred (1::int)" by (smt2 poly_Pred)
   6.324 +lemma "Pred (1::int)" by (smt poly_Pred)
   6.325  
   6.326  axiomatization g :: "'a \<Rightarrow> nat"
   6.327  axiomatization where
   6.328 @@ -468,6 +468,6 @@
   6.329    g2: "g None = g []" and
   6.330    g3: "g xs = length xs"
   6.331  
   6.332 -lemma "g (Some (3::int)) = g (Some True)" by (smt2 g1 g2 g3 list.size)
   6.333 +lemma "g (Some (3::int)) = g (Some True)" by (smt g1 g2 g3 list.size)
   6.334  
   6.335  end
     7.1 --- a/src/HOL/SMT_Examples/SMT_Tests.thy	Thu Aug 28 00:40:38 2014 +0200
     7.2 +++ b/src/HOL/SMT_Examples/SMT_Tests.thy	Thu Aug 28 00:40:38 2014 +0200
     7.3 @@ -8,7 +8,7 @@
     7.4  imports Complex_Main
     7.5  begin
     7.6  
     7.7 -smt2_status
     7.8 +smt_status
     7.9  
    7.10  text {* Most examples are taken from various Isabelle theories and from HOL4. *}
    7.11  
    7.12 @@ -23,7 +23,7 @@
    7.13    "True \<or> False"
    7.14    "False \<longrightarrow> True"
    7.15    "\<not> (False \<longleftrightarrow> True)"
    7.16 -  by smt2+
    7.17 +  by smt+
    7.18  
    7.19  lemma
    7.20    "P \<or> \<not> P"
    7.21 @@ -62,7 +62,7 @@
    7.22    "\<not> (P \<longleftrightarrow> \<not> P)"
    7.23    "(P \<longrightarrow> Q) \<longleftrightarrow> (\<not> Q \<longrightarrow> \<not> P)"
    7.24    "P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P \<longleftrightarrow> P"
    7.25 -  by smt2+
    7.26 +  by smt+
    7.27  
    7.28  lemma
    7.29    "(if P then Q1 else Q2) \<longleftrightarrow> ((P \<longrightarrow> Q1) \<and> (\<not> P \<longrightarrow> Q2))"
    7.30 @@ -71,14 +71,14 @@
    7.31    "(if P1 \<and> P2 then Q1 else Q2) \<longleftrightarrow> (if P1 then if P2 then Q1 else Q2 else Q2)"
    7.32    "(P1 \<longrightarrow> (if P2 then Q1 else Q2)) \<longleftrightarrow>
    7.33     (if P1 \<longrightarrow> P2 then P1 \<longrightarrow> Q1 else P1 \<longrightarrow> Q2)"
    7.34 -  by smt2+
    7.35 +  by smt+
    7.36  
    7.37  lemma
    7.38    "case P of True \<Rightarrow> P | False \<Rightarrow> \<not> P"
    7.39    "case P of False \<Rightarrow> \<not> P | True \<Rightarrow> P"
    7.40    "case \<not> P of True \<Rightarrow> \<not> P | False \<Rightarrow> P"
    7.41    "case P of True \<Rightarrow> (Q \<longrightarrow> P) | False \<Rightarrow> (P \<longrightarrow> Q)"
    7.42 -  by smt2+
    7.43 +  by smt+
    7.44  
    7.45  
    7.46  section {* First-order logic with equality *}
    7.47 @@ -91,7 +91,7 @@
    7.48    "x = y \<longrightarrow> g x y = g y x"
    7.49    "f (f x) = x \<and> f (f (f (f (f x)))) = x \<longrightarrow> f x = x"
    7.50    "((if a then b else c) = d) = ((a \<longrightarrow> (b = d)) \<and> (\<not> a \<longrightarrow> (c = d)))"
    7.51 -  by smt2+
    7.52 +  by smt+
    7.53  
    7.54  lemma
    7.55    "\<forall>x. x = x"
    7.56 @@ -104,11 +104,11 @@
    7.57    "(\<forall>x. P x \<longrightarrow> P (f x)) \<and> P d \<longrightarrow> P (f(f(f(d))))"
    7.58    "(\<forall>x y. s x y = s y x) \<longrightarrow> a = a \<and> s a b = s b a"
    7.59    "(\<forall>s. q s \<longrightarrow> r s) \<and> \<not> r s \<and> (\<forall>s. \<not> r s \<and> \<not> q s \<longrightarrow> p t \<or> q t) \<longrightarrow> p t \<or> r t"
    7.60 -  by smt2+
    7.61 +  by smt+
    7.62  
    7.63  lemma
    7.64    "(\<forall>x. P x) \<and> R \<longleftrightarrow> (\<forall>x. P x \<and> R)"
    7.65 -  by smt2
    7.66 +  by smt
    7.67  
    7.68  lemma
    7.69    "\<exists>x. x = x"
    7.70 @@ -117,7 +117,7 @@
    7.71    "(\<exists>x. P x) \<and> R \<longleftrightarrow> (\<exists>x. P x \<and> R)"
    7.72    "(\<exists>x y z. S x z) \<longleftrightarrow> (\<exists>x z. S x z)"
    7.73    "\<not> ((\<exists>x. \<not> P x) \<and> ((\<exists>x. P x) \<or> (\<exists>x. P x \<and> Q x)) \<and> \<not> (\<exists>x. P x))"
    7.74 -  by smt2+
    7.75 +  by smt+
    7.76  
    7.77  lemma
    7.78    "\<exists>x y. x = y"
    7.79 @@ -126,7 +126,7 @@
    7.80    "\<exists>x. P x \<longrightarrow> P a \<and> P b"
    7.81    "\<exists>x. (\<exists>y. P y) \<longrightarrow> P x"
    7.82    "(\<exists>x. Q \<longrightarrow> P x) \<longleftrightarrow> (Q \<longrightarrow> (\<exists>x. P x))"
    7.83 -  by smt2+
    7.84 +  by smt+
    7.85  
    7.86  lemma
    7.87    "(\<not> (\<exists>x. P x)) \<longleftrightarrow> (\<forall>x. \<not> P x)"
    7.88 @@ -134,7 +134,7 @@
    7.89    "(\<forall>x y. R x y = x) \<longrightarrow> (\<exists>y. R x y) = R x c"
    7.90    "(if P x then \<not> (\<exists>y. P y) else (\<forall>y. \<not> P y)) \<longrightarrow> P x \<longrightarrow> P y"
    7.91    "(\<forall>x y. R x y = x) \<and> (\<forall>x. \<exists>y. R x y) = (\<forall>x. R x c) \<longrightarrow> (\<exists>y. R x y) = R x c"
    7.92 -  by smt2+
    7.93 +  by smt+
    7.94  
    7.95  lemma
    7.96    "\<forall>x. \<exists>y. f x y = f x (g x)"
    7.97 @@ -145,7 +145,7 @@
    7.98    "(\<exists>x. \<forall>y. P x \<longleftrightarrow> P y) \<longrightarrow> ((\<exists>x. P x) \<longleftrightarrow> (\<forall>y. P y))"
    7.99    "\<exists>z. P z \<longrightarrow> (\<forall>x. P x)"
   7.100    "(\<exists>y. \<forall>x. R x y) \<longrightarrow> (\<forall>x. \<exists>y. R x y)"
   7.101 -  by smt2+
   7.102 +  by smt+
   7.103  
   7.104  lemma
   7.105    "(\<exists>!x. P x) \<longrightarrow> (\<exists>x. P x)"
   7.106 @@ -153,12 +153,12 @@
   7.107    "P a \<longrightarrow> (\<forall>x. P x \<longrightarrow> x = a) \<longrightarrow> (\<exists>!x. P x)"
   7.108    "(\<exists>x. P x) \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> x = y) \<longrightarrow> (\<exists>!x. P x)"
   7.109    "(\<exists>!x. P x) \<and> (\<forall>x. P x \<and> (\<forall>y. P y \<longrightarrow> y = x) \<longrightarrow> R) \<longrightarrow> R"
   7.110 -  by smt2+
   7.111 +  by smt+
   7.112  
   7.113  lemma
   7.114    "(\<forall>x\<in>M. P x) \<and> c \<in> M \<longrightarrow> P c"
   7.115    "(\<exists>x\<in>M. P x) \<or> \<not> (P c \<and> c \<in> M)"
   7.116 -  by smt2+
   7.117 +  by smt+
   7.118  
   7.119  lemma
   7.120    "let P = True in P"
   7.121 @@ -169,33 +169,33 @@
   7.122    "(let x = y1; z = y2 in R x z) \<longleftrightarrow> (let z = y2; x = y1 in R x z)"
   7.123    "(let x = y1; z = y2 in R x z) \<longleftrightarrow> (let z = y1; x = y2 in R z x)"
   7.124    "let P = (\<forall>x. Q x) in if P then P else \<not> P"
   7.125 -  by smt2+
   7.126 +  by smt+
   7.127  
   7.128  lemma
   7.129    "a \<noteq> b \<and> a \<noteq> c \<and> b \<noteq> c \<and> (\<forall>x y. f x = f y \<longrightarrow> y = x) \<longrightarrow> f a \<noteq> f b"
   7.130 -  by smt2
   7.131 +  by smt
   7.132  
   7.133  lemma
   7.134    "(\<forall>x y z. f x y = f x z \<longrightarrow> y = z) \<and> b \<noteq> c \<longrightarrow> f a b \<noteq> f a c"
   7.135    "(\<forall>x y z. f x y = f z y \<longrightarrow> x = z) \<and> a \<noteq> d \<longrightarrow> f a b \<noteq> f d b"
   7.136 -  by smt2+
   7.137 +  by smt+
   7.138  
   7.139  
   7.140  section {* Guidance for quantifier heuristics: patterns *}
   7.141  
   7.142  lemma
   7.143    assumes "\<forall>x.
   7.144 -    SMT2.trigger (SMT2.Symb_Cons (SMT2.Symb_Cons (SMT2.pat (f x)) SMT2.Symb_Nil) SMT2.Symb_Nil)
   7.145 +    SMT.trigger (SMT.Symb_Cons (SMT.Symb_Cons (SMT.pat (f x)) SMT.Symb_Nil) SMT.Symb_Nil)
   7.146      (f x = x)"
   7.147    shows "f 1 = 1"
   7.148 -  using assms using [[smt2_trace]] by smt2
   7.149 +  using assms using [[smt_trace]] by smt
   7.150  
   7.151  lemma
   7.152    assumes "\<forall>x y.
   7.153 -    SMT2.trigger (SMT2.Symb_Cons (SMT2.Symb_Cons (SMT2.pat (f x))
   7.154 -      (SMT2.Symb_Cons (SMT2.pat (g y)) SMT2.Symb_Nil)) SMT2.Symb_Nil) (f x = g y)"
   7.155 +    SMT.trigger (SMT.Symb_Cons (SMT.Symb_Cons (SMT.pat (f x))
   7.156 +      (SMT.Symb_Cons (SMT.pat (g y)) SMT.Symb_Nil)) SMT.Symb_Nil) (f x = g y)"
   7.157    shows "f a = g b"
   7.158 -  using assms by smt2
   7.159 +  using assms by smt
   7.160  
   7.161  
   7.162  section {* Meta-logical connectives *}
   7.163 @@ -219,7 +219,7 @@
   7.164    "(\<And>x y. h x y \<and> h y x) \<Longrightarrow> \<forall>x. h x x"
   7.165    "(p \<or> q) \<and> \<not> p \<Longrightarrow> q"
   7.166    "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)"
   7.167 -  by smt2+
   7.168 +  by smt+
   7.169  
   7.170  
   7.171  section {* Integers *}
   7.172 @@ -234,7 +234,7 @@
   7.173    "-123 + 345 < (567::int)"
   7.174    "(123456789::int) < 2345678901"
   7.175    "(-123456789::int) < 2345678901"
   7.176 -  by smt2+
   7.177 +  by smt+
   7.178  
   7.179  lemma
   7.180    "(x::int) + 0 = x"
   7.181 @@ -242,7 +242,7 @@
   7.182    "x + y = y + x"
   7.183    "x + (y + z) = (x + y) + z"
   7.184    "(x + y = 0) = (x = -y)"
   7.185 -  by smt2+
   7.186 +  by smt+
   7.187  
   7.188  lemma
   7.189    "(-1::int) = - 1"
   7.190 @@ -250,7 +250,7 @@
   7.191    "-(x::int) < 0 \<longleftrightarrow> x > 0"
   7.192    "x > 0 \<longrightarrow> -x < 0"
   7.193    "x < 0 \<longrightarrow> -x > 0"
   7.194 -  by smt2+
   7.195 +  by smt+
   7.196  
   7.197  lemma
   7.198    "(x::int) - 0 = x"
   7.199 @@ -259,7 +259,7 @@
   7.200    "x - y = -(y - x)"
   7.201    "x - y = -y + x"
   7.202    "x - y - z = x - (y + z)"
   7.203 -  by smt2+
   7.204 +  by smt+
   7.205  
   7.206  lemma
   7.207    "(x::int) * 0 = 0"
   7.208 @@ -269,7 +269,7 @@
   7.209    "x * -1 = -x"
   7.210    "-1 * x = -x"
   7.211    "3 * x = x * 3"
   7.212 -  by smt2+
   7.213 +  by smt+
   7.214  
   7.215  lemma
   7.216    "(0::int) div 0 = 0"
   7.217 @@ -296,8 +296,8 @@
   7.218    "(-1::int) div -3 = 0"
   7.219    "(-3::int) div -3 = 1"
   7.220    "(-5::int) div -3 = 1"
   7.221 -  using [[z3_new_extensions]]
   7.222 -  by smt2+
   7.223 +  using [[z3_extensions]]
   7.224 +  by smt+
   7.225  
   7.226  lemma
   7.227    "(0::int) mod 0 = 0"
   7.228 @@ -326,14 +326,14 @@
   7.229    "(-5::int) mod -3 = -2"
   7.230    "x mod 3 < 3"
   7.231    "(x mod 3 = x) \<longrightarrow> (x < 3)"
   7.232 -  using [[z3_new_extensions]]
   7.233 -  by smt2+
   7.234 +  using [[z3_extensions]]
   7.235 +  by smt+
   7.236  
   7.237  lemma
   7.238    "(x::int) = x div 1 * 1 + x mod 1"
   7.239    "x = x div 3 * 3 + x mod 3"
   7.240 -  using [[z3_new_extensions]]
   7.241 -  by smt2+
   7.242 +  using [[z3_extensions]]
   7.243 +  by smt+
   7.244  
   7.245  lemma
   7.246    "abs (x::int) \<ge> 0"
   7.247 @@ -341,7 +341,7 @@
   7.248    "(x \<ge> 0) = (abs x = x)"
   7.249    "(x \<le> 0) = (abs x = -x)"
   7.250    "abs (abs x) = abs x"
   7.251 -  by smt2+
   7.252 +  by smt+
   7.253  
   7.254  lemma
   7.255    "min (x::int) y \<le> x"
   7.256 @@ -350,7 +350,7 @@
   7.257    "min x y = min y x"
   7.258    "x \<ge> 0 \<longrightarrow> min x 0 = 0"
   7.259    "min x y \<le> abs (x + y)"
   7.260 -  by smt2+
   7.261 +  by smt+
   7.262  
   7.263  lemma
   7.264    "max (x::int) y \<ge> x"
   7.265 @@ -359,7 +359,7 @@
   7.266    "max x y = max y x"
   7.267    "x \<ge> 0 \<longrightarrow> max x 0 = x"
   7.268    "max x y \<ge> - abs x - abs y"
   7.269 -  by smt2+
   7.270 +  by smt+
   7.271  
   7.272  lemma
   7.273    "0 < (x::int) \<and> x \<le> 1 \<longrightarrow> x = 1"
   7.274 @@ -374,7 +374,7 @@
   7.275    "x \<le> y \<longrightarrow> y < z \<longrightarrow> x \<le> z"
   7.276    "x < y \<longrightarrow> y < z \<longrightarrow> x < z"
   7.277    "x < y \<and> y < z \<longrightarrow> \<not> (z < x)"
   7.278 -  by smt2+
   7.279 +  by smt+
   7.280  
   7.281  
   7.282  section {* Reals *}
   7.283 @@ -390,7 +390,7 @@
   7.284    "-123 + 345 < (567::real)"
   7.285    "(123456789::real) < 2345678901"
   7.286    "(-123456789::real) < 2345678901"
   7.287 -  by smt2+
   7.288 +  by smt+
   7.289  
   7.290  lemma
   7.291    "(x::real) + 0 = x"
   7.292 @@ -398,7 +398,7 @@
   7.293    "x + y = y + x"
   7.294    "x + (y + z) = (x + y) + z"
   7.295    "(x + y = 0) = (x = -y)"
   7.296 -  by smt2+
   7.297 +  by smt+
   7.298  
   7.299  lemma
   7.300    "(-1::real) = - 1"
   7.301 @@ -406,7 +406,7 @@
   7.302    "-(x::real) < 0 \<longleftrightarrow> x > 0"
   7.303    "x > 0 \<longrightarrow> -x < 0"
   7.304    "x < 0 \<longrightarrow> -x > 0"
   7.305 -  by smt2+
   7.306 +  by smt+
   7.307  
   7.308  lemma
   7.309    "(x::real) - 0 = x"
   7.310 @@ -415,7 +415,7 @@
   7.311    "x - y = -(y - x)"
   7.312    "x - y = -y + x"
   7.313    "x - y - z = x - (y + z)"
   7.314 -  by smt2+
   7.315 +  by smt+
   7.316  
   7.317  lemma
   7.318    "(x::real) * 0 = 0"
   7.319 @@ -425,7 +425,7 @@
   7.320    "x * -1 = -x"
   7.321    "-1 * x = -x"
   7.322    "3 * x = x * 3"
   7.323 -  by smt2+
   7.324 +  by smt+
   7.325  
   7.326  lemma
   7.327    "(1/2 :: real) < 1"
   7.328 @@ -436,16 +436,16 @@
   7.329    "(x::real) / 1 = x"
   7.330    "x > 0 \<longrightarrow> x / 3 < x"
   7.331    "x < 0 \<longrightarrow> x / 3 > x"
   7.332 -  using [[z3_new_extensions]]
   7.333 -  by smt2+
   7.334 +  using [[z3_extensions]]
   7.335 +  by smt+
   7.336  
   7.337  lemma
   7.338    "(3::real) * (x / 3) = x"
   7.339    "(x * 3) / 3 = x"
   7.340    "x > 0 \<longrightarrow> 2 * x / 3 < x"
   7.341    "x < 0 \<longrightarrow> 2 * x / 3 > x"
   7.342 -  using [[z3_new_extensions]]
   7.343 -  by smt2+
   7.344 +  using [[z3_extensions]]
   7.345 +  by smt+
   7.346  
   7.347  lemma
   7.348    "abs (x::real) \<ge> 0"
   7.349 @@ -453,7 +453,7 @@
   7.350    "(x \<ge> 0) = (abs x = x)"
   7.351    "(x \<le> 0) = (abs x = -x)"
   7.352    "abs (abs x) = abs x"
   7.353 -  by smt2+
   7.354 +  by smt+
   7.355  
   7.356  lemma
   7.357    "min (x::real) y \<le> x"
   7.358 @@ -462,7 +462,7 @@
   7.359    "min x y = min y x"
   7.360    "x \<ge> 0 \<longrightarrow> min x 0 = 0"
   7.361    "min x y \<le> abs (x + y)"
   7.362 -  by smt2+
   7.363 +  by smt+
   7.364  
   7.365  lemma
   7.366    "max (x::real) y \<ge> x"
   7.367 @@ -471,7 +471,7 @@
   7.368    "max x y = max y x"
   7.369    "x \<ge> 0 \<longrightarrow> max x 0 = x"
   7.370    "max x y \<ge> - abs x - abs y"
   7.371 -  by smt2+
   7.372 +  by smt+
   7.373  
   7.374  lemma
   7.375    "x \<le> (x::real)"
   7.376 @@ -484,7 +484,7 @@
   7.377    "x \<le> y \<longrightarrow> y < z \<longrightarrow> x \<le> z"
   7.378    "x < y \<longrightarrow> y < z \<longrightarrow> x < z"
   7.379    "x < y \<and> y < z \<longrightarrow> \<not> (z < x)"
   7.380 -  by smt2+
   7.381 +  by smt+
   7.382  
   7.383  
   7.384  section {* Datatypes, Records, and Typedefs *}
   7.385 @@ -507,7 +507,7 @@
   7.386    "(fst (x, y) = snd (x, y)) = (x = y)"
   7.387    "(fst p = snd p) = (p = (snd p, fst p))"
   7.388    using fst_conv snd_conv pair_collapse
   7.389 -  by smt2+
   7.390 +  by smt+
   7.391  
   7.392  lemma
   7.393    "[x] \<noteq> Nil"
   7.394 @@ -520,13 +520,13 @@
   7.395    "hd (tl [x, y, z]) = y"
   7.396    "tl (tl [x, y, z]) = [z]"
   7.397    using list.sel(1,3) list.simps
   7.398 -  by smt2+
   7.399 +  by smt+
   7.400  
   7.401  lemma
   7.402    "fst (hd [(a, b)]) = a"
   7.403    "snd (hd [(a, b)]) = b"
   7.404    using fst_conv snd_conv pair_collapse list.sel(1,3) list.simps
   7.405 -  by smt2+
   7.406 +  by smt+
   7.407  
   7.408  
   7.409  subsubsection {* Records *}
   7.410 @@ -544,7 +544,7 @@
   7.411    "cx p1 \<noteq> cx p2 \<longrightarrow> p1 \<noteq> p2"
   7.412    "cy p1 \<noteq> cy p2 \<longrightarrow> p1 \<noteq> p2"
   7.413    using point.simps
   7.414 -  by smt2+
   7.415 +  by smt+
   7.416  
   7.417  lemma
   7.418    "cx \<lparr> cx = 3, cy = 4 \<rparr> = 3"
   7.419 @@ -555,7 +555,7 @@
   7.420    "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
   7.421    "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr> = p"
   7.422    using point.simps
   7.423 -  by smt2+
   7.424 +  by smt+
   7.425  
   7.426  lemma
   7.427    "cy (p \<lparr> cx := a \<rparr>) = cy p"
   7.428 @@ -571,7 +571,7 @@
   7.429    "cy p1 \<noteq> cy p2 \<longrightarrow> p1 \<noteq> p2"
   7.430    "black p1 \<noteq> black p2 \<longrightarrow> p1 \<noteq> p2"
   7.431    using point.simps bw_point.simps
   7.432 -  by smt2+
   7.433 +  by smt+
   7.434  
   7.435  lemma
   7.436    "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> = 3"
   7.437 @@ -587,7 +587,7 @@
   7.438    "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
   7.439       p \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
   7.440    using point.simps bw_point.simps
   7.441 -  sorry (* smt2 FIXME: bad Z3 4.3.x proof *)
   7.442 +  sorry (* smt FIXME: bad Z3 4.3.x proof *)
   7.443  
   7.444  lemma
   7.445    "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> black := w \<rparr> = \<lparr> cx = 3, cy = 4, black = w \<rparr>"
   7.446 @@ -611,7 +611,7 @@
   7.447    "n0 \<noteq> n1"
   7.448    "plus' n1 n1 = n2"
   7.449    "plus' n0 n2 = n2"
   7.450 -  by (smt2 n0_def n1_def n2_def plus'_def Abs_int'_inverse Rep_int'_inverse UNIV_I)+
   7.451 +  by (smt n0_def n1_def n2_def plus'_def Abs_int'_inverse Rep_int'_inverse UNIV_I)+
   7.452  
   7.453  
   7.454  subsection {* With support by the SMT solver (but without proofs) *}
   7.455 @@ -632,8 +632,8 @@
   7.456    "(fst (x, y) = snd (x, y)) = (x = y)"
   7.457    "(fst p = snd p) = (p = (snd p, fst p))"
   7.458    using fst_conv snd_conv pair_collapse
   7.459 -  using [[smt2_oracle, z3_new_extensions]]
   7.460 -  by smt2+
   7.461 +  using [[smt_oracle, z3_extensions]]
   7.462 +  by smt+
   7.463  
   7.464  lemma
   7.465    "[x] \<noteq> Nil"
   7.466 @@ -646,15 +646,15 @@
   7.467    "hd (tl [x, y, z]) = y"
   7.468    "tl (tl [x, y, z]) = [z]"
   7.469    using list.sel(1,3)
   7.470 -  using [[smt2_oracle, z3_new_extensions]]
   7.471 -  by smt2+
   7.472 +  using [[smt_oracle, z3_extensions]]
   7.473 +  by smt+
   7.474  
   7.475  lemma
   7.476    "fst (hd [(a, b)]) = a"
   7.477    "snd (hd [(a, b)]) = b"
   7.478    using fst_conv snd_conv pair_collapse list.sel(1,3)
   7.479 -  using [[smt2_oracle, z3_new_extensions]]
   7.480 -  by smt2+
   7.481 +  using [[smt_oracle, z3_extensions]]
   7.482 +  by smt+
   7.483  
   7.484  
   7.485  subsubsection {* Records *}
   7.486 @@ -665,8 +665,8 @@
   7.487    "cx p1 \<noteq> cx p2 \<longrightarrow> p1 \<noteq> p2"
   7.488    "cy p1 \<noteq> cy p2 \<longrightarrow> p1 \<noteq> p2"
   7.489    using point.simps
   7.490 -  using [[smt2_oracle, z3_new_extensions]]
   7.491 -  by smt2+
   7.492 +  using [[smt_oracle, z3_extensions]]
   7.493 +  by smt+
   7.494  
   7.495  lemma
   7.496    "cx \<lparr> cx = 3, cy = 4 \<rparr> = 3"
   7.497 @@ -677,16 +677,16 @@
   7.498    "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
   7.499    "p = \<lparr> cx = 3, cy = 4 \<rparr> \<longrightarrow> p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr> = p"
   7.500    using point.simps
   7.501 -  using [[smt2_oracle, z3_new_extensions]]
   7.502 -  by smt2+
   7.503 +  using [[smt_oracle, z3_extensions]]
   7.504 +  by smt+
   7.505  
   7.506  lemma
   7.507    "cy (p \<lparr> cx := a \<rparr>) = cy p"
   7.508    "cx (p \<lparr> cy := a \<rparr>) = cx p"
   7.509    "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
   7.510    using point.simps
   7.511 -  using [[smt2_oracle, z3_new_extensions]]
   7.512 -  by smt2+
   7.513 +  using [[smt_oracle, z3_extensions]]
   7.514 +  by smt+
   7.515  
   7.516  lemma
   7.517    "p1 = p2 \<longrightarrow> cx p1 = cx p2"
   7.518 @@ -696,8 +696,8 @@
   7.519    "cy p1 \<noteq> cy p2 \<longrightarrow> p1 \<noteq> p2"
   7.520    "black p1 \<noteq> black p2 \<longrightarrow> p1 \<noteq> p2"
   7.521    using point.simps bw_point.simps
   7.522 -  using [[smt2_oracle, z3_new_extensions]]
   7.523 -  by smt2+
   7.524 +  using [[smt_oracle, z3_extensions]]
   7.525 +  by smt+
   7.526  
   7.527  lemma
   7.528    "cx \<lparr> cx = 3, cy = 4, black = b \<rparr> = 3"
   7.529 @@ -713,8 +713,8 @@
   7.530    "p = \<lparr> cx = 3, cy = 4, black = True \<rparr> \<longrightarrow>
   7.531       p \<lparr> black := True \<rparr> \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> = p"
   7.532    using point.simps bw_point.simps
   7.533 -  using [[smt2_oracle, z3_new_extensions]]
   7.534 -  by smt2+
   7.535 +  using [[smt_oracle, z3_extensions]]
   7.536 +  by smt+
   7.537  
   7.538  lemma
   7.539    "\<lparr> cx = 3, cy = 4, black = b \<rparr> \<lparr> black := w \<rparr> = \<lparr> cx = 3, cy = 4, black = w \<rparr>"
   7.540 @@ -726,8 +726,8 @@
   7.541    "p \<lparr> cx := 3 \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> black := True \<rparr> =
   7.542       p \<lparr> black := True \<rparr> \<lparr> cy := 4 \<rparr> \<lparr> cx := 3 \<rparr>"
   7.543    using point.simps bw_point.simps
   7.544 -  using [[smt2_oracle, z3_new_extensions]]
   7.545 -  by smt2
   7.546 +  using [[smt_oracle, z3_extensions]]
   7.547 +  by smt
   7.548  
   7.549  
   7.550  subsubsection {* Type definitions *}
   7.551 @@ -736,8 +736,8 @@
   7.552    "n0 \<noteq> n1"
   7.553    "plus' n1 n1 = n2"
   7.554    "plus' n0 n2 = n2"
   7.555 -  using [[smt2_oracle, z3_new_extensions]]
   7.556 -  by (smt2 n0_def n1_def n2_def plus'_def)+
   7.557 +  using [[smt_oracle, z3_extensions]]
   7.558 +  by (smt n0_def n1_def n2_def plus'_def)+
   7.559  
   7.560  
   7.561  section {* Function updates *}
   7.562 @@ -751,14 +751,14 @@
   7.563    "i1 = i2 \<longrightarrow> (f (i1 := v1, i2 := v2)) i1 = v2"
   7.564    "i1 \<noteq> i2 \<and>i1 \<noteq> i3 \<and>  i2 \<noteq> i3 \<longrightarrow> (f (i1 := v1, i2 := v2)) i3 = f i3"
   7.565    using fun_upd_same fun_upd_apply
   7.566 -  by smt2+
   7.567 +  by smt+
   7.568  
   7.569  
   7.570  section {* Sets *}
   7.571  
   7.572  lemma Empty: "x \<notin> {}" by simp
   7.573  
   7.574 -lemmas smt2_sets = Empty UNIV_I Un_iff Int_iff
   7.575 +lemmas smt_sets = Empty UNIV_I Un_iff Int_iff
   7.576  
   7.577  lemma
   7.578    "x \<notin> {}"
   7.579 @@ -776,6 +776,6 @@
   7.580    "x \<in> P \<inter> P \<longleftrightarrow> x \<in> P"
   7.581    "x \<in> P \<inter> (Q \<inter> R) \<longleftrightarrow> x \<in> (P \<inter> Q) \<inter> R"
   7.582    "{x. x \<in> P} = {y. y \<in> P}"
   7.583 -  by (smt2 smt2_sets)+
   7.584 +  by (smt smt_sets)+
   7.585  
   7.586  end
     8.1 --- a/src/HOL/SMT_Examples/SMT_Word_Examples.thy	Thu Aug 28 00:40:38 2014 +0200
     8.2 +++ b/src/HOL/SMT_Examples/SMT_Word_Examples.thy	Thu Aug 28 00:40:38 2014 +0200
     8.3 @@ -8,10 +8,10 @@
     8.4  imports "~~/src/HOL/Word/Word"
     8.5  begin
     8.6  
     8.7 -declare [[smt2_oracle = true]]
     8.8 -declare [[z3_new_extensions = true]]
     8.9 -declare [[smt2_certificates = "SMT_Word_Examples.certs2"]]
    8.10 -declare [[smt2_read_only_certificates = true]]
    8.11 +declare [[smt_oracle = true]]
    8.12 +declare [[z3_extensions = true]]
    8.13 +declare [[smt_certificates = "SMT_Word_Examples.certs2"]]
    8.14 +declare [[smt_read_only_certificates = true]]
    8.15  
    8.16  text {*
    8.17  Currently, there is no proof reconstruction for words.
    8.18 @@ -21,36 +21,36 @@
    8.19  
    8.20  section {* Bitvector numbers *}
    8.21  
    8.22 -lemma "(27 :: 4 word) = -5" by smt2
    8.23 -lemma "(27 :: 4 word) = 11" by smt2
    8.24 -lemma "23 < (27::8 word)" by smt2
    8.25 -lemma "27 + 11 = (6::5 word)" by smt2
    8.26 -lemma "7 * 3 = (21::8 word)" by smt2
    8.27 -lemma "11 - 27 = (-16::8 word)" by smt2
    8.28 -lemma "- -11 = (11::5 word)" by smt2
    8.29 -lemma "-40 + 1 = (-39::7 word)" by smt2
    8.30 -lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by smt2
    8.31 -lemma "x = (5 :: 4 word) \<Longrightarrow> 4 * x = 4" by smt2
    8.32 +lemma "(27 :: 4 word) = -5" by smt
    8.33 +lemma "(27 :: 4 word) = 11" by smt
    8.34 +lemma "23 < (27::8 word)" by smt
    8.35 +lemma "27 + 11 = (6::5 word)" by smt
    8.36 +lemma "7 * 3 = (21::8 word)" by smt
    8.37 +lemma "11 - 27 = (-16::8 word)" by smt
    8.38 +lemma "- -11 = (11::5 word)" by smt
    8.39 +lemma "-40 + 1 = (-39::7 word)" by smt
    8.40 +lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by smt
    8.41 +lemma "x = (5 :: 4 word) \<Longrightarrow> 4 * x = 4" by smt
    8.42  
    8.43  
    8.44  section {* Bit-level logic *}
    8.45  
    8.46 -lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by smt2
    8.47 -lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by smt2
    8.48 -lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by smt2
    8.49 -lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by smt2
    8.50 -lemma "word_cat (27::4 word) (27::8 word) = (2843::12 word)" by smt2
    8.51 -lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)" by smt2
    8.52 -lemma "slice 1 (0b10110 :: 4 word) = (0b11 :: 2 word)" by smt2
    8.53 -lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by smt2
    8.54 -lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by smt2
    8.55 -lemma "0b10011 << 2 = (0b1001100::8 word)" by smt2
    8.56 -lemma "0b11001 >> 2 = (0b110::8 word)" by smt2
    8.57 -lemma "0b10011 >>> 2 = (0b100::8 word)" by smt2
    8.58 -lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by smt2
    8.59 -lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by smt2
    8.60 -lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)" by smt2
    8.61 -lemma "w < 256 \<Longrightarrow> (w :: 16 word) AND 0x00FF = w" by smt2
    8.62 +lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by smt
    8.63 +lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by smt
    8.64 +lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by smt
    8.65 +lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by smt
    8.66 +lemma "word_cat (27::4 word) (27::8 word) = (2843::12 word)" by smt
    8.67 +lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)" by smt
    8.68 +lemma "slice 1 (0b10110 :: 4 word) = (0b11 :: 2 word)" by smt
    8.69 +lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by smt
    8.70 +lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by smt
    8.71 +lemma "0b10011 << 2 = (0b1001100::8 word)" by smt
    8.72 +lemma "0b11001 >> 2 = (0b110::8 word)" by smt
    8.73 +lemma "0b10011 >>> 2 = (0b100::8 word)" by smt
    8.74 +lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by smt
    8.75 +lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by smt
    8.76 +lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)" by smt
    8.77 +lemma "w < 256 \<Longrightarrow> (w :: 16 word) AND 0x00FF = w" by smt
    8.78  
    8.79  
    8.80  section {* Combined integer-bitvector properties *}
    8.81 @@ -62,8 +62,8 @@
    8.82        and "bv2int 3 = 3"
    8.83        and "\<forall>x::2 word. bv2int x > 0"
    8.84    shows "\<forall>i::int. i < 0 \<longrightarrow> (\<forall>x::2 word. bv2int x > i)"
    8.85 -  using assms by smt2
    8.86 +  using assms by smt
    8.87  
    8.88 -lemma "P (0 \<le> (a :: 4 word)) = P True" by smt2
    8.89 +lemma "P (0 \<le> (a :: 4 word)) = P True" by smt
    8.90  
    8.91  end
     9.1 --- a/src/HOL/SMT_Examples/boogie.ML	Thu Aug 28 00:40:38 2014 +0200
     9.2 +++ b/src/HOL/SMT_Examples/boogie.ML	Thu Aug 28 00:40:38 2014 +0200
     9.3 @@ -92,18 +92,18 @@
     9.4  fun mk_quant q (Free (x, T)) t = q T $ absfree (x, T) t
     9.5    | mk_quant _ t _ = raise TERM ("bad variable", [t])
     9.6  
     9.7 -val patternT = @{typ "SMT2.pattern"}
     9.8 +val patternT = @{typ "SMT.pattern"}
     9.9  
    9.10  fun mk_pat t =
    9.11 -  Const (@{const_name "SMT2.pat"}, Term.fastype_of t --> patternT) $ t
    9.12 +  Const (@{const_name "SMT.pat"}, Term.fastype_of t --> patternT) $ t
    9.13  
    9.14  fun mk_pattern [] = raise TERM ("mk_pattern", [])
    9.15 -  | mk_pattern ts = SMT2_Util.mk_symb_list patternT (map mk_pat ts)
    9.16 +  | mk_pattern ts = SMT_Util.mk_symb_list patternT (map mk_pat ts)
    9.17  
    9.18  fun mk_trigger [] t = t
    9.19    | mk_trigger pss t =
    9.20 -      @{term "SMT2.trigger"} $
    9.21 -        SMT2_Util.mk_symb_list @{typ "SMT2.pattern SMT2.symb_list"} (map mk_pattern pss) $ t
    9.22 +      @{term "SMT.trigger"} $
    9.23 +        SMT_Util.mk_symb_list @{typ "SMT.pattern SMT.symb_list"} (map mk_pattern pss) $ t
    9.24  
    9.25  
    9.26  (* parser *)
    9.27 @@ -247,7 +247,7 @@
    9.28    [@{thm fun_upd_same}, @{thm fun_upd_apply}]
    9.29  
    9.30  fun boogie_tac ctxt axioms =
    9.31 -  ALLGOALS (SMT2_Solver.smt2_tac ctxt (boogie_rules @ axioms))
    9.32 +  ALLGOALS (SMT_Solver.smt_tac ctxt (boogie_rules @ axioms))
    9.33  
    9.34  fun boogie_prove thy lines =
    9.35    let
    10.1 --- a/src/HOL/Sledgehammer.thy	Thu Aug 28 00:40:38 2014 +0200
    10.2 +++ b/src/HOL/Sledgehammer.thy	Thu Aug 28 00:40:38 2014 +0200
    10.3 @@ -7,7 +7,7 @@
    10.4  header {* Sledgehammer: Isabelle--ATP Linkup *}
    10.5  
    10.6  theory Sledgehammer
    10.7 -imports Presburger SMT2
    10.8 +imports Presburger SMT
    10.9  keywords "sledgehammer" :: diag and "sledgehammer_params" :: thy_decl
   10.10  begin
   10.11  
   10.12 @@ -26,7 +26,7 @@
   10.13  ML_file "Tools/Sledgehammer/sledgehammer_isar.ML"
   10.14  ML_file "Tools/Sledgehammer/sledgehammer_prover.ML"
   10.15  ML_file "Tools/Sledgehammer/sledgehammer_prover_atp.ML"
   10.16 -ML_file "Tools/Sledgehammer/sledgehammer_prover_smt2.ML"
   10.17 +ML_file "Tools/Sledgehammer/sledgehammer_prover_smt.ML"
   10.18  ML_file "Tools/Sledgehammer/sledgehammer_prover_minimize.ML"
   10.19  ML_file "Tools/Sledgehammer/sledgehammer_mepo.ML"
   10.20  ML_file "Tools/Sledgehammer/sledgehammer_mash.ML"
    11.1 --- a/src/HOL/TPTP/mash_eval.ML	Thu Aug 28 00:40:38 2014 +0200
    11.2 +++ b/src/HOL/TPTP/mash_eval.ML	Thu Aug 28 00:40:38 2014 +0200
    11.3 @@ -104,7 +104,7 @@
    11.4                in
    11.5                  Config.put atp_dest_dir dir
    11.6                  #> Config.put atp_problem_prefix (prob_prefix ^ "__")
    11.7 -                #> Config.put SMT2_Config.debug_files (dir ^ "/" ^ prob_prefix)
    11.8 +                #> Config.put SMT_Config.debug_files (dir ^ "/" ^ prob_prefix)
    11.9                end
   11.10              | set_file_name _ NONE = I
   11.11  
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Tools/SMT/smt_builtin.ML	Thu Aug 28 00:40:38 2014 +0200
    12.3 @@ -0,0 +1,222 @@
    12.4 +(*  Title:      HOL/Tools/SMT/smt_builtin.ML
    12.5 +    Author:     Sascha Boehme, TU Muenchen
    12.6 +
    12.7 +Tables of types and terms directly supported by SMT solvers.
    12.8 +*)
    12.9 +
   12.10 +signature SMT_BUILTIN =
   12.11 +sig
   12.12 +  (*for experiments*)
   12.13 +  val filter_builtins: (typ -> bool) -> Proof.context -> Proof.context
   12.14 +
   12.15 +  (*built-in types*)
   12.16 +  val add_builtin_typ: SMT_Util.class ->
   12.17 +    typ * (typ -> string option) * (typ -> int -> string option) -> Context.generic ->
   12.18 +    Context.generic
   12.19 +  val add_builtin_typ_ext: typ * (typ -> bool) -> Context.generic ->
   12.20 +    Context.generic
   12.21 +  val dest_builtin_typ: Proof.context -> typ -> string option
   12.22 +  val is_builtin_typ_ext: Proof.context -> typ -> bool
   12.23 +
   12.24 +  (*built-in numbers*)
   12.25 +  val dest_builtin_num: Proof.context -> term -> (string * typ) option
   12.26 +  val is_builtin_num: Proof.context -> term -> bool
   12.27 +  val is_builtin_num_ext: Proof.context -> term -> bool
   12.28 +
   12.29 +  (*built-in functions*)
   12.30 +  type 'a bfun = Proof.context -> typ -> term list -> 'a
   12.31 +  type bfunr = string * int * term list * (term list -> term)
   12.32 +  val add_builtin_fun: SMT_Util.class -> (string * typ) * bfunr option bfun -> Context.generic ->
   12.33 +    Context.generic
   12.34 +  val add_builtin_fun': SMT_Util.class -> term * string -> Context.generic -> Context.generic
   12.35 +  val add_builtin_fun_ext: (string * typ) * term list bfun -> Context.generic -> Context.generic
   12.36 +  val add_builtin_fun_ext': string * typ -> Context.generic -> Context.generic
   12.37 +  val add_builtin_fun_ext'': string -> Context.generic -> Context.generic
   12.38 +  val dest_builtin_fun: Proof.context -> string * typ -> term list -> bfunr option
   12.39 +  val dest_builtin_eq: Proof.context -> term -> term -> bfunr option
   12.40 +  val dest_builtin_pred: Proof.context -> string * typ -> term list -> bfunr option
   12.41 +  val dest_builtin_conn: Proof.context -> string * typ -> term list -> bfunr option
   12.42 +  val dest_builtin: Proof.context -> string * typ -> term list -> bfunr option
   12.43 +  val dest_builtin_ext: Proof.context -> string * typ -> term list -> term list option
   12.44 +  val is_builtin_fun: Proof.context -> string * typ -> term list -> bool
   12.45 +  val is_builtin_fun_ext: Proof.context -> string * typ -> term list -> bool
   12.46 +end;
   12.47 +
   12.48 +structure SMT_Builtin: SMT_BUILTIN =
   12.49 +struct
   12.50 +
   12.51 +
   12.52 +(* built-in tables *)
   12.53 +
   12.54 +datatype ('a, 'b) kind = Ext of 'a | Int of 'b
   12.55 +
   12.56 +type ('a, 'b) ttab = ((typ * ('a, 'b) kind) Ord_List.T) SMT_Util.dict
   12.57 +
   12.58 +fun typ_ord ((T, _), (U, _)) =
   12.59 +  let
   12.60 +    fun tord (TVar _, Type _) = GREATER
   12.61 +      | tord (Type _, TVar _) = LESS
   12.62 +      | tord (Type (n, Ts), Type (m, Us)) =
   12.63 +          if n = m then list_ord tord (Ts, Us)
   12.64 +          else Term_Ord.typ_ord (T, U)
   12.65 +      | tord TU = Term_Ord.typ_ord TU
   12.66 +  in tord (T, U) end
   12.67 +
   12.68 +fun insert_ttab cs T f =
   12.69 +  SMT_Util.dict_map_default (cs, [])
   12.70 +    (Ord_List.insert typ_ord (perhaps (try Logic.varifyT_global) T, f))
   12.71 +
   12.72 +fun merge_ttab ttabp = SMT_Util.dict_merge (Ord_List.merge typ_ord) ttabp
   12.73 +
   12.74 +fun lookup_ttab ctxt ttab T =
   12.75 +  let fun match (U, _) = Sign.typ_instance (Proof_Context.theory_of ctxt) (T, U)
   12.76 +  in
   12.77 +    get_first (find_first match) (SMT_Util.dict_lookup ttab (SMT_Config.solver_class_of ctxt))
   12.78 +  end
   12.79 +
   12.80 +type ('a, 'b) btab = ('a, 'b) ttab Symtab.table
   12.81 +
   12.82 +fun insert_btab cs n T f =
   12.83 +  Symtab.map_default (n, []) (insert_ttab cs T f)
   12.84 +
   12.85 +fun merge_btab btabp = Symtab.join (K merge_ttab) btabp
   12.86 +
   12.87 +fun lookup_btab ctxt btab (n, T) =
   12.88 +  (case Symtab.lookup btab n of
   12.89 +    NONE => NONE
   12.90 +  | SOME ttab => lookup_ttab ctxt ttab T)
   12.91 +
   12.92 +type 'a bfun = Proof.context -> typ -> term list -> 'a
   12.93 +
   12.94 +type bfunr = string * int * term list * (term list -> term)
   12.95 +
   12.96 +structure Builtins = Generic_Data
   12.97 +(
   12.98 +  type T =
   12.99 +    (typ -> bool, (typ -> string option) * (typ -> int -> string option)) ttab *
  12.100 +    (term list bfun, bfunr option bfun) btab
  12.101 +  val empty = ([], Symtab.empty)
  12.102 +  val extend = I
  12.103 +  fun merge ((t1, b1), (t2, b2)) = (merge_ttab (t1, t2), merge_btab (b1, b2))
  12.104 +)
  12.105 +
  12.106 +fun filter_ttab keep_T = map (apsnd (filter (keep_T o fst)))
  12.107 +
  12.108 +fun filter_builtins keep_T =
  12.109 +  Context.proof_map (Builtins.map (fn (ttab, btab) =>
  12.110 +    (filter_ttab keep_T ttab, Symtab.map (K (filter_ttab keep_T)) btab)))
  12.111 +
  12.112 +
  12.113 +(* built-in types *)
  12.114 +
  12.115 +fun add_builtin_typ cs (T, f, g) =
  12.116 +  Builtins.map (apfst (insert_ttab cs T (Int (f, g))))
  12.117 +
  12.118 +fun add_builtin_typ_ext (T, f) = Builtins.map (apfst (insert_ttab SMT_Util.basicC T (Ext f)))
  12.119 +
  12.120 +fun lookup_builtin_typ ctxt =
  12.121 +  lookup_ttab ctxt (fst (Builtins.get (Context.Proof ctxt)))
  12.122 +
  12.123 +fun dest_builtin_typ ctxt T =
  12.124 +  (case lookup_builtin_typ ctxt T of
  12.125 +    SOME (_, Int (f, _)) => f T
  12.126 +  | _ => NONE)
  12.127 +
  12.128 +fun is_builtin_typ_ext ctxt T =
  12.129 +  (case lookup_builtin_typ ctxt T of
  12.130 +    SOME (_, Int (f, _)) => is_some (f T)
  12.131 +  | SOME (_, Ext f) => f T
  12.132 +  | NONE => false)
  12.133 +
  12.134 +
  12.135 +(* built-in numbers *)
  12.136 +
  12.137 +fun dest_builtin_num ctxt t =
  12.138 +  (case try HOLogic.dest_number t of
  12.139 +    NONE => NONE
  12.140 +  | SOME (T, i) =>
  12.141 +      if i < 0 then NONE else
  12.142 +        (case lookup_builtin_typ ctxt T of
  12.143 +          SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
  12.144 +        | _ => NONE))
  12.145 +
  12.146 +val is_builtin_num = is_some oo dest_builtin_num
  12.147 +
  12.148 +fun is_builtin_num_ext ctxt t =
  12.149 +  (case try HOLogic.dest_number t of
  12.150 +    NONE => false
  12.151 +  | SOME (T, _) => is_builtin_typ_ext ctxt T)
  12.152 +
  12.153 +
  12.154 +(* built-in functions *)
  12.155 +
  12.156 +fun add_builtin_fun cs ((n, T), f) =
  12.157 +  Builtins.map (apsnd (insert_btab cs n T (Int f)))
  12.158 +
  12.159 +fun add_builtin_fun' cs (t, n) =
  12.160 +  let
  12.161 +    val c as (m, T) = Term.dest_Const t
  12.162 +    fun app U ts = Term.list_comb (Const (m, U), ts)
  12.163 +    fun bfun _ U ts = SOME (n, length (Term.binder_types T), ts, app U)
  12.164 +  in add_builtin_fun cs (c, bfun) end
  12.165 +
  12.166 +fun add_builtin_fun_ext ((n, T), f) =
  12.167 +  Builtins.map (apsnd (insert_btab SMT_Util.basicC n T (Ext f)))
  12.168 +
  12.169 +fun add_builtin_fun_ext' c = add_builtin_fun_ext (c, fn _ => fn _ => I)
  12.170 +
  12.171 +fun add_builtin_fun_ext'' n context =
  12.172 +  let val thy = Context.theory_of context
  12.173 +  in add_builtin_fun_ext' (n, Sign.the_const_type thy n) context end
  12.174 +
  12.175 +fun lookup_builtin_fun ctxt =
  12.176 +  lookup_btab ctxt (snd (Builtins.get (Context.Proof ctxt)))
  12.177 +
  12.178 +fun dest_builtin_fun ctxt (c as (_, T)) ts =
  12.179 +  (case lookup_builtin_fun ctxt c of
  12.180 +    SOME (_, Int f) => f ctxt T ts
  12.181 +  | _ => NONE)
  12.182 +
  12.183 +fun dest_builtin_eq ctxt t u =
  12.184 +  let
  12.185 +    val aT = TFree (Name.aT, @{sort type})
  12.186 +    val c = (@{const_name HOL.eq}, aT --> aT --> @{typ bool})
  12.187 +    fun mk ts = Term.list_comb (HOLogic.eq_const (Term.fastype_of (hd ts)), ts)
  12.188 +  in
  12.189 +    dest_builtin_fun ctxt c []
  12.190 +    |> Option.map (fn (n, i, _, _) => (n, i, [t, u], mk))
  12.191 +  end
  12.192 +
  12.193 +fun special_builtin_fun pred ctxt (c as (_, T)) ts =
  12.194 +  if pred (Term.body_type T, Term.binder_types T) then
  12.195 +    dest_builtin_fun ctxt c ts
  12.196 +  else NONE
  12.197 +
  12.198 +fun dest_builtin_pred ctxt = special_builtin_fun (equal @{typ bool} o fst) ctxt
  12.199 +
  12.200 +fun dest_builtin_conn ctxt =
  12.201 +  special_builtin_fun (forall (equal @{typ bool}) o (op ::)) ctxt
  12.202 +
  12.203 +fun dest_builtin ctxt c ts =
  12.204 +  let val t = Term.list_comb (Const c, ts)
  12.205 +  in
  12.206 +    (case dest_builtin_num ctxt t of
  12.207 +      SOME (n, _) => SOME (n, 0, [], K t)
  12.208 +    | NONE => dest_builtin_fun ctxt c ts)
  12.209 +  end
  12.210 +
  12.211 +fun dest_builtin_fun_ext ctxt (c as (_, T)) ts =
  12.212 +  (case lookup_builtin_fun ctxt c of
  12.213 +    SOME (_, Int f) => f ctxt T ts |> Option.map (fn (_, _, us, _) => us)
  12.214 +  | SOME (_, Ext f) => SOME (f ctxt T ts)
  12.215 +  | NONE => NONE)
  12.216 +
  12.217 +fun dest_builtin_ext ctxt c ts =
  12.218 +  if is_builtin_num_ext ctxt (Term.list_comb (Const c, ts)) then SOME []
  12.219 +  else dest_builtin_fun_ext ctxt c ts
  12.220 +
  12.221 +fun is_builtin_fun ctxt c ts = is_some (dest_builtin_fun ctxt c ts)
  12.222 +
  12.223 +fun is_builtin_fun_ext ctxt c ts = is_some (dest_builtin_fun_ext ctxt c ts)
  12.224 +
  12.225 +end;
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Tools/SMT/smt_config.ML	Thu Aug 28 00:40:38 2014 +0200
    13.3 @@ -0,0 +1,249 @@
    13.4 +(*  Title:      HOL/Tools/SMT/smt_config.ML
    13.5 +    Author:     Sascha Boehme, TU Muenchen
    13.6 +
    13.7 +Configuration options and diagnostic tools for SMT.
    13.8 +*)
    13.9 +
   13.10 +signature SMT_CONFIG =
   13.11 +sig
   13.12 +  (*solver*)
   13.13 +  type solver_info = {
   13.14 +    name: string,
   13.15 +    class: Proof.context -> SMT_Util.class,
   13.16 +    avail: unit -> bool,
   13.17 +    options: Proof.context -> string list }
   13.18 +  val add_solver: solver_info -> Context.generic -> Context.generic
   13.19 +  val set_solver_options: string * string -> Context.generic -> Context.generic
   13.20 +  val is_available: Proof.context -> string -> bool
   13.21 +  val available_solvers_of: Proof.context -> string list
   13.22 +  val select_solver: string -> Context.generic -> Context.generic
   13.23 +  val solver_of: Proof.context -> string
   13.24 +  val solver_class_of: Proof.context -> SMT_Util.class
   13.25 +  val solver_options_of: Proof.context -> string list
   13.26 +
   13.27 +  (*options*)
   13.28 +  val oracle: bool Config.T
   13.29 +  val timeout: real Config.T
   13.30 +  val random_seed: int Config.T
   13.31 +  val read_only_certificates: bool Config.T
   13.32 +  val verbose: bool Config.T
   13.33 +  val trace: bool Config.T
   13.34 +  val monomorph_limit: int Config.T
   13.35 +  val monomorph_instances: int Config.T
   13.36 +  val infer_triggers: bool Config.T
   13.37 +  val debug_files: string Config.T
   13.38 +  val sat_solver: string Config.T
   13.39 +
   13.40 +  (*tools*)
   13.41 +  val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
   13.42 +
   13.43 +  (*diagnostics*)
   13.44 +  val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
   13.45 +  val verbose_msg: Proof.context -> ('a -> string) -> 'a -> unit
   13.46 +
   13.47 +  (*certificates*)
   13.48 +  val select_certificates: string -> Context.generic -> Context.generic
   13.49 +  val certificates_of: Proof.context -> Cache_IO.cache option
   13.50 +
   13.51 +  (*setup*)
   13.52 +  val print_setup: Proof.context -> unit
   13.53 +end;
   13.54 +
   13.55 +structure SMT_Config: SMT_CONFIG =
   13.56 +struct
   13.57 +
   13.58 +(* solver *)
   13.59 +
   13.60 +type solver_info = {
   13.61 +  name: string,
   13.62 +  class: Proof.context -> SMT_Util.class,
   13.63 +  avail: unit -> bool,
   13.64 +  options: Proof.context -> string list}
   13.65 +
   13.66 +(* FIXME just one data slot (record) per program unit *)
   13.67 +structure Solvers = Generic_Data
   13.68 +(
   13.69 +  type T = (solver_info * string list) Symtab.table * string option
   13.70 +  val empty = (Symtab.empty, NONE)
   13.71 +  val extend = I
   13.72 +  fun merge ((ss1, s1), (ss2, s2)) =
   13.73 +    (Symtab.merge (K true) (ss1, ss2), merge_options (s1, s2))
   13.74 +)
   13.75 +
   13.76 +fun set_solver_options (name, options) =
   13.77 +  let val opts = String.tokens (Symbol.is_ascii_blank o str) options
   13.78 +  in Solvers.map (apfst (Symtab.map_entry name (apsnd (K opts)))) end
   13.79 +
   13.80 +fun add_solver (info as {name, ...} : solver_info) context =
   13.81 +  if Symtab.defined (fst (Solvers.get context)) name then
   13.82 +    error ("Solver already registered: " ^ quote name)
   13.83 +  else
   13.84 +    context
   13.85 +    |> Solvers.map (apfst (Symtab.update (name, (info, []))))
   13.86 +    |> Context.map_theory (Attrib.setup (Binding.name (name ^ "_options"))
   13.87 +        (Scan.lift (@{keyword "="} |-- Args.name) >>
   13.88 +          (Thm.declaration_attribute o K o set_solver_options o pair name))
   13.89 +        ("Additional command line options for SMT solver " ^ quote name))
   13.90 +
   13.91 +fun all_solvers_of ctxt = Symtab.keys (fst (Solvers.get (Context.Proof ctxt)))
   13.92 +
   13.93 +fun solver_name_of ctxt = snd (Solvers.get (Context.Proof ctxt))
   13.94 +
   13.95 +fun is_available ctxt name =
   13.96 +  (case Symtab.lookup (fst (Solvers.get (Context.Proof ctxt))) name of
   13.97 +    SOME ({avail, ...}, _) => avail ()
   13.98 +  | NONE => false)
   13.99 +
  13.100 +fun available_solvers_of ctxt =
  13.101 +  filter (is_available ctxt) (all_solvers_of ctxt)
  13.102 +
  13.103 +fun warn_solver (Context.Proof ctxt) name =
  13.104 +      if Context_Position.is_visible ctxt then
  13.105 +        warning ("The SMT solver " ^ quote name ^ " is not installed")
  13.106 +      else ()
  13.107 +  | warn_solver _ _ = ()
  13.108 +
  13.109 +fun select_solver name context =
  13.110 +  let
  13.111 +    val ctxt = Context.proof_of context
  13.112 +    val upd = Solvers.map (apsnd (K (SOME name)))
  13.113 +  in
  13.114 +    if not (member (op =) (all_solvers_of ctxt) name) then
  13.115 +      error ("Trying to select unknown solver: " ^ quote name)
  13.116 +    else if not (is_available ctxt name) then
  13.117 +      (warn_solver context name; upd context)
  13.118 +    else upd context
  13.119 +  end
  13.120 +
  13.121 +fun no_solver_err () = error "No SMT solver selected"
  13.122 +
  13.123 +fun solver_of ctxt =
  13.124 +  (case solver_name_of ctxt of
  13.125 +    SOME name => name
  13.126 +  | NONE => no_solver_err ())
  13.127 +
  13.128 +fun solver_info_of default select ctxt =
  13.129 +  (case Solvers.get (Context.Proof ctxt) of
  13.130 +    (solvers, SOME name) => select (Symtab.lookup solvers name)
  13.131 +  | (_, NONE) => default ())
  13.132 +
  13.133 +fun solver_class_of ctxt =
  13.134 +  let fun class_of ({class, ...}: solver_info, _) = class ctxt
  13.135 +  in solver_info_of no_solver_err (class_of o the) ctxt end
  13.136 +
  13.137 +fun solver_options_of ctxt =
  13.138 +  let
  13.139 +    fun all_options NONE = []
  13.140 +      | all_options (SOME ({options, ...} : solver_info, opts)) =
  13.141 +          opts @ options ctxt
  13.142 +  in solver_info_of (K []) all_options ctxt end
  13.143 +
  13.144 +val setup_solver =
  13.145 +  Attrib.setup @{binding smt_solver}
  13.146 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
  13.147 +      (Thm.declaration_attribute o K o select_solver))
  13.148 +    "SMT solver configuration"
  13.149 +
  13.150 +
  13.151 +(* options *)
  13.152 +
  13.153 +val oracle = Attrib.setup_config_bool @{binding smt_oracle} (K true)
  13.154 +val timeout = Attrib.setup_config_real @{binding smt_timeout} (K 30.0)
  13.155 +val random_seed = Attrib.setup_config_int @{binding smt_random_seed} (K 1)
  13.156 +val read_only_certificates = Attrib.setup_config_bool @{binding smt_read_only_certificates} (K false)
  13.157 +val verbose = Attrib.setup_config_bool @{binding smt_verbose} (K true)
  13.158 +val trace = Attrib.setup_config_bool @{binding smt_trace} (K false)
  13.159 +val monomorph_limit = Attrib.setup_config_int @{binding smt_monomorph_limit} (K 10)
  13.160 +val monomorph_instances = Attrib.setup_config_int @{binding smt_monomorph_instances} (K 500)
  13.161 +val infer_triggers = Attrib.setup_config_bool @{binding smt_infer_triggers} (K false)
  13.162 +val debug_files = Attrib.setup_config_string @{binding smt_debug_files} (K "")
  13.163 +val sat_solver = Attrib.setup_config_string @{binding smt_sat_solver} (K "cdclite")
  13.164 +
  13.165 +
  13.166 +(* diagnostics *)
  13.167 +
  13.168 +fun cond_trace flag f x = if flag then tracing ("SMT: " ^ f x) else ()
  13.169 +
  13.170 +fun verbose_msg ctxt = cond_trace (Config.get ctxt verbose)
  13.171 +
  13.172 +fun trace_msg ctxt = cond_trace (Config.get ctxt trace)
  13.173 +
  13.174 +
  13.175 +(* tools *)
  13.176 +
  13.177 +fun with_timeout ctxt f x =
  13.178 +  TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) f x
  13.179 +  handle TimeLimit.TimeOut => raise SMT_Failure.SMT SMT_Failure.Time_Out
  13.180 +
  13.181 +
  13.182 +(* certificates *)
  13.183 +
  13.184 +(* FIXME just one data slot (record) per program unit *)
  13.185 +structure Certificates = Generic_Data
  13.186 +(
  13.187 +  type T = Cache_IO.cache option
  13.188 +  val empty = NONE
  13.189 +  val extend = I
  13.190 +  fun merge (s, _) = s  (* FIXME merge options!? *)
  13.191 +)
  13.192 +
  13.193 +val get_certificates_path =
  13.194 +  Option.map (Cache_IO.cache_path_of) o Certificates.get o Context.Proof
  13.195 +
  13.196 +fun select_certificates name context = context |> Certificates.put (
  13.197 +  if name = "" then NONE
  13.198 +  else
  13.199 +    Path.explode name
  13.200 +    |> Path.append (Resources.master_directory (Context.theory_of context))
  13.201 +    |> SOME o Cache_IO.unsynchronized_init)
  13.202 +
  13.203 +val certificates_of = Certificates.get o Context.Proof
  13.204 +
  13.205 +val setup_certificates =
  13.206 +  Attrib.setup @{binding smt_certificates}
  13.207 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
  13.208 +      (Thm.declaration_attribute o K o select_certificates))
  13.209 +    "SMT certificates configuration"
  13.210 +
  13.211 +
  13.212 +(* setup *)
  13.213 +
  13.214 +val _ = Theory.setup (
  13.215 +  setup_solver #>
  13.216 +  setup_certificates)
  13.217 +
  13.218 +fun print_setup ctxt =
  13.219 +  let
  13.220 +    fun string_of_bool b = if b then "true" else "false"
  13.221 +
  13.222 +    val names = available_solvers_of ctxt
  13.223 +    val ns = if null names then ["(none)"] else sort_strings names
  13.224 +    val n = the_default "(none)" (solver_name_of ctxt)
  13.225 +    val opts = solver_options_of ctxt
  13.226 +
  13.227 +    val t = string_of_real (Config.get ctxt timeout)
  13.228 +
  13.229 +    val certs_filename =
  13.230 +      (case get_certificates_path ctxt of
  13.231 +        SOME path => Path.print path
  13.232 +      | NONE => "(disabled)")
  13.233 +  in
  13.234 +    Pretty.writeln (Pretty.big_list "SMT setup:" [
  13.235 +      Pretty.str ("Current SMT solver: " ^ n),
  13.236 +      Pretty.str ("Current SMT solver options: " ^ space_implode " " opts),
  13.237 +      Pretty.str_list "Available SMT solvers: "  "" ns,
  13.238 +      Pretty.str ("Current timeout: " ^ t ^ " seconds"),
  13.239 +      Pretty.str ("With proofs: " ^
  13.240 +        string_of_bool (not (Config.get ctxt oracle))),
  13.241 +      Pretty.str ("Certificates cache: " ^ certs_filename),
  13.242 +      Pretty.str ("Fixed certificates: " ^
  13.243 +        string_of_bool (Config.get ctxt read_only_certificates))])
  13.244 +  end
  13.245 +
  13.246 +val _ =
  13.247 +  Outer_Syntax.improper_command @{command_spec "smt_status"}
  13.248 +    "show the available SMT solvers, the currently selected SMT solver, \
  13.249 +    \and the values of SMT configuration options"
  13.250 +    (Scan.succeed (Toplevel.keep (print_setup o Toplevel.context_of)))
  13.251 +
  13.252 +end;
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Tools/SMT/smt_datatypes.ML	Thu Aug 28 00:40:38 2014 +0200
    14.3 @@ -0,0 +1,93 @@
    14.4 +(*  Title:      HOL/Tools/SMT/smt_datatypes.ML
    14.5 +    Author:     Sascha Boehme, TU Muenchen
    14.6 +
    14.7 +Collector functions for common type declarations and their representation
    14.8 +as algebraic datatypes.
    14.9 +*)
   14.10 +
   14.11 +signature SMT_DATATYPES =
   14.12 +sig
   14.13 +  val add_decls: typ ->
   14.14 +    (typ * (term * term list) list) list list * Proof.context ->
   14.15 +    (typ * (term * term list) list) list list * Proof.context
   14.16 +end;
   14.17 +
   14.18 +structure SMT_Datatypes: SMT_DATATYPES =
   14.19 +struct
   14.20 +
   14.21 +fun mk_selectors T Ts =
   14.22 +  Variable.variant_fixes (replicate (length Ts) "select")
   14.23 +  #>> map2 (fn U => fn n => Free (n, T --> U)) Ts
   14.24 +
   14.25 +
   14.26 +(* free constructor type declarations *)
   14.27 +
   14.28 +fun get_ctr_sugar_decl ({ctrs, ...} : Ctr_Sugar.ctr_sugar) T Ts ctxt =
   14.29 +  let
   14.30 +    fun mk_constr ctr0 =
   14.31 +      let val ctr = Ctr_Sugar.mk_ctr Ts ctr0 in
   14.32 +        mk_selectors T (binder_types (fastype_of ctr)) #>> pair ctr
   14.33 +      end
   14.34 +  in
   14.35 +    fold_map mk_constr ctrs ctxt
   14.36 +    |>> (pair T #> single)
   14.37 +  end
   14.38 +
   14.39 +
   14.40 +(* typedef declarations *)
   14.41 +
   14.42 +fun get_typedef_decl (({Abs_name, Rep_name, abs_type, rep_type, ...}, {Abs_inverse, ...})
   14.43 +    : Typedef.info) T Ts =
   14.44 +  if can (curry (op RS) @{thm UNIV_I}) Abs_inverse then
   14.45 +    let
   14.46 +      val env = snd (Term.dest_Type abs_type) ~~ Ts
   14.47 +      val instT = Term.map_atyps (perhaps (AList.lookup (op =) env))
   14.48 +
   14.49 +      val constr = Const (Abs_name, instT (rep_type --> abs_type))
   14.50 +      val select = Const (Rep_name, instT (abs_type --> rep_type))
   14.51 +    in [(T, [(constr, [select])])] end
   14.52 +  else
   14.53 +    []
   14.54 +
   14.55 +
   14.56 +(* collection of declarations *)
   14.57 +
   14.58 +fun declared declss T = exists (exists (equal T o fst)) declss
   14.59 +fun declared' dss T = exists (exists (equal T o fst) o snd) dss
   14.60 +
   14.61 +fun get_decls T n Ts ctxt =
   14.62 +  (case Ctr_Sugar.ctr_sugar_of ctxt n of
   14.63 +    SOME ctr_sugar => get_ctr_sugar_decl ctr_sugar T Ts ctxt
   14.64 +  | NONE =>
   14.65 +      (case Typedef.get_info ctxt n of
   14.66 +        [] => ([], ctxt)
   14.67 +      | info :: _ => (get_typedef_decl info T Ts, ctxt)))
   14.68 +
   14.69 +fun add_decls T (declss, ctxt) =
   14.70 +  let
   14.71 +    fun depends Ts ds = exists (member (op =) (map fst ds)) Ts
   14.72 +
   14.73 +    fun add (TFree _) = I
   14.74 +      | add (TVar _) = I
   14.75 +      | add (T as Type (@{type_name fun}, _)) =
   14.76 +          fold add (Term.body_type T :: Term.binder_types T)
   14.77 +      | add @{typ bool} = I
   14.78 +      | add (T as Type (n, Ts)) = (fn (dss, ctxt1) =>
   14.79 +          if declared declss T orelse declared' dss T then (dss, ctxt1)
   14.80 +          else if SMT_Builtin.is_builtin_typ_ext ctxt1 T then (dss, ctxt1)
   14.81 +          else
   14.82 +            (case get_decls T n Ts ctxt1 of
   14.83 +              ([], _) => (dss, ctxt1)
   14.84 +            | (ds, ctxt2) =>
   14.85 +                let
   14.86 +                  val constrTs = maps (map (snd o Term.dest_Const o fst) o snd) ds
   14.87 +                  val Us = fold (union (op =) o Term.binder_types) constrTs []
   14.88 +
   14.89 +                  fun ins [] = [(Us, ds)]
   14.90 +                    | ins ((Uds as (Us', _)) :: Udss) =
   14.91 +                        if depends Us' ds then (Us, ds) :: Uds :: Udss
   14.92 +                        else Uds :: ins Udss
   14.93 +            in fold add Us (ins dss, ctxt2) end))
   14.94 +  in add T ([], ctxt) |>> append declss o map snd end
   14.95 +
   14.96 +end;
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Tools/SMT/smt_failure.ML	Thu Aug 28 00:40:38 2014 +0200
    15.3 @@ -0,0 +1,40 @@
    15.4 +(*  Title:      HOL/Tools/SMT/smt_failure.ML
    15.5 +    Author:     Sascha Boehme, TU Muenchen
    15.6 +
    15.7 +Failures and exception of SMT.
    15.8 +*)
    15.9 +
   15.10 +signature SMT_FAILURE =
   15.11 +sig
   15.12 +  datatype failure =
   15.13 +    Counterexample of bool |
   15.14 +    Time_Out |
   15.15 +    Out_Of_Memory |
   15.16 +    Abnormal_Termination of int |
   15.17 +    Other_Failure of string
   15.18 +  val string_of_failure: failure -> string
   15.19 +  exception SMT of failure
   15.20 +end;
   15.21 +
   15.22 +structure SMT_Failure: SMT_FAILURE =
   15.23 +struct
   15.24 +
   15.25 +datatype failure =
   15.26 +  Counterexample of bool |
   15.27 +  Time_Out |
   15.28 +  Out_Of_Memory |
   15.29 +  Abnormal_Termination of int |
   15.30 +  Other_Failure of string
   15.31 +
   15.32 +fun string_of_failure (Counterexample genuine) =
   15.33 +      if genuine then "Counterexample found (possibly spurious)"
   15.34 +      else "Potential counterexample found"
   15.35 +  | string_of_failure Time_Out = "Timed out"
   15.36 +  | string_of_failure Out_Of_Memory = "Ran out of memory"
   15.37 +  | string_of_failure (Abnormal_Termination err) =
   15.38 +      "Solver terminated abnormally with error code " ^ string_of_int err
   15.39 +  | string_of_failure (Other_Failure msg) = msg
   15.40 +
   15.41 +exception SMT of failure
   15.42 +
   15.43 +end;
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Tools/SMT/smt_normalize.ML	Thu Aug 28 00:40:38 2014 +0200
    16.3 @@ -0,0 +1,441 @@
    16.4 +(*  Title:      HOL/Tools/SMT/smt_normalize.ML
    16.5 +    Author:     Sascha Boehme, TU Muenchen
    16.6 +
    16.7 +Normalization steps on theorems required by SMT solvers.
    16.8 +*)
    16.9 +
   16.10 +signature SMT_NORMALIZE =
   16.11 +sig
   16.12 +  val drop_fact_warning: Proof.context -> thm -> unit
   16.13 +  val atomize_conv: Proof.context -> conv
   16.14 +
   16.15 +  val special_quant_table: (string * thm) list
   16.16 +  val case_bool_entry: string * thm
   16.17 +  val abs_min_max_table: (string * thm) list
   16.18 +
   16.19 +  type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
   16.20 +  val add_extra_norm: SMT_Util.class * extra_norm -> Context.generic -> Context.generic
   16.21 +  val normalize: Proof.context -> thm list -> (int * thm) list
   16.22 +end;
   16.23 +
   16.24 +structure SMT_Normalize: SMT_NORMALIZE =
   16.25 +struct
   16.26 +
   16.27 +fun drop_fact_warning ctxt =
   16.28 +  SMT_Config.verbose_msg ctxt (prefix "Warning: dropping assumption: " o
   16.29 +    Display.string_of_thm ctxt)
   16.30 +
   16.31 +
   16.32 +(* general theorem normalizations *)
   16.33 +
   16.34 +(** instantiate elimination rules **)
   16.35 +
   16.36 +local
   16.37 +  val (cpfalse, cfalse) = `SMT_Util.mk_cprop (Thm.cterm_of @{theory} @{const False})
   16.38 +
   16.39 +  fun inst f ct thm =
   16.40 +    let val cv = f (Drule.strip_imp_concl (Thm.cprop_of thm))
   16.41 +    in Thm.instantiate ([], [(cv, ct)]) thm end
   16.42 +in
   16.43 +
   16.44 +fun instantiate_elim thm =
   16.45 +  (case Thm.concl_of thm of
   16.46 +    @{const Trueprop} $ Var (_, @{typ bool}) => inst Thm.dest_arg cfalse thm
   16.47 +  | Var _ => inst I cpfalse thm
   16.48 +  | _ => thm)
   16.49 +
   16.50 +end
   16.51 +
   16.52 +
   16.53 +(** normalize definitions **)
   16.54 +
   16.55 +fun norm_def thm =
   16.56 +  (case Thm.prop_of thm of
   16.57 +    @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _ $ Abs _) =>
   16.58 +      norm_def (thm RS @{thm fun_cong})
   16.59 +  | Const (@{const_name Pure.eq}, _) $ _ $ Abs _ => norm_def (thm RS @{thm meta_eq_to_obj_eq})
   16.60 +  | _ => thm)
   16.61 +
   16.62 +
   16.63 +(** atomization **)
   16.64 +
   16.65 +fun atomize_conv ctxt ct =
   16.66 +  (case Thm.term_of ct of
   16.67 +    @{const Pure.imp} $ _ $ _ =>
   16.68 +      Conv.binop_conv (atomize_conv ctxt) then_conv Conv.rewr_conv @{thm atomize_imp}
   16.69 +  | Const (@{const_name Pure.eq}, _) $ _ $ _ =>
   16.70 +      Conv.binop_conv (atomize_conv ctxt) then_conv Conv.rewr_conv @{thm atomize_eq}
   16.71 +  | Const (@{const_name Pure.all}, _) $ Abs _ =>
   16.72 +      Conv.binder_conv (atomize_conv o snd) ctxt then_conv Conv.rewr_conv @{thm atomize_all}
   16.73 +  | _ => Conv.all_conv) ct
   16.74 +
   16.75 +val setup_atomize =
   16.76 +  fold SMT_Builtin.add_builtin_fun_ext'' [@{const_name Pure.imp}, @{const_name Pure.eq},
   16.77 +    @{const_name Pure.all}, @{const_name Trueprop}]
   16.78 +
   16.79 +
   16.80 +(** unfold special quantifiers **)
   16.81 +
   16.82 +val special_quant_table = [
   16.83 +  (@{const_name Ex1}, @{thm Ex1_def_raw}),
   16.84 +  (@{const_name Ball}, @{thm Ball_def_raw}),
   16.85 +  (@{const_name Bex}, @{thm Bex_def_raw})]
   16.86 +
   16.87 +local
   16.88 +  fun special_quant (Const (n, _)) = AList.lookup (op =) special_quant_table n
   16.89 +    | special_quant _ = NONE
   16.90 +
   16.91 +  fun special_quant_conv _ ct =
   16.92 +    (case special_quant (Thm.term_of ct) of
   16.93 +      SOME thm => Conv.rewr_conv thm
   16.94 +    | NONE => Conv.all_conv) ct
   16.95 +in
   16.96 +
   16.97 +fun unfold_special_quants_conv ctxt =
   16.98 +  SMT_Util.if_exists_conv (is_some o special_quant) (Conv.top_conv special_quant_conv ctxt)
   16.99 +
  16.100 +val setup_unfolded_quants = fold (SMT_Builtin.add_builtin_fun_ext'' o fst) special_quant_table
  16.101 +
  16.102 +end
  16.103 +
  16.104 +
  16.105 +(** trigger inference **)
  16.106 +
  16.107 +local
  16.108 +  (*** check trigger syntax ***)
  16.109 +
  16.110 +  fun dest_trigger (Const (@{const_name pat}, _) $ _) = SOME true
  16.111 +    | dest_trigger (Const (@{const_name nopat}, _) $ _) = SOME false
  16.112 +    | dest_trigger _ = NONE
  16.113 +
  16.114 +  fun eq_list [] = false
  16.115 +    | eq_list (b :: bs) = forall (equal b) bs
  16.116 +
  16.117 +  fun proper_trigger t =
  16.118 +    t
  16.119 +    |> these o try SMT_Util.dest_symb_list
  16.120 +    |> map (map_filter dest_trigger o these o try SMT_Util.dest_symb_list)
  16.121 +    |> (fn [] => false | bss => forall eq_list bss)
  16.122 +
  16.123 +  fun proper_quant inside f t =
  16.124 +    (case t of
  16.125 +      Const (@{const_name All}, _) $ Abs (_, _, u) => proper_quant true f u
  16.126 +    | Const (@{const_name Ex}, _) $ Abs (_, _, u) => proper_quant true f u
  16.127 +    | @{const trigger} $ p $ u =>
  16.128 +        (if inside then f p else false) andalso proper_quant false f u
  16.129 +    | Abs (_, _, u) => proper_quant false f u
  16.130 +    | u1 $ u2 => proper_quant false f u1 andalso proper_quant false f u2
  16.131 +    | _ => true)
  16.132 +
  16.133 +  fun check_trigger_error ctxt t =
  16.134 +    error ("SMT triggers must only occur under quantifier and multipatterns " ^
  16.135 +      "must have the same kind: " ^ Syntax.string_of_term ctxt t)
  16.136 +
  16.137 +  fun check_trigger_conv ctxt ct =
  16.138 +    if proper_quant false proper_trigger (SMT_Util.term_of ct) then Conv.all_conv ct
  16.139 +    else check_trigger_error ctxt (Thm.term_of ct)
  16.140 +
  16.141 +
  16.142 +  (*** infer simple triggers ***)
  16.143 +
  16.144 +  fun dest_cond_eq ct =
  16.145 +    (case Thm.term_of ct of
  16.146 +      Const (@{const_name HOL.eq}, _) $ _ $ _ => Thm.dest_binop ct
  16.147 +    | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct)
  16.148 +    | _ => raise CTERM ("no equation", [ct]))
  16.149 +
  16.150 +  fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n)
  16.151 +    | get_constrs _ _ = []
  16.152 +
  16.153 +  fun is_constr thy (n, T) =
  16.154 +    let fun match (m, U) = m = n andalso Sign.typ_instance thy (T, U)
  16.155 +    in can (the o find_first match o get_constrs thy o Term.body_type) T end
  16.156 +
  16.157 +  fun is_constr_pat thy t =
  16.158 +    (case Term.strip_comb t of
  16.159 +      (Free _, []) => true
  16.160 +    | (Const c, ts) => is_constr thy c andalso forall (is_constr_pat thy) ts
  16.161 +    | _ => false)
  16.162 +
  16.163 +  fun is_simp_lhs ctxt t =
  16.164 +    (case Term.strip_comb t of
  16.165 +      (Const c, ts as _ :: _) =>
  16.166 +        not (SMT_Builtin.is_builtin_fun_ext ctxt c ts) andalso
  16.167 +        forall (is_constr_pat (Proof_Context.theory_of ctxt)) ts
  16.168 +    | _ => false)
  16.169 +
  16.170 +  fun has_all_vars vs t =
  16.171 +    subset (op aconv) (vs, map Free (Term.add_frees t []))
  16.172 +
  16.173 +  fun minimal_pats vs ct =
  16.174 +    if has_all_vars vs (Thm.term_of ct) then
  16.175 +      (case Thm.term_of ct of
  16.176 +        _ $ _ =>
  16.177 +          (case pairself (minimal_pats vs) (Thm.dest_comb ct) of
  16.178 +            ([], []) => [[ct]]
  16.179 +          | (ctss, ctss') => union (eq_set (op aconvc)) ctss ctss')
  16.180 +      | _ => [])
  16.181 +    else []
  16.182 +
  16.183 +  fun proper_mpat _ _ _ [] = false
  16.184 +    | proper_mpat thy gen u cts =
  16.185 +        let
  16.186 +          val tps = (op ~~) (`gen (map Thm.term_of cts))
  16.187 +          fun some_match u = tps |> exists (fn (t', t) =>
  16.188 +            Pattern.matches thy (t', u) andalso not (t aconv u))
  16.189 +        in not (Term.exists_subterm some_match u) end
  16.190 +
  16.191 +  val pat = SMT_Util.mk_const_pat @{theory} @{const_name pat} SMT_Util.destT1
  16.192 +  fun mk_pat ct = Thm.apply (SMT_Util.instT' ct pat) ct
  16.193 +
  16.194 +  fun mk_clist T =
  16.195 +    pairself (Thm.cterm_of @{theory}) (SMT_Util.symb_cons_const T, SMT_Util.symb_nil_const T)
  16.196 +  fun mk_list (ccons, cnil) f cts = fold_rev (Thm.mk_binop ccons o f) cts cnil
  16.197 +  val mk_pat_list = mk_list (mk_clist @{typ pattern})
  16.198 +  val mk_mpat_list = mk_list (mk_clist @{typ "pattern symb_list"})
  16.199 +  fun mk_trigger ctss = mk_mpat_list (mk_pat_list mk_pat) ctss
  16.200 +
  16.201 +  val trigger_eq = mk_meta_eq @{lemma "p = trigger t p" by (simp add: trigger_def)}
  16.202 +
  16.203 +  fun insert_trigger_conv [] ct = Conv.all_conv ct
  16.204 +    | insert_trigger_conv ctss ct =
  16.205 +        let val (ctr, cp) = Thm.dest_binop (Thm.rhs_of trigger_eq) ||> rpair ct
  16.206 +        in Thm.instantiate ([], [cp, (ctr, mk_trigger ctss)]) trigger_eq end
  16.207 +
  16.208 +  fun infer_trigger_eq_conv outer_ctxt (ctxt, cvs) ct =
  16.209 +    let
  16.210 +      val (lhs, rhs) = dest_cond_eq ct
  16.211 +
  16.212 +      val vs = map Thm.term_of cvs
  16.213 +      val thy = Proof_Context.theory_of ctxt
  16.214 +
  16.215 +      fun get_mpats ct =
  16.216 +        if is_simp_lhs ctxt (Thm.term_of ct) then minimal_pats vs ct
  16.217 +        else []
  16.218 +      val gen = Variable.export_terms ctxt outer_ctxt
  16.219 +      val filter_mpats = filter (proper_mpat thy gen (Thm.term_of rhs))
  16.220 +
  16.221 +    in insert_trigger_conv (filter_mpats (get_mpats lhs)) ct end
  16.222 +
  16.223 +  fun has_trigger (@{const trigger} $ _ $ _) = true
  16.224 +    | has_trigger _ = false
  16.225 +
  16.226 +  fun try_trigger_conv cv ct =
  16.227 +    if SMT_Util.under_quant has_trigger (SMT_Util.term_of ct) then Conv.all_conv ct
  16.228 +    else Conv.try_conv cv ct
  16.229 +
  16.230 +  fun infer_trigger_conv ctxt =
  16.231 +    if Config.get ctxt SMT_Config.infer_triggers then
  16.232 +      try_trigger_conv (SMT_Util.under_quant_conv (infer_trigger_eq_conv ctxt) ctxt)
  16.233 +    else Conv.all_conv
  16.234 +in
  16.235 +
  16.236 +fun trigger_conv ctxt =
  16.237 +  SMT_Util.prop_conv (check_trigger_conv ctxt then_conv infer_trigger_conv ctxt)
  16.238 +
  16.239 +val setup_trigger =
  16.240 +  fold SMT_Builtin.add_builtin_fun_ext''
  16.241 +    [@{const_name pat}, @{const_name nopat}, @{const_name trigger}]
  16.242 +
  16.243 +end
  16.244 +
  16.245 +
  16.246 +(** combined general normalizations **)
  16.247 +
  16.248 +fun gen_normalize1_conv ctxt =
  16.249 +  atomize_conv ctxt then_conv
  16.250 +  unfold_special_quants_conv ctxt then_conv
  16.251 +  Thm.beta_conversion true then_conv
  16.252 +  trigger_conv ctxt
  16.253 +
  16.254 +fun gen_normalize1 ctxt =
  16.255 +  instantiate_elim #>
  16.256 +  norm_def #>
  16.257 +  Conv.fconv_rule (Thm.beta_conversion true then_conv Thm.eta_conversion) #>
  16.258 +  Drule.forall_intr_vars #>
  16.259 +  Conv.fconv_rule (gen_normalize1_conv ctxt) #>
  16.260 +  (* Z3 4.3.1 silently normalizes "P --> Q --> R" to "P & Q --> R" *)
  16.261 +  Raw_Simplifier.rewrite_rule ctxt @{thms HOL.imp_conjL[symmetric, THEN eq_reflection]}
  16.262 +
  16.263 +fun gen_norm1_safe ctxt (i, thm) =
  16.264 +  (case try (gen_normalize1 ctxt) thm of
  16.265 +    SOME thm' => SOME (i, thm')
  16.266 +  | NONE => (drop_fact_warning ctxt thm; NONE))
  16.267 +
  16.268 +fun gen_normalize ctxt iwthms = map_filter (gen_norm1_safe ctxt) iwthms
  16.269 +
  16.270 +
  16.271 +(* unfolding of definitions and theory-specific rewritings *)
  16.272 +
  16.273 +fun expand_head_conv cv ct =
  16.274 +  (case Thm.term_of ct of
  16.275 +    _ $ _ =>
  16.276 +      Conv.fun_conv (expand_head_conv cv) then_conv
  16.277 +      Conv.try_conv (Thm.beta_conversion false)
  16.278 +  | _ => cv) ct
  16.279 +
  16.280 +
  16.281 +(** rewrite bool case expressions as if expressions **)
  16.282 +
  16.283 +val case_bool_entry = (@{const_name "bool.case_bool"}, @{thm case_bool_if})
  16.284 +
  16.285 +local
  16.286 +  fun is_case_bool (Const (@{const_name "bool.case_bool"}, _)) = true
  16.287 +    | is_case_bool _ = false
  16.288 +
  16.289 +  fun unfold_conv _ =
  16.290 +    SMT_Util.if_true_conv (is_case_bool o Term.head_of)
  16.291 +      (expand_head_conv (Conv.rewr_conv @{thm case_bool_if}))
  16.292 +in
  16.293 +
  16.294 +fun rewrite_case_bool_conv ctxt =
  16.295 +  SMT_Util.if_exists_conv is_case_bool (Conv.top_conv unfold_conv ctxt)
  16.296 +
  16.297 +val setup_case_bool = SMT_Builtin.add_builtin_fun_ext'' @{const_name "bool.case_bool"}
  16.298 +
  16.299 +end
  16.300 +
  16.301 +
  16.302 +(** unfold abs, min and max **)
  16.303 +
  16.304 +val abs_min_max_table = [
  16.305 +  (@{const_name min}, @{thm min_def_raw}),
  16.306 +  (@{const_name max}, @{thm max_def_raw}),
  16.307 +  (@{const_name abs}, @{thm abs_if_raw})]
  16.308 +
  16.309 +local
  16.310 +  fun abs_min_max ctxt (Const (n, Type (@{type_name fun}, [T, _]))) =
  16.311 +        (case AList.lookup (op =) abs_min_max_table n of
  16.312 +          NONE => NONE
  16.313 +        | SOME thm => if SMT_Builtin.is_builtin_typ_ext ctxt T then SOME thm else NONE)
  16.314 +    | abs_min_max _ _ = NONE
  16.315 +
  16.316 +  fun unfold_amm_conv ctxt ct =
  16.317 +    (case abs_min_max ctxt (Term.head_of (Thm.term_of ct)) of
  16.318 +      SOME thm => expand_head_conv (Conv.rewr_conv thm)
  16.319 +    | NONE => Conv.all_conv) ct
  16.320 +in
  16.321 +
  16.322 +fun unfold_abs_min_max_conv ctxt =
  16.323 +  SMT_Util.if_exists_conv (is_some o abs_min_max ctxt) (Conv.top_conv unfold_amm_conv ctxt)
  16.324 +
  16.325 +val setup_abs_min_max = fold (SMT_Builtin.add_builtin_fun_ext'' o fst) abs_min_max_table
  16.326 +
  16.327 +end
  16.328 +
  16.329 +
  16.330 +(** normalize numerals **)
  16.331 +
  16.332 +local
  16.333 +  (*
  16.334 +    rewrite Numeral1 into 1
  16.335 +    rewrite - 0 into 0
  16.336 +  *)
  16.337 +
  16.338 +  fun is_irregular_number (Const (@{const_name numeral}, _) $ Const (@{const_name num.One}, _)) =
  16.339 +        true
  16.340 +    | is_irregular_number (Const (@{const_name uminus}, _) $ Const (@{const_name Groups.zero}, _)) =
  16.341 +        true
  16.342 +    | is_irregular_number _ = false
  16.343 +
  16.344 +  fun is_strange_number ctxt t = is_irregular_number t andalso SMT_Builtin.is_builtin_num ctxt t
  16.345 +
  16.346 +  val proper_num_ss =
  16.347 +    simpset_of (put_simpset HOL_ss @{context} addsimps @{thms Num.numeral_One minus_zero})
  16.348 +
  16.349 +  fun norm_num_conv ctxt =
  16.350 +    SMT_Util.if_conv (is_strange_number ctxt) (Simplifier.rewrite (put_simpset proper_num_ss ctxt))
  16.351 +      Conv.no_conv
  16.352 +in
  16.353 +
  16.354 +fun normalize_numerals_conv ctxt =
  16.355 +  SMT_Util.if_exists_conv (is_strange_number ctxt) (Conv.top_sweep_conv norm_num_conv ctxt)
  16.356 +
  16.357 +end
  16.358 +
  16.359 +
  16.360 +(** combined unfoldings and rewritings **)
  16.361 +
  16.362 +fun unfold_conv ctxt =
  16.363 +  rewrite_case_bool_conv ctxt then_conv
  16.364 +  unfold_abs_min_max_conv ctxt then_conv
  16.365 +  Thm.beta_conversion true
  16.366 +
  16.367 +fun unfold_polymorph ctxt = map (apsnd (Conv.fconv_rule (unfold_conv ctxt)))
  16.368 +fun unfold_monomorph ctxt = map (apsnd (Conv.fconv_rule (normalize_numerals_conv ctxt)))
  16.369 +
  16.370 +
  16.371 +(* overall normalization *)
  16.372 +
  16.373 +fun burrow_ids f ithms =
  16.374 +  let
  16.375 +    val (is, thms) = split_list ithms
  16.376 +    val (thms', extra_thms) = f thms
  16.377 +  in (is ~~ thms') @ map (pair ~1) extra_thms end
  16.378 +
  16.379 +type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
  16.380 +
  16.381 +structure Extra_Norms = Generic_Data
  16.382 +(
  16.383 +  type T = extra_norm SMT_Util.dict
  16.384 +  val empty = []
  16.385 +  val extend = I
  16.386 +  fun merge data = SMT_Util.dict_merge fst data
  16.387 +)
  16.388 +
  16.389 +fun add_extra_norm (cs, norm) = Extra_Norms.map (SMT_Util.dict_update (cs, norm))
  16.390 +
  16.391 +fun apply_extra_norms ctxt ithms =
  16.392 +  let
  16.393 +    val cs = SMT_Config.solver_class_of ctxt
  16.394 +    val es = SMT_Util.dict_lookup (Extra_Norms.get (Context.Proof ctxt)) cs
  16.395 +  in burrow_ids (fold (fn e => e ctxt) es o rpair []) ithms end
  16.396 +
  16.397 +local
  16.398 +  val ignored = member (op =) [@{const_name All}, @{const_name Ex},
  16.399 +    @{const_name Let}, @{const_name If}, @{const_name HOL.eq}]
  16.400 +
  16.401 +  val schematic_consts_of =
  16.402 +    let
  16.403 +      fun collect (@{const trigger} $ p $ t) = collect_trigger p #> collect t
  16.404 +        | collect (t $ u) = collect t #> collect u
  16.405 +        | collect (Abs (_, _, t)) = collect t
  16.406 +        | collect (t as Const (n, _)) =
  16.407 +            if not (ignored n) then Monomorph.add_schematic_consts_of t else I
  16.408 +        | collect _ = I
  16.409 +      and collect_trigger t =
  16.410 +        let val dest = these o try SMT_Util.dest_symb_list
  16.411 +        in fold (fold collect_pat o dest) (dest t) end
  16.412 +      and collect_pat (Const (@{const_name pat}, _) $ t) = collect t
  16.413 +        | collect_pat (Const (@{const_name nopat}, _) $ t) = collect t
  16.414 +        | collect_pat _ = I
  16.415 +    in (fn t => collect t Symtab.empty) end
  16.416 +in
  16.417 +
  16.418 +fun monomorph ctxt xthms =
  16.419 +  let val (xs, thms) = split_list xthms
  16.420 +  in
  16.421 +    map (pair 1) thms
  16.422 +    |> Monomorph.monomorph schematic_consts_of ctxt
  16.423 +    |> maps (uncurry (map o pair)) o map2 pair xs o map (map snd)
  16.424 +  end
  16.425 +
  16.426 +end
  16.427 +
  16.428 +fun normalize ctxt wthms =
  16.429 +  wthms
  16.430 +  |> map_index I
  16.431 +  |> gen_normalize ctxt
  16.432 +  |> unfold_polymorph ctxt
  16.433 +  |> monomorph ctxt
  16.434 +  |> unfold_monomorph ctxt
  16.435 +  |> apply_extra_norms ctxt
  16.436 +
  16.437 +val _ = Theory.setup (Context.theory_map (
  16.438 +  setup_atomize #>
  16.439 +  setup_unfolded_quants #>
  16.440 +  setup_trigger #>
  16.441 +  setup_case_bool #>
  16.442 +  setup_abs_min_max))
  16.443 +
  16.444 +end;
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Tools/SMT/smt_real.ML	Thu Aug 28 00:40:38 2014 +0200
    17.3 @@ -0,0 +1,113 @@
    17.4 +(*  Title:      HOL/Tools/SMT/smt_real.ML
    17.5 +    Author:     Sascha Boehme, TU Muenchen
    17.6 +
    17.7 +SMT setup for reals.
    17.8 +*)
    17.9 +
   17.10 +structure SMT_Real: sig end =
   17.11 +struct
   17.12 +
   17.13 +
   17.14 +(* SMT-LIB logic *)
   17.15 +
   17.16 +fun smtlib_logic ts =
   17.17 +  if exists (Term.exists_type (Term.exists_subtype (equal @{typ real}))) ts
   17.18 +  then SOME "AUFLIRA"
   17.19 +  else NONE
   17.20 +
   17.21 +
   17.22 +(* SMT-LIB and Z3 built-ins *)
   17.23 +
   17.24 +local
   17.25 +  fun real_num _ i = SOME (string_of_int i ^ ".0")
   17.26 +
   17.27 +  fun is_linear [t] = SMT_Util.is_number t
   17.28 +    | is_linear [t, u] = SMT_Util.is_number t orelse SMT_Util.is_number u
   17.29 +    | is_linear _ = false
   17.30 +
   17.31 +  fun mk_times ts = Term.list_comb (@{const times (real)}, ts)
   17.32 +
   17.33 +  fun times _ _ ts = if is_linear ts then SOME ("*", 2, ts, mk_times) else NONE
   17.34 +in
   17.35 +
   17.36 +val setup_builtins =
   17.37 +  SMT_Builtin.add_builtin_typ SMTLIB_Interface.smtlibC
   17.38 +    (@{typ real}, K (SOME "Real"), real_num) #>
   17.39 +  fold (SMT_Builtin.add_builtin_fun' SMTLIB_Interface.smtlibC) [
   17.40 +    (@{const less (real)}, "<"),
   17.41 +    (@{const less_eq (real)}, "<="),
   17.42 +    (@{const uminus (real)}, "-"),
   17.43 +    (@{const plus (real)}, "+"),
   17.44 +    (@{const minus (real)}, "-") ] #>
   17.45 +  SMT_Builtin.add_builtin_fun SMTLIB_Interface.smtlibC
   17.46 +    (Term.dest_Const @{const times (real)}, times) #>
   17.47 +  SMT_Builtin.add_builtin_fun' Z3_Interface.smtlib_z3C
   17.48 +    (@{const times (real)}, "*") #>
   17.49 +  SMT_Builtin.add_builtin_fun' Z3_Interface.smtlib_z3C
   17.50 +    (@{const divide (real)}, "/")
   17.51 +
   17.52 +end
   17.53 +
   17.54 +
   17.55 +(* Z3 constructors *)
   17.56 +
   17.57 +local
   17.58 +  fun z3_mk_builtin_typ (Z3_Interface.Sym ("Real", _)) = SOME @{typ real}
   17.59 +    | z3_mk_builtin_typ (Z3_Interface.Sym ("real", _)) = SOME @{typ real}
   17.60 +        (*FIXME: delete*)
   17.61 +    | z3_mk_builtin_typ _ = NONE
   17.62 +
   17.63 +  fun z3_mk_builtin_num _ i T =
   17.64 +    if T = @{typ real} then SOME (Numeral.mk_cnumber @{ctyp real} i)
   17.65 +    else NONE
   17.66 +
   17.67 +  fun mk_nary _ cu [] = cu
   17.68 +    | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
   17.69 +
   17.70 +  val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (real)})
   17.71 +  val add = Thm.cterm_of @{theory} @{const plus (real)}
   17.72 +  val real0 = Numeral.mk_cnumber @{ctyp real} 0
   17.73 +  val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (real)})
   17.74 +  val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (real)})
   17.75 +  val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const divide (real)})
   17.76 +  val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (real)})
   17.77 +  val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (real)})
   17.78 +
   17.79 +  fun z3_mk_builtin_fun (Z3_Interface.Sym ("-", _)) [ct] = SOME (mk_uminus ct)
   17.80 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("+", _)) cts = SOME (mk_nary add real0 cts)
   17.81 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("-", _)) [ct, cu] = SOME (mk_sub ct cu)
   17.82 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("*", _)) [ct, cu] = SOME (mk_mul ct cu)
   17.83 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("/", _)) [ct, cu] = SOME (mk_div ct cu)
   17.84 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("<", _)) [ct, cu] = SOME (mk_lt ct cu)
   17.85 +    | z3_mk_builtin_fun (Z3_Interface.Sym ("<=", _)) [ct, cu] = SOME (mk_le ct cu)
   17.86 +    | z3_mk_builtin_fun (Z3_Interface.Sym (">", _)) [ct, cu] = SOME (mk_lt cu ct)
   17.87 +    | z3_mk_builtin_fun (Z3_Interface.Sym (">=", _)) [ct, cu] = SOME (mk_le cu ct)
   17.88 +    | z3_mk_builtin_fun _ _ = NONE
   17.89 +in
   17.90 +
   17.91 +val z3_mk_builtins = {
   17.92 +  mk_builtin_typ = z3_mk_builtin_typ,
   17.93 +  mk_builtin_num = z3_mk_builtin_num,
   17.94 +  mk_builtin_fun = (fn _ => fn sym => fn cts =>
   17.95 +    (case try (#T o Thm.rep_cterm o hd) cts of
   17.96 +      SOME @{typ real} => z3_mk_builtin_fun sym cts
   17.97 +    | _ => NONE)) }
   17.98 +
   17.99 +end
  17.100 +
  17.101 +
  17.102 +(* Z3 proof replay *)
  17.103 +
  17.104 +val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [
  17.105 +  "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc
  17.106 +
  17.107 +
  17.108 +(* setup *)
  17.109 +
  17.110 +val _ = Theory.setup (Context.theory_map (
  17.111 +  SMTLIB_Interface.add_logic (10, smtlib_logic) #>
  17.112 +  setup_builtins #>
  17.113 +  Z3_Interface.add_mk_builtins z3_mk_builtins #>
  17.114 +  Z3_Replay_Util.add_simproc real_linarith_proc))
  17.115 +
  17.116 +end;
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Tools/SMT/smt_solver.ML	Thu Aug 28 00:40:38 2014 +0200
    18.3 @@ -0,0 +1,306 @@
    18.4 +(*  Title:      HOL/Tools/SMT/smt_solver.ML
    18.5 +    Author:     Sascha Boehme, TU Muenchen
    18.6 +
    18.7 +SMT solvers registry and SMT tactic.
    18.8 +*)
    18.9 +
   18.10 +signature SMT_SOLVER =
   18.11 +sig
   18.12 +  (*configuration*)
   18.13 +  datatype outcome = Unsat | Sat | Unknown
   18.14 +
   18.15 +  type parsed_proof =
   18.16 +    {outcome: SMT_Failure.failure option,
   18.17 +     fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list,
   18.18 +     atp_proof: unit -> (term, string) ATP_Proof.atp_step list}
   18.19 +
   18.20 +  type solver_config =
   18.21 +    {name: string,
   18.22 +     class: Proof.context -> SMT_Util.class,
   18.23 +     avail: unit -> bool,
   18.24 +     command: unit -> string list,
   18.25 +     options: Proof.context -> string list,
   18.26 +     smt_options: (string * string) list,
   18.27 +     default_max_relevant: int,
   18.28 +     outcome: string -> string list -> outcome * string list,
   18.29 +     parse_proof: (Proof.context -> SMT_Translate.replay_data ->
   18.30 +       ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list ->
   18.31 +       parsed_proof) option,
   18.32 +     replay: (Proof.context -> SMT_Translate.replay_data -> string list -> thm) option}
   18.33 +
   18.34 +  (*registry*)
   18.35 +  val add_solver: solver_config -> theory -> theory
   18.36 +  val default_max_relevant: Proof.context -> string -> int
   18.37 +
   18.38 +  (*filter*)
   18.39 +  val smt_filter: Proof.context -> thm -> ((string * ATP_Problem_Generate.stature) * thm) list ->
   18.40 +    int -> Time.time -> parsed_proof
   18.41 +
   18.42 +  (*tactic*)
   18.43 +  val smt_tac: Proof.context -> thm list -> int -> tactic
   18.44 +  val smt_tac': Proof.context -> thm list -> int -> tactic
   18.45 +end;
   18.46 +
   18.47 +structure SMT_Solver: SMT_SOLVER =
   18.48 +struct
   18.49 +
   18.50 +(* interface to external solvers *)
   18.51 +
   18.52 +local
   18.53 +
   18.54 +fun make_command command options problem_path proof_path =
   18.55 +  "(exec 2>&1;" :: map File.shell_quote (command () @ options) @
   18.56 +  [File.shell_path problem_path, ")", ">", File.shell_path proof_path]
   18.57 +  |> space_implode " "
   18.58 +
   18.59 +fun with_trace ctxt msg f x =
   18.60 +  let val _ = SMT_Config.trace_msg ctxt (fn () => msg) ()
   18.61 +  in f x end
   18.62 +
   18.63 +fun run ctxt name mk_cmd input =
   18.64 +  (case SMT_Config.certificates_of ctxt of
   18.65 +    NONE =>
   18.66 +      if not (SMT_Config.is_available ctxt name) then
   18.67 +        error ("The SMT solver " ^ quote name ^ " is not installed")
   18.68 +      else if Config.get ctxt SMT_Config.debug_files = "" then
   18.69 +        with_trace ctxt ("Invoking SMT solver " ^ quote name ^ " ...") (Cache_IO.run mk_cmd) input
   18.70 +      else
   18.71 +        let
   18.72 +          val base_path = Path.explode (Config.get ctxt SMT_Config.debug_files)
   18.73 +          val in_path = Path.ext "smt_in" base_path
   18.74 +          val out_path = Path.ext "smt_out" base_path
   18.75 +        in Cache_IO.raw_run mk_cmd input in_path out_path end
   18.76 +  | SOME certs =>
   18.77 +      (case Cache_IO.lookup certs input of
   18.78 +        (NONE, key) =>
   18.79 +          if Config.get ctxt SMT_Config.read_only_certificates then
   18.80 +            error ("Bad certificate cache: missing certificate")
   18.81 +          else
   18.82 +            Cache_IO.run_and_cache certs key mk_cmd input
   18.83 +      | (SOME output, _) =>
   18.84 +          with_trace ctxt ("Using cached certificate from " ^
   18.85 +            File.shell_path (Cache_IO.cache_path_of certs) ^ " ...") I output))
   18.86 +
   18.87 +(* Z3 returns 1 if "get-model" or "get-model" fails *)
   18.88 +val normal_return_codes = [0, 1]
   18.89 +
   18.90 +fun run_solver ctxt name mk_cmd input =
   18.91 +  let
   18.92 +    fun pretty tag lines = Pretty.string_of (Pretty.big_list tag (map Pretty.str lines))
   18.93 +
   18.94 +    val _ = SMT_Config.trace_msg ctxt (pretty "Problem:" o split_lines) input
   18.95 +
   18.96 +    val {redirected_output = res, output = err, return_code} =
   18.97 +      SMT_Config.with_timeout ctxt (run ctxt name mk_cmd) input
   18.98 +    val _ = SMT_Config.trace_msg ctxt (pretty "Solver:") err
   18.99 +
  18.100 +    val output = fst (take_suffix (equal "") res)
  18.101 +    val _ = SMT_Config.trace_msg ctxt (pretty "Result:") output
  18.102 +
  18.103 +    val _ = member (op =) normal_return_codes return_code orelse
  18.104 +      raise SMT_Failure.SMT (SMT_Failure.Abnormal_Termination return_code)
  18.105 +  in output end
  18.106 +
  18.107 +fun trace_assms ctxt =
  18.108 +  SMT_Config.trace_msg ctxt (Pretty.string_of o
  18.109 +    Pretty.big_list "Assertions:" o map (Display.pretty_thm ctxt o snd))
  18.110 +
  18.111 +fun trace_replay_data ({context = ctxt, typs, terms, ...} : SMT_Translate.replay_data) =
  18.112 +  let
  18.113 +    fun pretty_eq n p = Pretty.block [Pretty.str n, Pretty.str " = ", p]
  18.114 +    fun p_typ (n, T) = pretty_eq n (Syntax.pretty_typ ctxt T)
  18.115 +    fun p_term (n, t) = pretty_eq n (Syntax.pretty_term ctxt t)
  18.116 +  in
  18.117 +    SMT_Config.trace_msg ctxt (fn () =>
  18.118 +      Pretty.string_of (Pretty.big_list "Names:" [
  18.119 +        Pretty.big_list "sorts:" (map p_typ (Symtab.dest typs)),
  18.120 +        Pretty.big_list "functions:" (map p_term (Symtab.dest terms))])) ()
  18.121 +  end
  18.122 +
  18.123 +in
  18.124 +
  18.125 +fun invoke name command smt_options ithms ctxt =
  18.126 +  let
  18.127 +    val options = SMT_Config.solver_options_of ctxt
  18.128 +    val comments = [space_implode " " options]
  18.129 +
  18.130 +    val (str, replay_data as {context = ctxt', ...}) =
  18.131 +      ithms
  18.132 +      |> tap (trace_assms ctxt)
  18.133 +      |> SMT_Translate.translate ctxt smt_options comments
  18.134 +      ||> tap trace_replay_data
  18.135 +  in (run_solver ctxt' name (make_command command options) str, replay_data) end
  18.136 +
  18.137 +end
  18.138 +
  18.139 +
  18.140 +(* configuration *)
  18.141 +
  18.142 +datatype outcome = Unsat | Sat | Unknown
  18.143 +
  18.144 +type parsed_proof =
  18.145 +  {outcome: SMT_Failure.failure option,
  18.146 +   fact_ids: (int * ((string * ATP_Problem_Generate.stature) * thm)) list,
  18.147 +   atp_proof: unit -> (term, string) ATP_Proof.atp_step list}
  18.148 +
  18.149 +type solver_config =
  18.150 +  {name: string,
  18.151 +   class: Proof.context -> SMT_Util.class,
  18.152 +   avail: unit -> bool,
  18.153 +   command: unit -> string list,
  18.154 +   options: Proof.context -> string list,
  18.155 +   smt_options: (string * string) list,
  18.156 +   default_max_relevant: int,
  18.157 +   outcome: string -> string list -> outcome * string list,
  18.158 +   parse_proof: (Proof.context -> SMT_Translate.replay_data ->
  18.159 +     ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list ->
  18.160 +     parsed_proof) option,
  18.161 +   replay: (Proof.context -> SMT_Translate.replay_data -> string list -> thm) option}
  18.162 +
  18.163 +
  18.164 +(* check well-sortedness *)
  18.165 +
  18.166 +val has_topsort = Term.exists_type (Term.exists_subtype (fn
  18.167 +    TFree (_, []) => true
  18.168 +  | TVar (_, []) => true
  18.169 +  | _ => false))
  18.170 +
  18.171 +(* top sorts cause problems with atomization *)
  18.172 +fun check_topsort ctxt thm =
  18.173 +  if has_topsort (Thm.prop_of thm) then (SMT_Normalize.drop_fact_warning ctxt thm; TrueI) else thm
  18.174 +
  18.175 +
  18.176 +(* registry *)
  18.177 +
  18.178 +type solver_info = {
  18.179 +  command: unit -> string list,
  18.180 +  smt_options: (string * string) list,
  18.181 +  default_max_relevant: int,
  18.182 +  parse_proof: Proof.context -> SMT_Translate.replay_data ->
  18.183 +    ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list ->
  18.184 +    parsed_proof,
  18.185 +  replay: Proof.context -> SMT_Translate.replay_data -> string list -> thm}
  18.186 +
  18.187 +structure Solvers = Generic_Data
  18.188 +(
  18.189 +  type T = solver_info Symtab.table
  18.190 +  val empty = Symtab.empty
  18.191 +  val extend = I
  18.192 +  fun merge data = Symtab.merge (K true) data
  18.193 +)
  18.194 +
  18.195 +local
  18.196 +  fun parse_proof outcome parse_proof0 outer_ctxt replay_data xfacts prems concl output =
  18.197 +    (case outcome output of
  18.198 +      (Unsat, lines) =>
  18.199 +        (case parse_proof0 of
  18.200 +          SOME pp => pp outer_ctxt replay_data xfacts prems concl lines
  18.201 +        | NONE => {outcome = NONE, fact_ids = [], atp_proof = K []})
  18.202 +    | (result, _) => raise SMT_Failure.SMT (SMT_Failure.Counterexample (result = Sat)))
  18.203 +
  18.204 +  fun replay outcome replay0 oracle outer_ctxt
  18.205 +      (replay_data as {context = ctxt, ...} : SMT_Translate.replay_data) output =
  18.206 +    (case outcome output of
  18.207 +      (Unsat, lines) =>
  18.208 +        if not (Config.get ctxt SMT_Config.oracle) andalso is_some replay0
  18.209 +        then the replay0 outer_ctxt replay_data lines
  18.210 +        else oracle ()
  18.211 +    | (result, _) => raise SMT_Failure.SMT (SMT_Failure.Counterexample (result = Sat)))
  18.212 +
  18.213 +  val cfalse = Thm.cterm_of @{theory} @{prop False}
  18.214 +in
  18.215 +
  18.216 +fun add_solver ({name, class, avail, command, options, smt_options, default_max_relevant, outcome,
  18.217 +    parse_proof = parse_proof0, replay = replay0} : solver_config) =
  18.218 +  let
  18.219 +    fun solver oracle = {
  18.220 +      command = command,
  18.221 +      smt_options = smt_options,
  18.222 +      default_max_relevant = default_max_relevant,
  18.223 +      parse_proof = parse_proof (outcome name) parse_proof0,
  18.224 +      replay = replay (outcome name) replay0 oracle}
  18.225 +
  18.226 +    val info = {name = name, class = class, avail = avail, options = options}
  18.227 +  in
  18.228 +    Thm.add_oracle (Binding.name name, K cfalse) #-> (fn (_, oracle) =>
  18.229 +    Context.theory_map (Solvers.map (Symtab.update_new (name, solver oracle)))) #>
  18.230 +    Context.theory_map (SMT_Config.add_solver info)
  18.231 +  end
  18.232 +
  18.233 +end
  18.234 +
  18.235 +fun get_info ctxt name = the (Symtab.lookup (Solvers.get (Context.Proof ctxt)) name)
  18.236 +
  18.237 +fun name_and_info_of ctxt =
  18.238 +  let val name = SMT_Config.solver_of ctxt
  18.239 +  in (name, get_info ctxt name) end
  18.240 +
  18.241 +val default_max_relevant = #default_max_relevant oo get_info
  18.242 +
  18.243 +fun apply_solver_and_replay ctxt thms0 =
  18.244 +  let
  18.245 +    val thms = map (check_topsort ctxt) thms0
  18.246 +    val (name, {command, smt_options, replay, ...}) = name_and_info_of ctxt
  18.247 +    val (output, replay_data) =
  18.248 +      invoke name command smt_options (SMT_Normalize.normalize ctxt thms) ctxt
  18.249 +  in replay ctxt replay_data output end
  18.250 +
  18.251 +
  18.252 +(* filter *)
  18.253 +
  18.254 +fun smt_filter ctxt0 goal xfacts i time_limit =
  18.255 +  let
  18.256 +    val ctxt = ctxt0 |> Config.put SMT_Config.timeout (Time.toReal time_limit)
  18.257 +
  18.258 +    val ({context = ctxt, prems, concl, ...}, _) = Subgoal.focus ctxt i goal
  18.259 +    fun negate ct = Thm.dest_comb ct ||> Thm.apply @{cterm Not} |-> Thm.apply
  18.260 +    val cprop =
  18.261 +      (case try negate (Thm.rhs_of (SMT_Normalize.atomize_conv ctxt concl)) of
  18.262 +        SOME ct => ct
  18.263 +      | NONE => raise SMT_Failure.SMT (SMT_Failure.Other_Failure "goal is not a HOL term"))
  18.264 +
  18.265 +    val conjecture = Thm.assume cprop
  18.266 +    val facts = map snd xfacts
  18.267 +    val thms = conjecture :: prems @ facts
  18.268 +    val thms' = map (check_topsort ctxt) thms
  18.269 +
  18.270 +    val (name, {command, smt_options, parse_proof, ...}) = name_and_info_of ctxt
  18.271 +    val (output, replay_data) =
  18.272 +      invoke name command smt_options (SMT_Normalize.normalize ctxt thms') ctxt
  18.273 +  in
  18.274 +    parse_proof ctxt replay_data xfacts (map Thm.prop_of prems) (Thm.term_of concl) output
  18.275 +  end
  18.276 +  handle SMT_Failure.SMT fail => {outcome = SOME fail, fact_ids = [], atp_proof = K []}
  18.277 +
  18.278 +
  18.279 +(* SMT tactic *)
  18.280 +
  18.281 +local
  18.282 +  fun str_of ctxt fail =
  18.283 +    "Solver " ^ SMT_Config.solver_of ctxt ^ ": " ^ SMT_Failure.string_of_failure fail
  18.284 +
  18.285 +  fun safe_solve ctxt facts = SOME (apply_solver_and_replay ctxt facts)
  18.286 +    handle
  18.287 +      SMT_Failure.SMT (fail as SMT_Failure.Counterexample _) =>
  18.288 +        (SMT_Config.verbose_msg ctxt (str_of ctxt) fail; NONE)
  18.289 +    | SMT_Failure.SMT (fail as SMT_Failure.Time_Out) =>
  18.290 +        error ("SMT: Solver " ^ quote (SMT_Config.solver_of ctxt) ^ ": " ^
  18.291 +          SMT_Failure.string_of_failure fail ^ " (setting the " ^
  18.292 +          "configuration option " ^ quote (Config.name_of SMT_Config.timeout) ^ " might help)")
  18.293 +    | SMT_Failure.SMT fail => error (str_of ctxt fail)
  18.294 +
  18.295 +  fun resolve (SOME thm) = rtac thm 1
  18.296 +    | resolve NONE = no_tac
  18.297 +
  18.298 +  fun tac prove ctxt rules =
  18.299 +    CONVERSION (SMT_Normalize.atomize_conv ctxt)
  18.300 +    THEN' rtac @{thm ccontr}
  18.301 +    THEN' SUBPROOF (fn {context = ctxt, prems, ...} => resolve (prove ctxt (rules @ prems))) ctxt
  18.302 +in
  18.303 +
  18.304 +val smt_tac = tac safe_solve
  18.305 +val smt_tac' = tac (SOME oo apply_solver_and_replay)
  18.306 +
  18.307 +end
  18.308 +
  18.309 +end;
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Tools/SMT/smt_systems.ML	Thu Aug 28 00:40:38 2014 +0200
    19.3 @@ -0,0 +1,188 @@
    19.4 +(*  Title:      HOL/Tools/SMT/smt_systems.ML
    19.5 +    Author:     Sascha Boehme, TU Muenchen
    19.6 +
    19.7 +Setup SMT solvers.
    19.8 +*)
    19.9 +
   19.10 +signature SMT_SYSTEMS =
   19.11 +sig
   19.12 +  datatype z3_non_commercial =
   19.13 +    Z3_Non_Commercial_Unknown |
   19.14 +    Z3_Non_Commercial_Accepted |
   19.15 +    Z3_Non_Commercial_Declined
   19.16 +  val z3_non_commercial: unit -> z3_non_commercial
   19.17 +  val z3_extensions: bool Config.T
   19.18 +end;
   19.19 +
   19.20 +structure SMT_Systems: SMT_SYSTEMS =
   19.21 +struct
   19.22 +
   19.23 +(* helper functions *)
   19.24 +
   19.25 +fun make_avail name () = getenv (name ^ "_SOLVER") <> ""
   19.26 +
   19.27 +fun make_command name () = [getenv (name ^ "_SOLVER")]
   19.28 +
   19.29 +fun outcome_of unsat sat unknown solver_name line =
   19.30 +  if String.isPrefix unsat line then SMT_Solver.Unsat
   19.31 +  else if String.isPrefix sat line then SMT_Solver.Sat
   19.32 +  else if String.isPrefix unknown line then SMT_Solver.Unknown
   19.33 +  else raise SMT_Failure.SMT (SMT_Failure.Other_Failure ("Solver " ^ quote solver_name ^
   19.34 +    " failed -- enable tracing using the " ^ quote (Config.name_of SMT_Config.trace) ^
   19.35 +    " option for details"))
   19.36 +
   19.37 +fun on_first_line test_outcome solver_name lines =
   19.38 +  let
   19.39 +    val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
   19.40 +    val (l, ls) = split_first (snd (take_prefix (curry (op =) "") lines))
   19.41 +  in (test_outcome solver_name l, ls) end
   19.42 +
   19.43 +fun on_first_non_unsupported_line test_outcome solver_name lines =
   19.44 +  on_first_line test_outcome solver_name (filter (curry (op <>) "unsupported") lines)
   19.45 +
   19.46 +(* CVC3 *)
   19.47 +
   19.48 +local
   19.49 +  fun cvc3_options ctxt = [
   19.50 +    "-seed", string_of_int (Config.get ctxt SMT_Config.random_seed),
   19.51 +    "-lang", "smt2",
   19.52 +    "-timeout", string_of_int (Real.ceil (Config.get ctxt SMT_Config.timeout))]
   19.53 +in
   19.54 +
   19.55 +val cvc3: SMT_Solver.solver_config = {
   19.56 +  name = "cvc3",
   19.57 +  class = K SMTLIB_Interface.smtlibC,
   19.58 +  avail = make_avail "CVC3",
   19.59 +  command = make_command "CVC3",
   19.60 +  options = cvc3_options,
   19.61 +  smt_options = [],
   19.62 +  default_max_relevant = 400 (* FUDGE *),
   19.63 +  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
   19.64 +  parse_proof = NONE,
   19.65 +  replay = NONE }
   19.66 +
   19.67 +end
   19.68 +
   19.69 +
   19.70 +(* CVC4 *)
   19.71 +
   19.72 +local
   19.73 +  fun cvc4_options ctxt = [
   19.74 +    "--random-seed=" ^ string_of_int (Config.get ctxt SMT_Config.random_seed),
   19.75 +    "--lang=smt2",
   19.76 +    "--tlimit", string_of_int (Real.ceil (1000.0 * Config.get ctxt SMT_Config.timeout))]
   19.77 +in
   19.78 +
   19.79 +val cvc4: SMT_Solver.solver_config = {
   19.80 +  name = "cvc4",
   19.81 +  class = K SMTLIB_Interface.smtlibC,
   19.82 +  avail = make_avail "CVC4",
   19.83 +  command = make_command "CVC4",
   19.84 +  options = cvc4_options,
   19.85 +  smt_options = [],
   19.86 +  default_max_relevant = 400 (* FUDGE *),
   19.87 +  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
   19.88 +  parse_proof = NONE,
   19.89 +  replay = NONE }
   19.90 +
   19.91 +end
   19.92 +
   19.93 +(* veriT *)
   19.94 +
   19.95 +val veriT: SMT_Solver.solver_config = {
   19.96 +  name = "veriT",
   19.97 +  class = K SMTLIB_Interface.smtlibC,
   19.98 +  avail = make_avail "VERIT",
   19.99 +  command = make_command "VERIT",
  19.100 +  options = (fn ctxt => [
  19.101 +    "--proof-version=1",
  19.102 +    "--proof=-",
  19.103 +    "--proof-prune",
  19.104 +    "--proof-merge",
  19.105 +    "--disable-print-success",
  19.106 +    "--disable-banner",
  19.107 +    "--max-time=" ^ string_of_int (Real.ceil (Config.get ctxt SMT_Config.timeout))]),
  19.108 +  smt_options = [],
  19.109 +  default_max_relevant = 120 (* FUDGE *),
  19.110 +  outcome = on_first_non_unsupported_line (outcome_of "unsat" "sat"
  19.111 +    "warning : proof_done: status is still open"),
  19.112 +  parse_proof = SOME VeriT_Proof_Parse.parse_proof,
  19.113 +  replay = NONE }
  19.114 +
  19.115 +(* Z3 *)
  19.116 +
  19.117 +datatype z3_non_commercial =
  19.118 +  Z3_Non_Commercial_Unknown |
  19.119 +  Z3_Non_Commercial_Accepted |
  19.120 +  Z3_Non_Commercial_Declined
  19.121 +
  19.122 +local
  19.123 +  val accepted = member (op =) ["yes", "Yes", "YES"]
  19.124 +  val declined = member (op =) ["no", "No", "NO"]
  19.125 +in
  19.126 +
  19.127 +fun z3_non_commercial () =
  19.128 +  let
  19.129 +    val flag1 = Options.default_string @{system_option z3_non_commercial}
  19.130 +    val flag2 = getenv "Z3_NON_COMMERCIAL"
  19.131 +  in
  19.132 +    if accepted flag1 then Z3_Non_Commercial_Accepted
  19.133 +    else if declined flag1 then Z3_Non_Commercial_Declined
  19.134 +    else if accepted flag2 then Z3_Non_Commercial_Accepted
  19.135 +    else if declined flag2 then Z3_Non_Commercial_Declined
  19.136 +    else Z3_Non_Commercial_Unknown
  19.137 +  end
  19.138 +
  19.139 +fun if_z3_non_commercial f =
  19.140 +  (case z3_non_commercial () of
  19.141 +    Z3_Non_Commercial_Accepted => f ()
  19.142 +  | Z3_Non_Commercial_Declined =>
  19.143 +      error (Pretty.string_of (Pretty.para
  19.144 +        "The SMT solver Z3 may be used only for non-commercial applications."))
  19.145 +  | Z3_Non_Commercial_Unknown =>
  19.146 +      error (Pretty.string_of (Pretty.para
  19.147 +        ("The SMT solver Z3 is not activated. To activate it, set the Isabelle \
  19.148 +         \system option \"z3_non_commercial\" to \"yes\" (e.g. via \
  19.149 +         \the Isabelle/jEdit menu Plugin Options / Isabelle / General)."))))
  19.150 +
  19.151 +end
  19.152 +
  19.153 +val z3_extensions = Attrib.setup_config_bool @{binding z3_extensions} (K false)
  19.154 +
  19.155 +local
  19.156 +  fun z3_make_command name () = if_z3_non_commercial (make_command name)
  19.157 +
  19.158 +  fun z3_options ctxt =
  19.159 +    ["smt.random_seed=" ^ string_of_int (Config.get ctxt SMT_Config.random_seed),
  19.160 +     "smt.refine_inj_axioms=false",
  19.161 +     "-T:" ^ string_of_int (Real.ceil (Config.get ctxt SMT_Config.timeout)),
  19.162 +     "-smt2"]
  19.163 +
  19.164 +  fun select_class ctxt =
  19.165 +    if Config.get ctxt z3_extensions then Z3_Interface.smtlib_z3C else SMTLIB_Interface.smtlibC
  19.166 +in
  19.167 +
  19.168 +val z3: SMT_Solver.solver_config = {
  19.169 +  name = "z3",
  19.170 +  class = select_class,
  19.171 +  avail = make_avail "Z3_NEW",
  19.172 +  command = z3_make_command "Z3_NEW",
  19.173 +  options = z3_options,
  19.174 +  smt_options = [(":produce-proofs", "true")],
  19.175 +  default_max_relevant = 350 (* FUDGE *),
  19.176 +  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
  19.177 +  parse_proof = SOME Z3_Replay.parse_proof,
  19.178 +  replay = SOME Z3_Replay.replay }
  19.179 +
  19.180 +end
  19.181 +
  19.182 +
  19.183 +(* overall setup *)
  19.184 +
  19.185 +val _ = Theory.setup (
  19.186 +  SMT_Solver.add_solver cvc3 #>
  19.187 +  SMT_Solver.add_solver cvc4 #>
  19.188 +  SMT_Solver.add_solver veriT #>
  19.189 +  SMT_Solver.add_solver z3)
  19.190 +
  19.191 +end;
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Tools/SMT/smt_translate.ML	Thu Aug 28 00:40:38 2014 +0200
    20.3 @@ -0,0 +1,522 @@
    20.4 +(*  Title:      HOL/Tools/SMT/smt_translate.ML
    20.5 +    Author:     Sascha Boehme, TU Muenchen
    20.6 +
    20.7 +Translate theorems into an SMT intermediate format and serialize them.
    20.8 +*)
    20.9 +
   20.10 +signature SMT_TRANSLATE =
   20.11 +sig
   20.12 +  (*intermediate term structure*)
   20.13 +  datatype squant = SForall | SExists
   20.14 +  datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   20.15 +  datatype sterm =
   20.16 +    SVar of int |
   20.17 +    SApp of string * sterm list |
   20.18 +    SLet of string * sterm * sterm |
   20.19 +    SQua of squant * string list * sterm spattern list * sterm
   20.20 +
   20.21 +  (*translation configuration*)
   20.22 +  type sign = {
   20.23 +    logic: string,
   20.24 +    sorts: string list,
   20.25 +    dtyps: (string * (string * (string * string) list) list) list list,
   20.26 +    funcs: (string * (string list * string)) list }
   20.27 +  type config = {
   20.28 +    logic: term list -> string,
   20.29 +    has_datatypes: bool,
   20.30 +    serialize: (string * string) list -> string list -> sign -> sterm list -> string }
   20.31 +  type replay_data = {
   20.32 +    context: Proof.context,
   20.33 +    typs: typ Symtab.table,
   20.34 +    terms: term Symtab.table,
   20.35 +    ll_defs: term list,
   20.36 +    rewrite_rules: thm list,
   20.37 +    assms: (int * thm) list }
   20.38 +
   20.39 +  (*translation*)
   20.40 +  val add_config: SMT_Util.class * (Proof.context -> config) -> Context.generic -> Context.generic
   20.41 +  val translate: Proof.context -> (string * string) list -> string list -> (int * thm) list ->
   20.42 +    string * replay_data
   20.43 +end;
   20.44 +
   20.45 +structure SMT_Translate: SMT_TRANSLATE =
   20.46 +struct
   20.47 +
   20.48 +
   20.49 +(* intermediate term structure *)
   20.50 +
   20.51 +datatype squant = SForall | SExists
   20.52 +
   20.53 +datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   20.54 +
   20.55 +datatype sterm =
   20.56 +  SVar of int |
   20.57 +  SApp of string * sterm list |
   20.58 +  SLet of string * sterm * sterm |
   20.59 +  SQua of squant * string list * sterm spattern list * sterm
   20.60 +
   20.61 +
   20.62 +(* translation configuration *)
   20.63 +
   20.64 +type sign = {
   20.65 +  logic: string,
   20.66 +  sorts: string list,
   20.67 +  dtyps: (string * (string * (string * string) list) list) list list,
   20.68 +  funcs: (string * (string list * string)) list }
   20.69 +
   20.70 +type config = {
   20.71 +  logic: term list -> string,
   20.72 +  has_datatypes: bool,
   20.73 +  serialize: (string * string) list -> string list -> sign -> sterm list -> string }
   20.74 +
   20.75 +type replay_data = {
   20.76 +  context: Proof.context,
   20.77 +  typs: typ Symtab.table,
   20.78 +  terms: term Symtab.table,
   20.79 +  ll_defs: term list,
   20.80 +  rewrite_rules: thm list,
   20.81 +  assms: (int * thm) list }
   20.82 +
   20.83 +
   20.84 +(* translation context *)
   20.85 +
   20.86 +fun add_components_of_typ (Type (s, Ts)) =
   20.87 +    cons (Long_Name.base_name s) #> fold_rev add_components_of_typ Ts
   20.88 +  | add_components_of_typ (TFree (s, _)) = cons (perhaps (try (unprefix "'")) s)
   20.89 +  | add_components_of_typ _ = I;
   20.90 +
   20.91 +fun suggested_name_of_typ T = space_implode "_" (add_components_of_typ T []);
   20.92 +
   20.93 +fun suggested_name_of_term (Const (s, _)) = Long_Name.base_name s
   20.94 +  | suggested_name_of_term (Free (s, _)) = s
   20.95 +  | suggested_name_of_term _ = Name.uu
   20.96 +
   20.97 +val empty_tr_context = (Name.context, Typtab.empty, Termtab.empty)
   20.98 +val safe_suffix = "$"
   20.99 +
  20.100 +fun add_typ T proper (cx as (names, typs, terms)) =
  20.101 +  (case Typtab.lookup typs T of
  20.102 +    SOME (name, _) => (name, cx)
  20.103 +  | NONE =>
  20.104 +      let
  20.105 +        val sugg = Name.desymbolize (SOME true) (suggested_name_of_typ T) ^ safe_suffix
  20.106 +        val (name, names') = Name.variant sugg names
  20.107 +        val typs' = Typtab.update (T, (name, proper)) typs
  20.108 +      in (name, (names', typs', terms)) end)
  20.109 +
  20.110 +fun add_fun t sort (cx as (names, typs, terms)) =
  20.111 +  (case Termtab.lookup terms t of
  20.112 +    SOME (name, _) => (name, cx)
  20.113 +  | NONE =>
  20.114 +      let
  20.115 +        val sugg = Name.desymbolize (SOME false) (suggested_name_of_term t) ^ safe_suffix
  20.116 +        val (name, names') = Name.variant sugg names
  20.117 +        val terms' = Termtab.update (t, (name, sort)) terms
  20.118 +      in (name, (names', typs, terms')) end)
  20.119 +
  20.120 +fun sign_of logic dtyps (_, typs, terms) = {
  20.121 +  logic = logic,
  20.122 +  sorts = Typtab.fold (fn (_, (n, true)) => cons n | _ => I) typs [],
  20.123 +  dtyps = dtyps,
  20.124 +  funcs = Termtab.fold (fn (_, (n, SOME ss)) => cons (n,ss) | _ => I) terms []}
  20.125 +
  20.126 +fun replay_data_of ctxt ll_defs rules assms (_, typs, terms) =
  20.127 +  let
  20.128 +    fun add_typ (T, (n, _)) = Symtab.update (n, T)
  20.129 +    val typs' = Typtab.fold add_typ typs Symtab.empty
  20.130 +
  20.131 +    fun add_fun (t, (n, _)) = Symtab.update (n, t)
  20.132 +    val terms' = Termtab.fold add_fun terms Symtab.empty
  20.133 +  in
  20.134 +    {context = ctxt, typs = typs', terms = terms', ll_defs = ll_defs, rewrite_rules = rules,
  20.135 +     assms = assms}
  20.136 +  end
  20.137 +
  20.138 +
  20.139 +(* preprocessing *)
  20.140 +
  20.141 +(** datatype declarations **)
  20.142 +
  20.143 +fun collect_datatypes_and_records (tr_context, ctxt) ts =
  20.144 +  let
  20.145 +    val (declss, ctxt') = fold (Term.fold_types SMT_Datatypes.add_decls) ts ([], ctxt)
  20.146 +
  20.147 +    fun is_decl_typ T = exists (exists (equal T o fst)) declss
  20.148 +
  20.149 +    fun add_typ' T proper =
  20.150 +      (case SMT_Builtin.dest_builtin_typ ctxt' T of
  20.151 +        SOME n => pair n
  20.152 +      | NONE => add_typ T proper)
  20.153 +
  20.154 +    fun tr_select sel =
  20.155 +      let val T = Term.range_type (Term.fastype_of sel)
  20.156 +      in add_fun sel NONE ##>> add_typ' T (not (is_decl_typ T)) end
  20.157 +    fun tr_constr (constr, selects) =
  20.158 +      add_fun constr NONE ##>> fold_map tr_select selects
  20.159 +    fun tr_typ (T, cases) = add_typ' T false ##>> fold_map tr_constr cases
  20.160 +    val (declss', tr_context') = fold_map (fold_map tr_typ) declss tr_context
  20.161 +
  20.162 +    fun add (constr, selects) =
  20.163 +      Termtab.update (constr, length selects) #>
  20.164 +      fold (Termtab.update o rpair 1) selects
  20.165 +    val funcs = fold (fold (fold add o snd)) declss Termtab.empty
  20.166 +  in ((funcs, declss', tr_context', ctxt'), ts) end
  20.167 +    (* FIXME: also return necessary datatype and record theorems *)
  20.168 +
  20.169 +
  20.170 +(** eta-expand quantifiers, let expressions and built-ins *)
  20.171 +
  20.172 +local
  20.173 +  fun eta f T t = Abs (Name.uu, T, f (Term.incr_boundvars 1 t $ Bound 0))
  20.174 +
  20.175 +  fun exp f T = eta f (Term.domain_type (Term.domain_type T))
  20.176 +
  20.177 +  fun exp2 T q =
  20.178 +    let val U = Term.domain_type T
  20.179 +    in Abs (Name.uu, U, q $ eta I (Term.domain_type U) (Bound 0)) end
  20.180 +
  20.181 +  fun expf k i T t =
  20.182 +    let val Ts = drop i (fst (SMT_Util.dest_funT k T))
  20.183 +    in
  20.184 +      Term.incr_boundvars (length Ts) t
  20.185 +      |> fold_rev (fn i => fn u => u $ Bound i) (0 upto length Ts - 1)
  20.186 +      |> fold_rev (fn T => fn u => Abs (Name.uu, T, u)) Ts
  20.187 +    end
  20.188 +in
  20.189 +
  20.190 +fun eta_expand ctxt funcs =
  20.191 +  let
  20.192 +    fun exp_func t T ts =
  20.193 +      (case Termtab.lookup funcs t of
  20.194 +        SOME k => Term.list_comb (t, ts) |> k <> length ts ? expf k (length ts) T
  20.195 +      | NONE => Term.list_comb (t, ts))
  20.196 +
  20.197 +    fun expand ((q as Const (@{const_name All}, _)) $ Abs a) = q $ abs_expand a
  20.198 +      | expand ((q as Const (@{const_name All}, T)) $ t) = q $ exp expand T t
  20.199 +      | expand (q as Const (@{const_name All}, T)) = exp2 T q
  20.200 +      | expand ((q as Const (@{const_name Ex}, _)) $ Abs a) = q $ abs_expand a
  20.201 +      | expand ((q as Const (@{const_name Ex}, T)) $ t) = q $ exp expand T t
  20.202 +      | expand (q as Const (@{const_name Ex}, T)) = exp2 T q
  20.203 +      | expand (Const (@{const_name Let}, _) $ t $ u) = expand (Term.betapply (u, t))
  20.204 +      | expand (Const (@{const_name Let}, T) $ t) =
  20.205 +          let val U = Term.domain_type (Term.range_type T)
  20.206 +          in Abs (Name.uu, U, Bound 0 $ Term.incr_boundvars 1 t) end
  20.207 +      | expand (Const (@{const_name Let}, T)) =
  20.208 +          let val U = Term.domain_type (Term.range_type T)
  20.209 +          in Abs (Name.uu, Term.domain_type T, Abs (Name.uu, U, Bound 0 $ Bound 1)) end
  20.210 +      | expand t =
  20.211 +          (case Term.strip_comb t of
  20.212 +            (u as Const (c as (_, T)), ts) =>
  20.213 +              (case SMT_Builtin.dest_builtin ctxt c ts of
  20.214 +                SOME (_, k, us, mk) =>
  20.215 +                  if k = length us then mk (map expand us)
  20.216 +                  else if k < length us then chop k (map expand us) |>> mk |> Term.list_comb
  20.217 +                  else expf k (length ts) T (mk (map expand us))
  20.218 +              | NONE => exp_func u T (map expand ts))
  20.219 +          | (u as Free (_, T), ts) => exp_func u T (map expand ts)
  20.220 +          | (Abs a, ts) => Term.list_comb (abs_expand a, map expand ts)
  20.221 +          | (u, ts) => Term.list_comb (u, map expand ts))
  20.222 +
  20.223 +    and abs_expand (n, T, t) = Abs (n, T, expand t)
  20.224 +
  20.225 +  in map expand end
  20.226 +
  20.227 +end
  20.228 +
  20.229 +
  20.230 +(** introduce explicit applications **)
  20.231 +
  20.232 +local
  20.233 +  (*
  20.234 +    Make application explicit for functions with varying number of arguments.
  20.235 +  *)
  20.236 +
  20.237 +  fun add t i = apfst (Termtab.map_default (t, i) (Integer.min i))
  20.238 +  fun add_type T = apsnd (Typtab.update (T, ()))
  20.239 +
  20.240 +  fun min_arities t =
  20.241 +    (case Term.strip_comb t of
  20.242 +      (u as Const _, ts) => add u (length ts) #> fold min_arities ts
  20.243 +    | (u as Free _, ts) => add u (length ts) #> fold min_arities ts
  20.244 +    | (Abs (_, T, u), ts) => (can dest_funT T ? add_type T) #> min_arities u #> fold min_arities ts
  20.245 +    | (_, ts) => fold min_arities ts)
  20.246 +
  20.247 +  fun minimize types t i =
  20.248 +    let
  20.249 +      fun find_min j [] _ = j
  20.250 +        | find_min j (U :: Us) T =
  20.251 +            if Typtab.defined types T then j else find_min (j + 1) Us (U --> T)
  20.252 +
  20.253 +      val (Ts, T) = Term.strip_type (Term.type_of t)
  20.254 +    in find_min 0 (take i (rev Ts)) T end
  20.255 +
  20.256 +  fun app u (t, T) = (Const (@{const_name fun_app}, T --> T) $ t $ u, Term.range_type T)
  20.257 +
  20.258 +  fun apply i t T ts =
  20.259 +    let
  20.260 +      val (ts1, ts2) = chop i ts
  20.261 +      val (_, U) = SMT_Util.dest_funT i T
  20.262 +    in fst (fold app ts2 (Term.list_comb (t, ts1), U)) end
  20.263 +in
  20.264 +
  20.265 +fun intro_explicit_application ctxt funcs ts =
  20.266 +  let
  20.267 +    val (arities, types) = fold min_arities ts (Termtab.empty, Typtab.empty)
  20.268 +    val arities' = Termtab.map (minimize types) arities (* FIXME: highly suspicious *)
  20.269 +
  20.270 +    fun app_func t T ts =
  20.271 +      if is_some (Termtab.lookup funcs t) then Term.list_comb (t, ts)
  20.272 +      else apply (the (Termtab.lookup arities' t)) t T ts
  20.273 +
  20.274 +    fun in_list T f t = SMT_Util.mk_symb_list T (map f (SMT_Util.dest_symb_list t))
  20.275 +
  20.276 +    fun traverse Ts t =
  20.277 +      (case Term.strip_comb t of
  20.278 +        (q as Const (@{const_name All}, _), [Abs (x, T, u)]) =>
  20.279 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  20.280 +      | (q as Const (@{const_name Ex}, _), [Abs (x, T, u)]) =>
  20.281 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  20.282 +      | (q as Const (@{const_name Let}, _), [u1, u2 as Abs _]) =>
  20.283 +          q $ traverse Ts u1 $ traverse Ts u2
  20.284 +      | (u as Const (c as (_, T)), ts) =>
  20.285 +          (case SMT_Builtin.dest_builtin ctxt c ts of
  20.286 +            SOME (_, k, us, mk) =>
  20.287 +              let
  20.288 +                val (ts1, ts2) = chop k (map (traverse Ts) us)
  20.289 +                val U = Term.strip_type T |>> snd o chop k |> (op --->)
  20.290 +              in apply 0 (mk ts1) U ts2 end
  20.291 +          | NONE => app_func u T (map (traverse Ts) ts))
  20.292 +      | (u as Free (_, T), ts) => app_func u T (map (traverse Ts) ts)
  20.293 +      | (u as Bound i, ts) => apply 0 u (nth Ts i) (map (traverse Ts) ts)
  20.294 +      | (Abs (n, T, u), ts) => traverses Ts (Abs (n, T, traverse (T::Ts) u)) ts
  20.295 +      | (u, ts) => traverses Ts u ts)
  20.296 +    and in_trigger Ts ((c as @{const trigger}) $ p $ t) = c $ in_pats Ts p $ traverse Ts t
  20.297 +      | in_trigger Ts t = traverse Ts t
  20.298 +    and in_pats Ts ps =
  20.299 +      in_list @{typ "pattern symb_list"} (in_list @{typ pattern} (in_pat Ts)) ps
  20.300 +    and in_pat Ts ((p as Const (@{const_name pat}, _)) $ t) = p $ traverse Ts t
  20.301 +      | in_pat Ts ((p as Const (@{const_name nopat}, _)) $ t) = p $ traverse Ts t
  20.302 +      | in_pat _ t = raise TERM ("bad pattern", [t])
  20.303 +    and traverses Ts t ts = Term.list_comb (t, map (traverse Ts) ts)
  20.304 +  in map (traverse []) ts end
  20.305 +
  20.306 +val fun_app_eq = mk_meta_eq @{thm fun_app_def}
  20.307 +
  20.308 +end
  20.309 +
  20.310 +
  20.311 +(** map HOL formulas to FOL formulas (i.e., separate formulas froms terms) **)
  20.312 +
  20.313 +local
  20.314 +  val is_quant = member (op =) [@{const_name All}, @{const_name Ex}]
  20.315 +
  20.316 +  val fol_rules = [
  20.317 +    Let_def,
  20.318 +    @{lemma "P = True == P" by (rule eq_reflection) simp},
  20.319 +    @{lemma "if P then True else False == P" by (rule eq_reflection) simp}]
  20.320 +
  20.321 +  exception BAD_PATTERN of unit
  20.322 +
  20.323 +  fun wrap_in_if pat t =
  20.324 +    if pat then raise BAD_PATTERN () else @{const If (bool)} $ t $ @{const True} $ @{const False}
  20.325 +
  20.326 +  fun is_builtin_conn_or_pred ctxt c ts =
  20.327 +    is_some (SMT_Builtin.dest_builtin_conn ctxt c ts) orelse
  20.328 +    is_some (SMT_Builtin.dest_builtin_pred ctxt c ts)
  20.329 +in
  20.330 +
  20.331 +fun folify ctxt =
  20.332 +  let
  20.333 +    fun in_list T f t = SMT_Util.mk_symb_list T (map_filter f (SMT_Util.dest_symb_list t))
  20.334 +
  20.335 +    fun in_term pat t =
  20.336 +      (case Term.strip_comb t of
  20.337 +        (@{const True}, []) => t
  20.338 +      | (@{const False}, []) => t
  20.339 +      | (u as Const (@{const_name If}, _), [t1, t2, t3]) =>
  20.340 +          if pat then raise BAD_PATTERN () else u $ in_form t1 $ in_term pat t2 $ in_term pat t3
  20.341 +      | (Const (c as (n, _)), ts) =>
  20.342 +          if is_builtin_conn_or_pred ctxt c ts then wrap_in_if pat (in_form t)
  20.343 +          else if is_quant n then wrap_in_if pat (in_form t)
  20.344 +          else Term.list_comb (Const c, map (in_term pat) ts)
  20.345 +      | (Free c, ts) => Term.list_comb (Free c, map (in_term pat) ts)
  20.346 +      | _ => t)
  20.347 +
  20.348 +    and in_pat ((p as Const (@{const_name pat}, _)) $ t) =
  20.349 +          p $ in_term true t
  20.350 +      | in_pat ((p as Const (@{const_name nopat}, _)) $ t) =
  20.351 +          p $ in_term true t
  20.352 +      | in_pat t = raise TERM ("bad pattern", [t])
  20.353 +
  20.354 +    and in_pats ps =
  20.355 +      in_list @{typ "pattern symb_list"} (SOME o in_list @{typ pattern} (try in_pat)) ps
  20.356 +
  20.357 +    and in_trigger ((c as @{const trigger}) $ p $ t) = c $ in_pats p $ in_form t
  20.358 +      | in_trigger t = in_form t
  20.359 +
  20.360 +    and in_form t =
  20.361 +      (case Term.strip_comb t of
  20.362 +        (q as Const (qn, _), [Abs (n, T, u)]) =>
  20.363 +          if is_quant qn then q $ Abs (n, T, in_trigger u)
  20.364 +          else in_term false t
  20.365 +      | (Const c, ts) =>
  20.366 +          (case SMT_Builtin.dest_builtin_conn ctxt c ts of
  20.367 +            SOME (_, _, us, mk) => mk (map in_form us)
  20.368 +          | NONE =>
  20.369 +              (case SMT_Builtin.dest_builtin_pred ctxt c ts of
  20.370 +                SOME (_, _, us, mk) => mk (map (in_term false) us)
  20.371 +              | NONE => in_term false t))
  20.372 +      | _ => in_term false t)
  20.373 +  in
  20.374 +    map in_form #>
  20.375 +    pair (fol_rules, I)
  20.376 +  end
  20.377 +
  20.378 +end
  20.379 +
  20.380 +
  20.381 +(* translation into intermediate format *)
  20.382 +
  20.383 +(** utility functions **)
  20.384 +
  20.385 +val quantifier = (fn
  20.386 +    @{const_name All} => SOME SForall
  20.387 +  | @{const_name Ex} => SOME SExists
  20.388 +  | _ => NONE)
  20.389 +
  20.390 +fun group_quant qname Ts (t as Const (q, _) $ Abs (_, T, u)) =
  20.391 +      if q = qname then group_quant qname (T :: Ts) u else (Ts, t)
  20.392 +  | group_quant _ Ts t = (Ts, t)
  20.393 +
  20.394 +fun dest_pat (Const (@{const_name pat}, _) $ t) = (t, true)
  20.395 +  | dest_pat (Const (@{const_name nopat}, _) $ t) = (t, false)
  20.396 +  | dest_pat t = raise TERM ("bad pattern", [t])
  20.397 +
  20.398 +fun dest_pats [] = I
  20.399 +  | dest_pats ts =
  20.400 +      (case map dest_pat ts |> split_list ||> distinct (op =) of
  20.401 +        (ps, [true]) => cons (SPat ps)
  20.402 +      | (ps, [false]) => cons (SNoPat ps)
  20.403 +      | _ => raise TERM ("bad multi-pattern", ts))
  20.404 +
  20.405 +fun dest_trigger (@{const trigger} $ tl $ t) =
  20.406 +      (rev (fold (dest_pats o SMT_Util.dest_symb_list) (SMT_Util.dest_symb_list tl) []), t)
  20.407 +  | dest_trigger t = ([], t)
  20.408 +
  20.409 +fun dest_quant qn T t = quantifier qn |> Option.map (fn q =>
  20.410 +  let
  20.411 +    val (Ts, u) = group_quant qn [T] t
  20.412 +    val (ps, p) = dest_trigger u
  20.413 +  in (q, rev Ts, ps, p) end)
  20.414 +
  20.415 +fun fold_map_pat f (SPat ts) = fold_map f ts #>> SPat
  20.416 +  | fold_map_pat f (SNoPat ts) = fold_map f ts #>> SNoPat
  20.417 +
  20.418 +
  20.419 +(** translation from Isabelle terms into SMT intermediate terms **)
  20.420 +
  20.421 +fun intermediate logic dtyps builtin ctxt ts trx =
  20.422 +  let
  20.423 +    fun transT (T as TFree _) = add_typ T true
  20.424 +      | transT (T as TVar _) = (fn _ => raise TYPE ("bad SMT type", [T], []))
  20.425 +      | transT (T as Type _) =
  20.426 +          (case SMT_Builtin.dest_builtin_typ ctxt T of
  20.427 +            SOME n => pair n
  20.428 +          | NONE => add_typ T true)
  20.429 +
  20.430 +    fun app n ts = SApp (n, ts)
  20.431 +
  20.432 +    fun trans t =
  20.433 +      (case Term.strip_comb t of
  20.434 +        (Const (qn, _), [Abs (_, T, t1)]) =>
  20.435 +          (case dest_quant qn T t1 of
  20.436 +            SOME (q, Ts, ps, b) =>
  20.437 +              fold_map transT Ts ##>> fold_map (fold_map_pat trans) ps ##>>
  20.438 +              trans b #>> (fn ((Ts', ps'), b') => SQua (q, Ts', ps', b'))
  20.439 +          | NONE => raise TERM ("unsupported quantifier", [t]))
  20.440 +      | (Const (@{const_name Let}, _), [t1, Abs (_, T, t2)]) =>
  20.441 +          transT T ##>> trans t1 ##>> trans t2 #>> (fn ((U, u1), u2) => SLet (U, u1, u2))
  20.442 +      | (u as Const (c as (_, T)), ts) =>
  20.443 +          (case builtin ctxt c ts of
  20.444 +            SOME (n, _, us, _) => fold_map trans us #>> app n
  20.445 +          | NONE => transs u T ts)
  20.446 +      | (u as Free (_, T), ts) => transs u T ts
  20.447 +      | (Bound i, []) => pair (SVar i)
  20.448 +      | _ => raise TERM ("bad SMT term", [t]))
  20.449 +
  20.450 +    and transs t T ts =
  20.451 +      let val (Us, U) = SMT_Util.dest_funT (length ts) T
  20.452 +      in
  20.453 +        fold_map transT Us ##>> transT U #-> (fn Up =>
  20.454 +          add_fun t (SOME Up) ##>> fold_map trans ts #>> SApp)
  20.455 +      end
  20.456 +
  20.457 +    val (us, trx') = fold_map trans ts trx
  20.458 +  in ((sign_of (logic ts) dtyps trx', us), trx') end
  20.459 +
  20.460 +
  20.461 +(* translation *)
  20.462 +
  20.463 +structure Configs = Generic_Data
  20.464 +(
  20.465 +  type T = (Proof.context -> config) SMT_Util.dict
  20.466 +  val empty = []
  20.467 +  val extend = I
  20.468 +  fun merge data = SMT_Util.dict_merge fst data
  20.469 +)
  20.470 +
  20.471 +fun add_config (cs, cfg) = Configs.map (SMT_Util.dict_update (cs, cfg))
  20.472 +
  20.473 +fun get_config ctxt =
  20.474 +  let val cs = SMT_Config.solver_class_of ctxt
  20.475 +  in
  20.476 +    (case SMT_Util.dict_get (Configs.get (Context.Proof ctxt)) cs of
  20.477 +      SOME cfg => cfg ctxt
  20.478 +    | NONE => error ("SMT: no translation configuration found " ^
  20.479 +        "for solver class " ^ quote (SMT_Util.string_of_class cs)))
  20.480 +  end
  20.481 +
  20.482 +fun translate ctxt smt_options comments ithms =
  20.483 +  let
  20.484 +    val {logic, has_datatypes, serialize} = get_config ctxt
  20.485 +
  20.486 +    fun no_dtyps (tr_context, ctxt) ts =
  20.487 +      ((Termtab.empty, [], tr_context, ctxt), ts)
  20.488 +
  20.489 +    val ts1 = map (Envir.beta_eta_contract o SMT_Util.prop_of o snd) ithms
  20.490 +
  20.491 +    val ((funcs, dtyps, tr_context, ctxt1), ts2) =
  20.492 +      ((empty_tr_context, ctxt), ts1)
  20.493 +      |-> (if has_datatypes then collect_datatypes_and_records else no_dtyps)
  20.494 +
  20.495 +    fun is_binder (Const (@{const_name Let}, _) $ _) = true
  20.496 +      | is_binder t = Lambda_Lifting.is_quantifier t
  20.497 +
  20.498 +    fun mk_trigger ((q as Const (@{const_name All}, _)) $ Abs (n, T, t)) =
  20.499 +          q $ Abs (n, T, mk_trigger t)
  20.500 +      | mk_trigger (eq as (Const (@{const_name HOL.eq}, T) $ lhs $ _)) =
  20.501 +          Term.domain_type T --> @{typ pattern}
  20.502 +          |> (fn T => Const (@{const_name pat}, T) $ lhs)
  20.503 +          |> SMT_Util.mk_symb_list @{typ pattern} o single
  20.504 +          |> SMT_Util.mk_symb_list @{typ "pattern symb_list"} o single
  20.505 +          |> (fn t => @{const trigger} $ t $ eq)
  20.506 +      | mk_trigger t = t
  20.507 +
  20.508 +    val (ctxt2, (ts3, ll_defs)) =
  20.509 +      ts2
  20.510 +      |> eta_expand ctxt1 funcs
  20.511 +      |> rpair ctxt1
  20.512 +      |-> Lambda_Lifting.lift_lambdas NONE is_binder
  20.513 +      |-> (fn (ts', ll_defs) => fn ctxt' =>
  20.514 +          (ctxt', (intro_explicit_application ctxt' funcs (map mk_trigger ll_defs @ ts'), ll_defs)))
  20.515 +
  20.516 +    val ((rewrite_rules, builtin), ts4) = folify ctxt2 ts3
  20.517 +      |>> apfst (cons fun_app_eq)
  20.518 +  in
  20.519 +    (ts4, tr_context)
  20.520 +    |-> intermediate logic dtyps (builtin SMT_Builtin.dest_builtin) ctxt2
  20.521 +    |>> uncurry (serialize smt_options comments)
  20.522 +    ||> replay_data_of ctxt2 ll_defs rewrite_rules ithms
  20.523 +  end
  20.524 +
  20.525 +end;
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/Tools/SMT/smt_util.ML	Thu Aug 28 00:40:38 2014 +0200
    21.3 @@ -0,0 +1,246 @@
    21.4 +(*  Title:      HOL/Tools/SMT/smt_util.ML
    21.5 +    Author:     Sascha Boehme, TU Muenchen
    21.6 +
    21.7 +General utility functions.
    21.8 +*)
    21.9 +
   21.10 +signature SMT_UTIL =
   21.11 +sig
   21.12 +  (*basic combinators*)
   21.13 +  val repeat: ('a -> 'a option) -> 'a -> 'a
   21.14 +  val repeat_yield: ('a -> 'b -> ('a * 'b) option) -> 'a -> 'b -> 'a * 'b
   21.15 +
   21.16 +  (*class dictionaries*)
   21.17 +  type class = string list
   21.18 +  val basicC: class
   21.19 +  val string_of_class: class -> string
   21.20 +  type 'a dict = (class * 'a) Ord_List.T
   21.21 +  val dict_map_default: class * 'a -> ('a -> 'a) -> 'a dict -> 'a dict
   21.22 +  val dict_update: class * 'a -> 'a dict -> 'a dict
   21.23 +  val dict_merge: ('a * 'a -> 'a) -> 'a dict * 'a dict -> 'a dict
   21.24 +  val dict_lookup: 'a dict -> class -> 'a list
   21.25 +  val dict_get: 'a dict -> class -> 'a option
   21.26 +
   21.27 +  (*types*)
   21.28 +  val dest_funT: int -> typ -> typ list * typ
   21.29 +
   21.30 +  (*terms*)
   21.31 +  val dest_conj: term -> term * term
   21.32 +  val dest_disj: term -> term * term
   21.33 +  val under_quant: (term -> 'a) -> term -> 'a
   21.34 +  val is_number: term -> bool
   21.35 +
   21.36 +  (*symbolic lists*)
   21.37 +  val symb_nil_const: typ -> term
   21.38 +  val symb_cons_const: typ -> term
   21.39 +  val mk_symb_list: typ -> term list -> term
   21.40 +  val dest_symb_list: term -> term list
   21.41 +
   21.42 +  (*patterns and instantiations*)
   21.43 +  val mk_const_pat: theory -> string -> (ctyp -> 'a) -> 'a * cterm
   21.44 +  val destT1: ctyp -> ctyp
   21.45 +  val destT2: ctyp -> ctyp
   21.46 +  val instTs: ctyp list -> ctyp list * cterm -> cterm
   21.47 +  val instT: ctyp -> ctyp * cterm -> cterm
   21.48 +  val instT': cterm -> ctyp * cterm -> cterm
   21.49 +
   21.50 +  (*certified terms*)
   21.51 +  val certify: Proof.context -> term -> cterm
   21.52 +  val typ_of: cterm -> typ
   21.53 +  val dest_cabs: cterm -> Proof.context -> cterm * Proof.context
   21.54 +  val dest_all_cabs: cterm -> Proof.context -> cterm * Proof.context
   21.55 +  val dest_cbinder: cterm -> Proof.context -> cterm * Proof.context
   21.56 +  val dest_all_cbinders: cterm -> Proof.context -> cterm * Proof.context
   21.57 +  val mk_cprop: cterm -> cterm
   21.58 +  val dest_cprop: cterm -> cterm
   21.59 +  val mk_cequals: cterm -> cterm -> cterm
   21.60 +  val term_of: cterm -> term
   21.61 +  val prop_of: thm -> term
   21.62 +
   21.63 +  (*conversions*)
   21.64 +  val if_conv: (term -> bool) -> conv -> conv -> conv
   21.65 +  val if_true_conv: (term -> bool) -> conv -> conv
   21.66 +  val if_exists_conv: (term -> bool) -> conv -> conv
   21.67 +  val binders_conv: (Proof.context -> conv) -> Proof.context -> conv
   21.68 +  val under_quant_conv: (Proof.context * cterm list -> conv) ->
   21.69 +    Proof.context -> conv
   21.70 +  val prop_conv: conv -> conv
   21.71 +end;
   21.72 +
   21.73 +structure SMT_Util: SMT_UTIL =
   21.74 +struct
   21.75 +
   21.76 +(* basic combinators *)
   21.77 +
   21.78 +fun repeat f =
   21.79 +  let fun rep x = (case f x of SOME y => rep y | NONE => x)
   21.80 +  in rep end
   21.81 +
   21.82 +fun repeat_yield f =
   21.83 +  let fun rep x y = (case f x y of SOME (x', y') => rep x' y' | NONE => (x, y))
   21.84 +  in rep end
   21.85 +
   21.86 +
   21.87 +(* class dictionaries *)
   21.88 +
   21.89 +type class = string list
   21.90 +
   21.91 +val basicC = []
   21.92 +
   21.93 +fun string_of_class [] = "basic"
   21.94 +  | string_of_class cs = "basic." ^ space_implode "." cs
   21.95 +
   21.96 +type 'a dict = (class * 'a) Ord_List.T
   21.97 +
   21.98 +fun class_ord ((cs1, _), (cs2, _)) =
   21.99 +  rev_order (list_ord fast_string_ord (cs1, cs2))
  21.100 +
  21.101 +fun dict_insert (cs, x) d =
  21.102 +  if AList.defined (op =) d cs then d
  21.103 +  else Ord_List.insert class_ord (cs, x) d
  21.104 +
  21.105 +fun dict_map_default (cs, x) f =
  21.106 +  dict_insert (cs, x) #> AList.map_entry (op =) cs f
  21.107 +
  21.108 +fun dict_update (e as (_, x)) = dict_map_default e (K x)
  21.109 +
  21.110 +fun dict_merge val_merge = sort class_ord o AList.join (op =) (K val_merge)
  21.111 +
  21.112 +fun dict_lookup d cs =
  21.113 +  let fun match (cs', x) = if is_prefix (op =) cs' cs then SOME x else NONE
  21.114 +  in map_filter match d end
  21.115 +
  21.116 +fun dict_get d cs =
  21.117 +  (case AList.lookup (op =) d cs of
  21.118 +    NONE => (case cs of [] => NONE | _ => dict_get d (take (length cs - 1) cs))
  21.119 +  | SOME x => SOME x)
  21.120 +
  21.121 +
  21.122 +(* types *)
  21.123 +
  21.124 +val dest_funT =
  21.125 +  let
  21.126 +    fun dest Ts 0 T = (rev Ts, T)
  21.127 +      | dest Ts i (Type ("fun", [T, U])) = dest (T::Ts) (i-1) U
  21.128 +      | dest _ _ T = raise TYPE ("not a function type", [T], [])
  21.129 +  in dest [] end
  21.130 +
  21.131 +
  21.132 +(* terms *)
  21.133 +
  21.134 +fun dest_conj (@{const HOL.conj} $ t $ u) = (t, u)
  21.135 +  | dest_conj t = raise TERM ("not a conjunction", [t])
  21.136 +
  21.137 +fun dest_disj (@{const HOL.disj} $ t $ u) = (t, u)
  21.138 +  | dest_disj t = raise TERM ("not a disjunction", [t])
  21.139 +
  21.140 +fun under_quant f t =
  21.141 +  (case t of
  21.142 +    Const (@{const_name All}, _) $ Abs (_, _, u) => under_quant f u
  21.143 +  | Const (@{const_name Ex}, _) $ Abs (_, _, u) => under_quant f u
  21.144 +  | _ => f t)
  21.145 +
  21.146 +val is_number =
  21.147 +  let
  21.148 +    fun is_num env (Const (@{const_name Let}, _) $ t $ Abs (_, _, u)) = is_num (t :: env) u
  21.149 +      | is_num env (Bound i) = i < length env andalso is_num env (nth env i)
  21.150 +      | is_num _ t = can HOLogic.dest_number t
  21.151 +  in is_num [] end
  21.152 +
  21.153 +
  21.154 +(* symbolic lists *)
  21.155 +
  21.156 +fun symb_listT T = Type (@{type_name symb_list}, [T])
  21.157 +
  21.158 +fun symb_nil_const T = Const (@{const_name Symb_Nil}, symb_listT T)
  21.159 +
  21.160 +fun symb_cons_const T =
  21.161 +  let val listT = symb_listT T in Const (@{const_name Symb_Cons}, T --> listT --> listT) end
  21.162 +
  21.163 +fun mk_symb_list T ts =
  21.164 +  fold_rev (fn t => fn u => symb_cons_const T $ t $ u) ts (symb_nil_const T)
  21.165 +
  21.166 +fun dest_symb_list (Const (@{const_name Symb_Nil}, _)) = []
  21.167 +  | dest_symb_list (Const (@{const_name Symb_Cons}, _) $ t $ u) = t :: dest_symb_list u
  21.168 +
  21.169 +
  21.170 +(* patterns and instantiations *)
  21.171 +
  21.172 +fun mk_const_pat thy name destT =
  21.173 +  let val cpat = Thm.cterm_of thy (Const (name, Sign.the_const_type thy name))
  21.174 +  in (destT (Thm.ctyp_of_term cpat), cpat) end
  21.175 +
  21.176 +val destT1 = hd o Thm.dest_ctyp
  21.177 +val destT2 = hd o tl o Thm.dest_ctyp
  21.178 +
  21.179 +fun instTs cUs (cTs, ct) = Thm.instantiate_cterm (cTs ~~ cUs, []) ct
  21.180 +fun instT cU (cT, ct) = instTs [cU] ([cT], ct)
  21.181 +fun instT' ct = instT (Thm.ctyp_of_term ct)
  21.182 +
  21.183 +
  21.184 +(* certified terms *)
  21.185 +
  21.186 +fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt)
  21.187 +
  21.188 +fun typ_of ct = #T (Thm.rep_cterm ct)
  21.189 +
  21.190 +fun dest_cabs ct ctxt =
  21.191 +  (case Thm.term_of ct of
  21.192 +    Abs _ =>
  21.193 +      let val (n, ctxt') = yield_singleton Variable.variant_fixes Name.uu ctxt
  21.194 +      in (snd (Thm.dest_abs (SOME n) ct), ctxt') end
  21.195 +  | _ => raise CTERM ("no abstraction", [ct]))
  21.196 +
  21.197 +val dest_all_cabs = repeat_yield (try o dest_cabs)
  21.198 +
  21.199 +fun dest_cbinder ct ctxt =
  21.200 +  (case Thm.term_of ct of
  21.201 +    Const _ $ Abs _ => dest_cabs (Thm.dest_arg ct) ctxt
  21.202 +  | _ => raise CTERM ("not a binder", [ct]))
  21.203 +
  21.204 +val dest_all_cbinders = repeat_yield (try o dest_cbinder)
  21.205 +
  21.206 +val mk_cprop = Thm.apply (Thm.cterm_of @{theory} @{const Trueprop})
  21.207 +
  21.208 +fun dest_cprop ct =
  21.209 +  (case Thm.term_of ct of
  21.210 +    @{const Trueprop} $ _ => Thm.dest_arg ct
  21.211 +  | _ => raise CTERM ("not a property", [ct]))
  21.212 +
  21.213 +val equals = mk_const_pat @{theory} @{const_name Pure.eq} destT1
  21.214 +fun mk_cequals ct cu = Thm.mk_binop (instT' ct equals) ct cu
  21.215 +
  21.216 +val dest_prop = (fn @{const Trueprop} $ t => t | t => t)
  21.217 +fun term_of ct = dest_prop (Thm.term_of ct)
  21.218 +fun prop_of thm = dest_prop (Thm.prop_of thm)
  21.219 +
  21.220 +
  21.221 +(* conversions *)
  21.222 +
  21.223 +fun if_conv pred cv1 cv2 ct = if pred (Thm.term_of ct) then cv1 ct else cv2 ct
  21.224 +
  21.225 +fun if_true_conv pred cv = if_conv pred cv Conv.all_conv
  21.226 +
  21.227 +fun if_exists_conv pred = if_true_conv (Term.exists_subterm pred)
  21.228 +
  21.229 +fun binders_conv cv ctxt =
  21.230 +  Conv.binder_conv (binders_conv cv o snd) ctxt else_conv cv ctxt
  21.231 +
  21.232 +fun under_quant_conv cv ctxt =
  21.233 +  let
  21.234 +    fun quant_conv inside ctxt cvs ct =
  21.235 +      (case Thm.term_of ct of
  21.236 +        Const (@{const_name All}, _) $ Abs _ =>
  21.237 +          Conv.binder_conv (under_conv cvs) ctxt
  21.238 +      | Const (@{const_name Ex}, _) $ Abs _ =>
  21.239 +          Conv.binder_conv (under_conv cvs) ctxt
  21.240 +      | _ => if inside then cv (ctxt, cvs) else Conv.all_conv) ct
  21.241 +    and under_conv cvs (cv, ctxt) = quant_conv true ctxt (cv :: cvs)
  21.242 +  in quant_conv false ctxt [] end
  21.243 +
  21.244 +fun prop_conv cv ct =
  21.245 +  (case Thm.term_of ct of
  21.246 +    @{const Trueprop} $ _ => Conv.arg_conv cv ct
  21.247 +  | _ => raise CTERM ("not a property", [ct]))
  21.248 +
  21.249 +end;
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/Tools/SMT/smtlib.ML	Thu Aug 28 00:40:38 2014 +0200
    22.3 @@ -0,0 +1,191 @@
    22.4 +(*  Title:      HOL/Tools/SMT/smtlib.ML
    22.5 +    Author:     Sascha Boehme, TU Muenchen
    22.6 +
    22.7 +Parsing and generating SMT-LIB 2.
    22.8 +*)
    22.9 +
   22.10 +signature SMTLIB =
   22.11 +sig
   22.12 +  exception PARSE of int * string
   22.13 +  datatype tree = 
   22.14 +    Num of int |
   22.15 +    Dec of int * int |
   22.16 +    Str of string |
   22.17 +    Sym of string |
   22.18 +    Key of string |
   22.19 +    S of tree list
   22.20 +  val parse: string list -> tree
   22.21 +  val pretty_tree: tree -> Pretty.T
   22.22 +  val str_of: tree -> string
   22.23 +end;
   22.24 +
   22.25 +structure SMTLIB: SMTLIB =
   22.26 +struct
   22.27 +
   22.28 +(* data structures *)
   22.29 +
   22.30 +exception PARSE of int * string
   22.31 +
   22.32 +datatype tree = 
   22.33 +  Num of int |
   22.34 +  Dec of int * int |
   22.35 +  Str of string |
   22.36 +  Sym of string |
   22.37 +  Key of string |
   22.38 +  S of tree list
   22.39 +
   22.40 +datatype unfinished = None | String of string | Symbol of string
   22.41 +
   22.42 +
   22.43 +(* utilities *)
   22.44 +
   22.45 +fun read_raw pred l cs =
   22.46 +  (case take_prefix pred cs of
   22.47 +    ([], []) => raise PARSE (l, "empty token")
   22.48 +  | ([], c :: _) => raise PARSE (l, "unexpected character " ^ quote c)
   22.49 +  | x => x)
   22.50 +
   22.51 +
   22.52 +(* numerals and decimals *)
   22.53 +
   22.54 +fun int_of cs = fst (read_int cs)
   22.55 +
   22.56 +fun read_num l cs =
   22.57 +  (case read_raw Symbol.is_ascii_digit l cs of
   22.58 +    (cs1, "." :: cs') =>
   22.59 +      let val (cs2, cs'') = read_raw Symbol.is_ascii_digit l cs'
   22.60 +      in (Dec (int_of cs1, int_of cs2), cs'') end
   22.61 +  | (cs1, cs2) => (Num (int_of cs1), cs2))
   22.62 +
   22.63 +
   22.64 +(* binary numbers *)
   22.65 +
   22.66 +fun is_bin c = (c = "0" orelse c = "1")
   22.67 +
   22.68 +fun read_bin l cs = read_raw is_bin l cs |>> Num o fst o read_radix_int 2
   22.69 +
   22.70 +
   22.71 +(* hex numbers *)
   22.72 +
   22.73 +val is_hex = member (op =) (raw_explode "0123456789abcdefABCDEF")
   22.74 +
   22.75 +fun within c1 c2 c = (ord c1 <= ord c andalso ord c <= ord c2)
   22.76 +
   22.77 +fun unhex i [] = i
   22.78 +  | unhex i (c :: cs) =
   22.79 +      if within "0" "9" c then unhex (i * 16 + (ord c - ord "0")) cs
   22.80 +      else if within "a" "f" c then unhex (i * 16 + (ord c - ord "a" + 10)) cs
   22.81 +      else if within "A" "F" c then unhex (i * 16 + (ord c - ord "A" + 10)) cs
   22.82 +      else raise Fail ("bad hex character " ^ quote c)
   22.83 +
   22.84 +fun read_hex l cs = read_raw is_hex l cs |>> Num o unhex 0
   22.85 +
   22.86 +
   22.87 +(* symbols *)
   22.88 +
   22.89 +val symbol_chars = raw_explode "~!@$%^&*_+=<>.?/-" 
   22.90 +
   22.91 +fun is_sym c =
   22.92 +  Symbol.is_ascii_letter c orelse
   22.93 +  Symbol.is_ascii_digit c orelse
   22.94 +  member (op =) symbol_chars c
   22.95 +
   22.96 +fun read_sym f l cs = read_raw is_sym l cs |>> f o implode
   22.97 +
   22.98 +
   22.99 +(* quoted tokens *)
  22.100 +
  22.101 +fun read_quoted stop (escape, replacement) cs =
  22.102 +  let
  22.103 +    fun read _ [] = NONE
  22.104 +      | read rs (cs as (c :: cs')) =
  22.105 +          if is_prefix (op =) stop cs then
  22.106 +            SOME (implode (rev rs), drop (length stop) cs)
  22.107 +          else if not (null escape) andalso is_prefix (op =) escape cs then
  22.108 +            read (replacement :: rs) (drop (length escape) cs)
  22.109 +          else read (c :: rs) cs'
  22.110 +  in read [] cs end
  22.111 +
  22.112 +fun read_string cs = read_quoted ["\\", "\""] (["\\", "\\"], "\\") cs
  22.113 +fun read_symbol cs = read_quoted ["|"] ([], "") cs
  22.114 +
  22.115 +
  22.116 +(* core parser *)
  22.117 +
  22.118 +fun read _ [] rest tss = (rest, tss)
  22.119 +  | read l ("(" :: cs) None tss = read l cs None ([] :: tss)
  22.120 +  | read l (")" :: cs) None (ts1 :: ts2 :: tss) =
  22.121 +      read l cs None ((S (rev ts1) :: ts2) :: tss)
  22.122 +  | read l ("#" :: "x" :: cs) None (ts :: tss) =
  22.123 +      token read_hex l cs ts tss
  22.124 +  | read l ("#" :: "b" :: cs) None (ts :: tss) =
  22.125 +      token read_bin l cs ts tss
  22.126 +  | read l (":" :: cs) None (ts :: tss) =
  22.127 +      token (read_sym Key) l cs ts tss
  22.128 +  | read l ("\"" :: cs) None (ts :: tss) =
  22.129 +      quoted read_string String Str l "" cs ts tss
  22.130 +  | read l ("|" :: cs) None (ts :: tss) =
  22.131 +      quoted read_symbol Symbol Sym l "" cs ts tss
  22.132 +  | read l ((c as "!") :: cs) None (ts :: tss) =
  22.133 +      token (fn _ => pair (Sym c)) l cs ts tss
  22.134 +  | read l (c :: cs) None (ts :: tss) =
  22.135 +      if Symbol.is_ascii_blank c then read l cs None (ts :: tss)
  22.136 +      else if Symbol.is_digit c then token read_num l (c :: cs) ts tss
  22.137 +      else token (read_sym Sym) l (c :: cs) ts tss
  22.138 +  | read l cs (String s) (ts :: tss) =
  22.139 +      quoted read_string String Str l s cs ts tss
  22.140 +  | read l cs (Symbol s) (ts :: tss) =
  22.141 +      quoted read_symbol Symbol Sym l s cs ts tss
  22.142 +  | read l _ _ [] = raise PARSE (l, "bad parser state")
  22.143 +
  22.144 +and token f l cs ts tss =
  22.145 +  let val (t, cs') = f l cs
  22.146 +  in read l cs' None ((t :: ts) :: tss) end
  22.147 +
  22.148 +and quoted r f g l s cs ts tss =
  22.149 +  (case r cs of
  22.150 +    NONE => (f (s ^ implode cs), ts :: tss)
  22.151 +  | SOME (s', cs') => read l cs' None ((g (s ^ s') :: ts) :: tss))
  22.152 +  
  22.153 +
  22.154 +
  22.155 +(* overall parser *)
  22.156 +
  22.157 +fun read_line l line = read l (raw_explode line)
  22.158 +
  22.159 +fun add_line line (l, (None, tss)) =
  22.160 +      if size line = 0 orelse nth_string line 0 = ";" then (l + 1, (None, tss))
  22.161 +      else (l + 1, read_line l line None tss)
  22.162 +  | add_line line (l, (unfinished, tss)) =
  22.163 +      (l + 1, read_line l line unfinished tss)
  22.164 +
  22.165 +fun finish (_, (None, [[t]])) = t
  22.166 +  | finish (l, _) = raise PARSE (l, "bad nesting")
  22.167 +
  22.168 +fun parse lines = finish (fold add_line lines (1, (None, [[]])))
  22.169 +
  22.170 +
  22.171 +(* pretty printer *)
  22.172 +
  22.173 +fun pretty_tree (Num i) = Pretty.str (string_of_int i)
  22.174 +  | pretty_tree (Dec (i, j)) =
  22.175 +      Pretty.str (string_of_int i ^ "." ^ string_of_int j)
  22.176 +  | pretty_tree (Str s) =
  22.177 +      raw_explode s
  22.178 +      |> maps (fn "\"" => ["\\", "\""] | "\\" => ["\\", "\\"] | c => [c])
  22.179 +      |> implode
  22.180 +      |> enclose "\"" "\""
  22.181 +      |> Pretty.str
  22.182 +  | pretty_tree (Sym s) =
  22.183 +      if String.isPrefix "(" s (* for bit vector functions *) orelse
  22.184 +         forall is_sym (raw_explode s) then
  22.185 +        Pretty.str s
  22.186 +      else
  22.187 +        Pretty.str ("|" ^ s ^ "|")
  22.188 +  | pretty_tree (Key s) = Pretty.str (":" ^ s)
  22.189 +  | pretty_tree (S trees) =
  22.190 +      Pretty.enclose "(" ")" (Pretty.separate "" (map pretty_tree trees))
  22.191 +
  22.192 +val str_of = Pretty.str_of o pretty_tree
  22.193 +
  22.194 +end;
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Tools/SMT/smtlib_interface.ML	Thu Aug 28 00:40:38 2014 +0200
    23.3 @@ -0,0 +1,163 @@
    23.4 +(*  Title:      HOL/Tools/SMT/smtlib_interface.ML
    23.5 +    Author:     Sascha Boehme, TU Muenchen
    23.6 +    Author:     Jasmin Blanchette, TU Muenchen
    23.7 +
    23.8 +Interface to SMT solvers based on the SMT-LIB 2 format.
    23.9 +*)
   23.10 +
   23.11 +signature SMTLIB_INTERFACE =
   23.12 +sig
   23.13 +  val smtlibC: SMT_Util.class
   23.14 +  val add_logic: int * (term list -> string option) -> Context.generic -> Context.generic
   23.15 +  val translate_config: Proof.context -> SMT_Translate.config
   23.16 +  val assert_index_of_name: string -> int
   23.17 +  val assert_prefix : string
   23.18 +end;
   23.19 +
   23.20 +structure SMTLIB_Interface: SMTLIB_INTERFACE =
   23.21 +struct
   23.22 +
   23.23 +val smtlibC = ["smtlib"]
   23.24 +
   23.25 +
   23.26 +(* builtins *)
   23.27 +
   23.28 +local
   23.29 +  fun int_num _ i = SOME (string_of_int i)
   23.30 +
   23.31 +  fun is_linear [t] = SMT_Util.is_number t
   23.32 +    | is_linear [t, u] = SMT_Util.is_number t orelse SMT_Util.is_number u
   23.33 +    | is_linear _ = false
   23.34 +
   23.35 +  fun times _ _ ts =
   23.36 +    let val mk = Term.list_comb o pair @{const times (int)}
   23.37 +    in if is_linear ts then SOME ("*", 2, ts, mk) else NONE end
   23.38 +in
   23.39 +
   23.40 +val setup_builtins =
   23.41 +  fold (SMT_Builtin.add_builtin_typ smtlibC) [
   23.42 +    (@{typ bool}, K (SOME "Bool"), K (K NONE)),
   23.43 +    (@{typ int}, K (SOME "Int"), int_num)] #>
   23.44 +  fold (SMT_Builtin.add_builtin_fun' smtlibC) [
   23.45 +    (@{const True}, "true"),
   23.46 +    (@{const False}, "false"),
   23.47 +    (@{const Not}, "not"),
   23.48 +    (@{const HOL.conj}, "and"),
   23.49 +    (@{const HOL.disj}, "or"),
   23.50 +    (@{const HOL.implies}, "=>"),
   23.51 +    (@{const HOL.eq ('a)}, "="),
   23.52 +    (@{const If ('a)}, "ite"),
   23.53 +    (@{const less (int)}, "<"),
   23.54 +    (@{const less_eq (int)}, "<="),
   23.55 +    (@{const uminus (int)}, "-"),
   23.56 +    (@{const plus (int)}, "+"),
   23.57 +    (@{const minus (int)}, "-")] #>
   23.58 +  SMT_Builtin.add_builtin_fun smtlibC
   23.59 +    (Term.dest_Const @{const times (int)}, times)
   23.60 +
   23.61 +end
   23.62 +
   23.63 +
   23.64 +(* serialization *)
   23.65 +
   23.66 +(** logic **)
   23.67 +
   23.68 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
   23.69 +
   23.70 +structure Logics = Generic_Data
   23.71 +(
   23.72 +  type T = (int * (term list -> string option)) list
   23.73 +  val empty = []
   23.74 +  val extend = I
   23.75 +  fun merge data = Ord_List.merge fst_int_ord data
   23.76 +)
   23.77 +
   23.78 +fun add_logic pf = Logics.map (Ord_List.insert fst_int_ord pf)
   23.79 +
   23.80 +fun choose_logic ctxt ts =
   23.81 +  let
   23.82 +    fun choose [] = "AUFLIA"
   23.83 +      | choose ((_, f) :: fs) = (case f ts of SOME s => s | NONE => choose fs)
   23.84 +  in
   23.85 +    (case choose (Logics.get (Context.Proof ctxt)) of
   23.86 +      "" => "" (* for default Z3 logic, a subset of everything *)
   23.87 +    | logic => "(set-logic " ^ logic ^ ")\n")
   23.88 +  end
   23.89 +
   23.90 +
   23.91 +(** serialization **)
   23.92 +
   23.93 +fun var i = "?v" ^ string_of_int i
   23.94 +
   23.95 +fun tree_of_sterm l (SMT_Translate.SVar i) = SMTLIB.Sym (var (l - i - 1))
   23.96 +  | tree_of_sterm _ (SMT_Translate.SApp (n, [])) = SMTLIB.Sym n
   23.97 +  | tree_of_sterm l (SMT_Translate.SApp (n, ts)) =
   23.98 +      SMTLIB.S (SMTLIB.Sym n :: map (tree_of_sterm l) ts)
   23.99 +  | tree_of_sterm _ (SMT_Translate.SLet _) =
  23.100 +      raise Fail "SMT-LIB: unsupported let expression"
  23.101 +  | tree_of_sterm l (SMT_Translate.SQua (q, ss, pats, t)) =
  23.102 +      let
  23.103 +        val l' = l + length ss
  23.104 +
  23.105 +        fun quant_name SMT_Translate.SForall = "forall"
  23.106 +          | quant_name SMT_Translate.SExists = "exists"
  23.107 +
  23.108 +        fun gen_trees_of_pat keyword ps =
  23.109 +          [SMTLIB.Key keyword, (case map (tree_of_sterm l') ps of [t] => t | ts => SMTLIB.S ts)]
  23.110 +        fun trees_of_pat (SMT_Translate.SPat ps) = gen_trees_of_pat "pattern" ps
  23.111 +          | trees_of_pat (SMT_Translate.SNoPat ps) = gen_trees_of_pat "no-pattern" ps
  23.112 +        fun tree_of_pats [] t = t
  23.113 +          | tree_of_pats pats t = SMTLIB.S (SMTLIB.Sym "!" :: t :: maps trees_of_pat pats)
  23.114 +
  23.115 +        val vs = map_index (fn (i, ty) =>
  23.116 +          SMTLIB.S [SMTLIB.Sym (var (l + i)), SMTLIB.Sym ty]) ss
  23.117 +
  23.118 +        val body = t
  23.119 +          |> tree_of_sterm l'
  23.120 +          |> tree_of_pats pats
  23.121 +      in
  23.122 +        SMTLIB.S [SMTLIB.Sym (quant_name q), SMTLIB.S vs, body]
  23.123 +      end
  23.124 +
  23.125 +
  23.126 +fun sctrarg (sel, typ) = "(" ^ sel ^ " " ^ typ ^ ")"
  23.127 +fun sctr (name, args) = enclose "(" ")" (space_implode " " (name :: map sctrarg args))
  23.128 +fun sdatatype (name, ctrs) = enclose "(" ")" (space_implode " " (name :: map sctr ctrs))
  23.129 +
  23.130 +fun string_of_fun (f, (ss, s)) = f ^ " (" ^ space_implode " " ss ^ ") " ^ s
  23.131 +
  23.132 +fun named_sterm s t = SMTLIB.S [SMTLIB.Sym "!", t, SMTLIB.Key "named", SMTLIB.Sym s]
  23.133 +
  23.134 +val assert_prefix = "a"
  23.135 +
  23.136 +fun assert_name_of_index i = assert_prefix ^ string_of_int i
  23.137 +fun assert_index_of_name s = the_default ~1 (Int.fromString (unprefix assert_prefix s))
  23.138 +
  23.139 +fun serialize smt_options comments {logic, sorts, dtyps, funcs} ts =
  23.140 +  Buffer.empty
  23.141 +  |> fold (Buffer.add o enclose "; " "\n") comments
  23.142 +  |> fold (fn (k, v) => Buffer.add ("(set-option " ^ k ^ " " ^ v ^ ")\n")) smt_options
  23.143 +  |> Buffer.add logic
  23.144 +  |> fold (Buffer.add o enclose "(declare-sort " " 0)\n") (sort fast_string_ord sorts)
  23.145 +  |> (if null dtyps then I
  23.146 +    else Buffer.add (enclose "(declare-datatypes () (" "))\n"
  23.147 +      (space_implode "\n  " (maps (map sdatatype) dtyps))))
  23.148 +  |> fold (Buffer.add o enclose "(declare-fun " ")\n" o string_of_fun)
  23.149 +      (sort (fast_string_ord o pairself fst) funcs)
  23.150 +  |> fold (fn (i, t) => Buffer.add (enclose "(assert " ")\n"
  23.151 +      (SMTLIB.str_of (named_sterm (assert_name_of_index i) (tree_of_sterm 0 t))))) (map_index I ts)
  23.152 +  |> Buffer.add "(check-sat)\n(get-proof)\n"
  23.153 +  |> Buffer.content
  23.154 +
  23.155 +(* interface *)
  23.156 +
  23.157 +fun translate_config ctxt = {
  23.158 +  logic = choose_logic ctxt,
  23.159 +  has_datatypes = false,
  23.160 +  serialize = serialize}
  23.161 +
  23.162 +val _ = Theory.setup (Context.theory_map
  23.163 +  (setup_builtins #>
  23.164 +   SMT_Translate.add_config (smtlibC, translate_config)))
  23.165 +
  23.166 +end;
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Tools/SMT/smtlib_isar.ML	Thu Aug 28 00:40:38 2014 +0200
    24.3 @@ -0,0 +1,71 @@
    24.4 +(*  Title:      HOL/Tools/SMT/smtlib_isar.ML
    24.5 +    Author:     Jasmin Blanchette, TU Muenchen
    24.6 +    Author:     Mathias Fleury, ENS Rennes
    24.7 +
    24.8 +General tools for Isar proof reconstruction.
    24.9 +*)
   24.10 +
   24.11 +signature SMTLIB_ISAR =
   24.12 +sig
   24.13 +  val unlift_term: term list -> term -> term
   24.14 +  val postprocess_step_conclusion: theory -> thm list -> term list -> term -> term
   24.15 +  val normalizing_prems : Proof.context -> term -> (string * string list) list
   24.16 +  val distinguish_conjecture_and_hypothesis : ''a list -> ''b -> ''b -> ''b list ->
   24.17 +    (''a * 'c) list -> 'c list -> 'c -> (ATP_Problem.atp_formula_role * 'c) option
   24.18 +  val unskolemize_names: term -> term
   24.19 +end;
   24.20 +
   24.21 +structure SMTLIB_Isar: SMTLIB_ISAR =
   24.22 +struct
   24.23 +
   24.24 +open ATP_Util
   24.25 +open ATP_Problem
   24.26 +open ATP_Proof_Reconstruct
   24.27 +
   24.28 +fun unlift_term ll_defs =
   24.29 +  let
   24.30 +    val lifted = map (ATP_Util.extract_lambda_def dest_Free o ATP_Util.hol_open_form I) ll_defs
   24.31 +
   24.32 +    fun un_free (t as Free (s, _)) =
   24.33 +       (case AList.lookup (op =) lifted s of
   24.34 +         SOME t => un_term t
   24.35 +       | NONE => t)
   24.36 +     | un_free t = t
   24.37 +    and un_term t = map_aterms un_free t
   24.38 +  in un_term end
   24.39 +
   24.40 +(* It is not entirely clear why this should be necessary, especially for abstractions variables. *)
   24.41 +val unskolemize_names =
   24.42 +  Term.map_abs_vars (perhaps (try Name.dest_skolem))
   24.43 +  #> Term.map_aterms (perhaps (try (fn Free (s, T) => Free (Name.dest_skolem s, T))))
   24.44 +
   24.45 +fun postprocess_step_conclusion thy rewrite_rules ll_defs =
   24.46 +  Raw_Simplifier.rewrite_term thy rewrite_rules []
   24.47 +  #> Object_Logic.atomize_term thy
   24.48 +  #> not (null ll_defs) ? unlift_term ll_defs
   24.49 +  #> simplify_bool
   24.50 +  #> unskolemize_names
   24.51 +  #> HOLogic.mk_Trueprop
   24.52 +
   24.53 +fun normalizing_prems ctxt concl0 =
   24.54 +  SMT_Normalize.case_bool_entry :: SMT_Normalize.special_quant_table @
   24.55 +  SMT_Normalize.abs_min_max_table
   24.56 +  |> map_filter (fn (c, th) =>
   24.57 +    if exists_Const (curry (op =) c o fst) concl0 then
   24.58 +      let val s = short_thm_name ctxt th in SOME (s, [s]) end
   24.59 +    else
   24.60 +      NONE)
   24.61 +
   24.62 +fun distinguish_conjecture_and_hypothesis ss id conjecture_id prem_ids fact_helper_ts hyp_ts
   24.63 +    concl_t =
   24.64 +  (case ss of
   24.65 +    [s] => SOME (Axiom, the (AList.lookup (op =) fact_helper_ts s))
   24.66 +  | _ =>
   24.67 +    if id = conjecture_id then
   24.68 +      SOME (Conjecture, concl_t)
   24.69 +    else
   24.70 +     (case find_index (curry (op =) id) prem_ids of
   24.71 +       ~1 => NONE (* lambda-lifting definition *)
   24.72 +     | i => SOME (Hypothesis, nth hyp_ts i)))
   24.73 +
   24.74 +end;
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/Tools/SMT/smtlib_proof.ML	Thu Aug 28 00:40:38 2014 +0200
    25.3 @@ -0,0 +1,298 @@
    25.4 +(*  Title:      HOL/Tools/SMT/smtlib_proof.ML
    25.5 +    Author:     Sascha Boehme, TU Muenchen
    25.6 +    Author:     Mathias Fleury, ENS Rennes
    25.7 +    Author:     Jasmin Blanchette, TU Muenchen
    25.8 +
    25.9 +SMT-LIB-2-style proofs: parsing and abstract syntax tree.
   25.10 +*)
   25.11 +
   25.12 +signature SMTLIB_PROOF =
   25.13 +sig
   25.14 +  datatype 'b shared = Tree of SMTLIB.tree | Term of term | Proof of 'b | None
   25.15 +  type ('a, 'b) context
   25.16 +
   25.17 +  val mk_context: Proof.context -> int -> 'b shared Symtab.table -> typ Symtab.table ->
   25.18 +    term Symtab.table -> 'a -> ('a, 'b) context
   25.19 +  val empty_context: Proof.context -> typ Symtab.table -> term Symtab.table -> ('a list, 'b) context
   25.20 +  val ctxt_of: ('a, 'b) context -> Proof.context
   25.21 +  val lookup_binding: ('a, 'b) context -> string -> 'b shared
   25.22 +  val update_binding: string * 'b shared -> ('a, 'b) context -> ('a, 'b) context
   25.23 +  val with_bindings: (string * 'b shared) list -> (('a, 'b) context -> 'c * ('d, 'b) context) ->
   25.24 +    ('a, 'b) context -> 'c * ('d, 'b) context
   25.25 +  val next_id: ('a, 'b) context -> int * ('a, 'b) context
   25.26 +  val with_fresh_names: (('a list, 'b) context ->
   25.27 +    term * ((string * (string * typ)) list, 'b) context) -> ('c, 'b) context -> (term * string list)
   25.28 +
   25.29 +  (*type and term parsers*)
   25.30 +  type type_parser = SMTLIB.tree * typ list -> typ option
   25.31 +  type term_parser = SMTLIB.tree * term list -> term option
   25.32 +  val add_type_parser: type_parser -> Context.generic -> Context.generic
   25.33 +  val add_term_parser: term_parser -> Context.generic -> Context.generic
   25.34 +
   25.35 +  exception SMTLIB_PARSE of string * SMTLIB.tree
   25.36 +
   25.37 +  val declare_fun: string -> typ -> ((string * typ) list, 'a) context ->
   25.38 +    ((string * typ) list, 'a) context
   25.39 +  val dest_binding: SMTLIB.tree -> string * 'a shared
   25.40 +  val type_of: ('a, 'b) context -> SMTLIB.tree -> typ
   25.41 +  val term_of: SMTLIB.tree -> ((string * (string * typ)) list, 'a) context ->
   25.42 +    term * ((string * (string * typ)) list, 'a) context
   25.43 +end;
   25.44 +
   25.45 +structure SMTLIB_Proof: SMTLIB_PROOF =
   25.46 +struct
   25.47 +
   25.48 +(* proof parser context *)
   25.49 +
   25.50 +datatype 'b shared = Tree of SMTLIB.tree | Term of term | Proof of 'b | None
   25.51 +
   25.52 +type ('a, 'b) context = {
   25.53 +  ctxt: Proof.context,
   25.54 +  id: int,
   25.55 +  syms: 'b shared Symtab.table,
   25.56 +  typs: typ Symtab.table,
   25.57 +  funs: term Symtab.table,
   25.58 +  extra: 'a}
   25.59 +
   25.60 +fun mk_context ctxt id syms typs funs extra: ('a, 'b) context =
   25.61 +  {ctxt = ctxt, id = id, syms = syms, typs = typs, funs = funs, extra = extra}
   25.62 +
   25.63 +fun empty_context ctxt typs funs = mk_context ctxt 1 Symtab.empty typs funs []
   25.64 +
   25.65 +fun ctxt_of ({ctxt, ...}: ('a, 'b) context) = ctxt
   25.66 +
   25.67 +fun lookup_binding ({syms, ...}: ('a, 'b) context) =
   25.68 +  the_default None o Symtab.lookup syms
   25.69 +
   25.70 +fun map_syms f ({ctxt, id, syms, typs, funs, extra}: ('a, 'b) context) =
   25.71 +  mk_context ctxt id (f syms) typs funs extra
   25.72 +
   25.73 +fun update_binding b = map_syms (Symtab.update b)
   25.74 +
   25.75 +fun with_bindings bs f cx =
   25.76 +  let val bs' = map (lookup_binding cx o fst) bs
   25.77 +  in
   25.78 +    cx
   25.79 +    |> fold update_binding bs
   25.80 +    |> f
   25.81 +    ||> fold2 (fn (name, _) => update_binding o pair name) bs bs'
   25.82 +  end
   25.83 +
   25.84 +fun next_id ({ctxt, id, syms, typs, funs, extra}: ('a, 'b) context) =
   25.85 +  (id, mk_context ctxt (id + 1) syms typs funs extra)
   25.86 +
   25.87 +fun with_fresh_names f ({ctxt, id, syms, typs, funs, ...}: ('a, 'b) context) =
   25.88 +  let
   25.89 +    fun bind (_, v as (_, T)) t = Logic.all_const T $ Term.absfree v t
   25.90 +
   25.91 +    val needs_inferT = equal Term.dummyT orf Term.is_TVar
   25.92 +    val needs_infer = Term.exists_type (Term.exists_subtype needs_inferT)
   25.93 +    fun infer_types ctxt =
   25.94 +      singleton (Type_Infer_Context.infer_types ctxt) #>
   25.95 +      singleton (Proof_Context.standard_term_check_finish ctxt)
   25.96 +    fun infer ctxt t = if needs_infer t then infer_types ctxt t else t
   25.97 +
   25.98 +    val (t, {ctxt = ctxt', extra = names, ...}: ((string * (string * typ)) list, 'b) context) =
   25.99 +      f (mk_context ctxt id syms typs funs [])
  25.100 +    val t' = infer ctxt' (fold_rev bind names (HOLogic.mk_Trueprop t))
  25.101 +  in
  25.102 +    (t', map fst names)
  25.103 +  end
  25.104 +
  25.105 +fun lookup_typ ({typs, ...}: ('a, 'b) context) = Symtab.lookup typs
  25.106 +fun lookup_fun ({funs, ...}: ('a, 'b) context) = Symtab.lookup funs
  25.107 +
  25.108 +
  25.109 +(* core type and term parser *)
  25.110 +
  25.111 +fun core_type_parser (SMTLIB.Sym "Bool", []) = SOME @{typ HOL.bool}
  25.112 +  | core_type_parser (SMTLIB.Sym "Int", []) = SOME @{typ Int.int}
  25.113 +  | core_type_parser _ = NONE
  25.114 +
  25.115 +fun mk_unary n t =
  25.116 +  let val T = fastype_of t
  25.117 +  in Const (n, T --> T) $ t end
  25.118 +
  25.119 +fun mk_binary' n T U t1 t2 = Const (n, [T, T] ---> U) $ t1 $ t2
  25.120 +
  25.121 +fun mk_binary n t1 t2 =
  25.122 +  let val T = fastype_of t1
  25.123 +  in mk_binary' n T T t1 t2 end
  25.124 +
  25.125 +fun mk_rassoc f t ts =
  25.126 +  let val us = rev (t :: ts)
  25.127 +  in fold f (tl us) (hd us) end
  25.128 +
  25.129 +fun mk_lassoc f t ts = fold (fn u1 => fn u2 => f u2 u1) ts t
  25.130 +
  25.131 +fun mk_lassoc' n = mk_lassoc (mk_binary n)
  25.132 +
  25.133 +fun mk_binary_pred n S t1 t2 =
  25.134 +  let
  25.135 +    val T1 = fastype_of t1
  25.136 +    val T2 = fastype_of t2
  25.137 +    val T =
  25.138 +      if T1 <> Term.dummyT then T1
  25.139 +      else if T2 <> Term.dummyT then T2
  25.140 +      else TVar (("?a", serial ()), S)
  25.141 +  in mk_binary' n T @{typ HOL.bool} t1 t2 end
  25.142 +
  25.143 +fun mk_less t1 t2 = mk_binary_pred @{const_name ord_class.less} @{sort linorder} t1 t2
  25.144 +fun mk_less_eq t1 t2 = mk_binary_pred @{const_name ord_class.less_eq} @{sort linorder} t1 t2
  25.145 +
  25.146 +fun core_term_parser (SMTLIB.Sym "true", _) = SOME @{const HOL.True}
  25.147 +  | core_term_parser (SMTLIB.Sym "false", _) = SOME @{const HOL.False}
  25.148 +  | core_term_parser (SMTLIB.Sym "not", [t]) = SOME (HOLogic.mk_not t)
  25.149 +  | core_term_parser (SMTLIB.Sym "and", t :: ts) = SOME (mk_rassoc (curry HOLogic.mk_conj) t ts)
  25.150 +  | core_term_parser (SMTLIB.Sym "or", t :: ts) = SOME (mk_rassoc (curry HOLogic.mk_disj) t ts)
  25.151 +  | core_term_parser (SMTLIB.Sym "=>", [t1, t2]) = SOME (HOLogic.mk_imp (t1, t2))
  25.152 +  | core_term_parser (SMTLIB.Sym "implies", [t1, t2]) = SOME (HOLogic.mk_imp (t1, t2))
  25.153 +  | core_term_parser (SMTLIB.Sym "=", [t1, t2]) = SOME (HOLogic.mk_eq (t1, t2))
  25.154 +  | core_term_parser (SMTLIB.Sym "~", [t1, t2]) = SOME (HOLogic.mk_eq (t1, t2))
  25.155 +  | core_term_parser (SMTLIB.Sym "ite", [t1, t2, t3]) =
  25.156 +      let
  25.157 +        val T = fastype_of t2
  25.158 +        val c = Const (@{const_name HOL.If}, [@{typ HOL.bool}, T, T] ---> T)
  25.159 +      in SOME (c $ t1 $ t2 $ t3) end
  25.160 +  | core_term_parser (SMTLIB.Num i, []) = SOME (HOLogic.mk_number @{typ Int.int} i)
  25.161 +  | core_term_parser (SMTLIB.Sym "-", [t]) = SOME (mk_unary @{const_name uminus_class.uminus} t)
  25.162 +  | core_term_parser (SMTLIB.Sym "~", [t]) = SOME (mk_unary @{const_name uminus_class.uminus} t)
  25.163 +  | core_term_parser (SMTLIB.Sym "+", t :: ts) =
  25.164 +      SOME (mk_lassoc' @{const_name plus_class.plus} t ts)
  25.165 +  | core_term_parser (SMTLIB.Sym "-", t :: ts) =
  25.166 +      SOME (mk_lassoc' @{const_name minus_class.minus} t ts)
  25.167 +  | core_term_parser (SMTLIB.Sym "*", t :: ts) =
  25.168 +      SOME (mk_lassoc' @{const_name times_class.times} t ts)
  25.169 +  | core_term_parser (SMTLIB.Sym "div", [t1, t2]) = SOME (mk_binary @{const_name z3div} t1 t2)
  25.170 +  | core_term_parser (SMTLIB.Sym "mod", [t1, t2]) = SOME (mk_binary @{const_name z3mod} t1 t2)
  25.171 +  | core_term_parser (SMTLIB.Sym "<", [t1, t2]) = SOME (mk_less t1 t2)
  25.172 +  | core_term_parser (SMTLIB.Sym ">", [t1, t2]) = SOME (mk_less t2 t1)
  25.173 +  | core_term_parser (SMTLIB.Sym "<=", [t1, t2]) = SOME (mk_less_eq t1 t2)
  25.174 +  | core_term_parser (SMTLIB.Sym ">=", [t1, t2]) = SOME (mk_less_eq t2 t1)
  25.175 +  | core_term_parser _ = NONE
  25.176 +
  25.177 +
  25.178 +(* custom type and term parsers *)
  25.179 +
  25.180 +type type_parser = SMTLIB.tree * typ list -> typ option
  25.181 +
  25.182 +type term_parser = SMTLIB.tree * term list -> term option
  25.183 +
  25.184 +fun id_ord ((id1, _), (id2, _)) = int_ord (id1, id2)
  25.185 +
  25.186 +structure Parsers = Generic_Data
  25.187 +(
  25.188 +  type T = (int * type_parser) list * (int * term_parser) list
  25.189 +  val empty : T = ([(serial (), core_type_parser)], [(serial (), core_term_parser)])
  25.190 +  val extend = I
  25.191 +  fun merge ((tys1, ts1), (tys2, ts2)) =
  25.192 +    (Ord_List.merge id_ord (tys1, tys2), Ord_List.merge id_ord (ts1, ts2))
  25.193 +)
  25.194 +
  25.195 +fun add_type_parser type_parser =
  25.196 +  Parsers.map (apfst (Ord_List.insert id_ord (serial (), type_parser)))
  25.197 +
  25.198 +fun add_term_parser term_parser =
  25.199 +  Parsers.map (apsnd (Ord_List.insert id_ord (serial (), term_parser)))
  25.200 +
  25.201 +fun get_type_parsers ctxt = map snd (fst (Parsers.get (Context.Proof ctxt)))
  25.202 +fun get_term_parsers ctxt = map snd (snd (Parsers.get (Context.Proof ctxt)))
  25.203 +
  25.204 +fun apply_parsers parsers x =
  25.205 +  let
  25.206 +    fun apply [] = NONE
  25.207 +      | apply (parser :: parsers) =
  25.208 +          (case parser x of
  25.209 +            SOME y => SOME y
  25.210 +          | NONE => apply parsers)
  25.211 +  in apply parsers end
  25.212 +
  25.213 +
  25.214 +(* type and term parsing *)
  25.215 +
  25.216 +exception SMTLIB_PARSE of string * SMTLIB.tree
  25.217 +
  25.218 +val desymbolize = Name.desymbolize (SOME false) o perhaps (try (unprefix "?"))
  25.219 +
  25.220 +fun fresh_fun add name n T ({ctxt, id, syms, typs, funs, extra}: ('a, 'b) context) =
  25.221 +  let
  25.222 +    val (n', ctxt') = yield_singleton Variable.variant_fixes n ctxt
  25.223 +    val t = Free (n', T)
  25.224 +    val funs' = Symtab.update (name, t) funs
  25.225 +  in (t, mk_context ctxt' id syms typs funs' (add (n', T) extra)) end
  25.226 +
  25.227 +fun declare_fun name = snd oo fresh_fun cons name (desymbolize name)
  25.228 +fun declare_free name = fresh_fun (cons o pair name) name (desymbolize name)
  25.229 +
  25.230 +fun parse_type cx ty Ts =
  25.231 +  (case apply_parsers (get_type_parsers (ctxt_of cx)) (ty, Ts) of
  25.232 +    SOME T => T
  25.233 +  | NONE =>
  25.234 +      (case ty of
  25.235 +        SMTLIB.Sym name =>
  25.236 +          (case lookup_typ cx name of
  25.237 +            SOME T => T
  25.238 +          | NONE => raise SMTLIB_PARSE ("unknown SMT type", ty))
  25.239 +      | _ => raise SMTLIB_PARSE ("bad SMT type format", ty)))
  25.240 +
  25.241 +fun parse_term t ts cx =
  25.242 +  (case apply_parsers (get_term_parsers (ctxt_of cx)) (t, ts) of
  25.243 +    SOME u => (u, cx)
  25.244 +  | NONE =>
  25.245 +      (case t of
  25.246 +        SMTLIB.Sym name =>
  25.247 +          (case lookup_fun cx name of
  25.248 +            SOME u => (Term.list_comb (u, ts), cx)
  25.249 +          | NONE =>
  25.250 +              if null ts then declare_free name Term.dummyT cx
  25.251 +              else raise SMTLIB_PARSE ("bad SMT term", t))
  25.252 +      | _ => raise SMTLIB_PARSE ("bad SMT term format", t)))
  25.253 +
  25.254 +fun type_of cx ty =
  25.255 +  (case try (parse_type cx ty) [] of
  25.256 +    SOME T => T
  25.257 +  | NONE =>
  25.258 +      (case ty of
  25.259 +        SMTLIB.S (ty' :: tys) => parse_type cx ty' (map (type_of cx) tys)
  25.260 +      | _ => raise SMTLIB_PARSE ("bad SMT type", ty)))
  25.261 +
  25.262 +fun dest_var cx (SMTLIB.S [SMTLIB.Sym name, ty]) = (name, (desymbolize name, type_of cx ty))
  25.263 +  | dest_var _ v = raise SMTLIB_PARSE ("bad SMT quantifier variable format", v)
  25.264 +
  25.265 +fun dest_body (SMTLIB.S (SMTLIB.Sym "!" :: body :: _)) = dest_body body
  25.266 +  | dest_body body = body
  25.267 +
  25.268 +fun dest_binding (SMTLIB.S [SMTLIB.Sym name, t]) = (name, Tree t)
  25.269 +  | dest_binding b = raise SMTLIB_PARSE ("bad SMT let binding format", b)
  25.270 +
  25.271 +fun term_of t cx =
  25.272 +  (case t of
  25.273 +    SMTLIB.S [SMTLIB.Sym "forall", SMTLIB.S vars, body] => quant HOLogic.mk_all vars body cx
  25.274 +  | SMTLIB.S [SMTLIB.Sym "exists", SMTLIB.S vars, body] => quant HOLogic.mk_exists vars body cx
  25.275 +  | SMTLIB.S [SMTLIB.Sym "let", SMTLIB.S bindings, body] =>
  25.276 +      with_bindings (map dest_binding bindings) (term_of body) cx
  25.277 +  | SMTLIB.S (SMTLIB.Sym "!" :: t :: _) => term_of t cx
  25.278 +  | SMTLIB.S (f :: args) =>
  25.279 +      cx
  25.280 +      |> fold_map term_of args
  25.281 +      |-> parse_term f
  25.282 +  | SMTLIB.Sym name =>
  25.283 +      (case lookup_binding cx name of
  25.284 +        Tree u =>
  25.285 +          cx
  25.286 +          |> term_of u
  25.287 +          |-> (fn u' => pair u' o update_binding (name, Term u'))
  25.288 +      | Term u => (u, cx)
  25.289 +      | None => parse_term t [] cx
  25.290 +      | _ => raise SMTLIB_PARSE ("bad SMT term format", t))
  25.291 +  | _ => parse_term t [] cx)
  25.292 +
  25.293 +and quant q vars body cx =
  25.294 +  let val vs = map (dest_var cx) vars
  25.295 +  in
  25.296 +    cx
  25.297 +    |> with_bindings (map (apsnd (Term o Free)) vs) (term_of (dest_body body))
  25.298 +    |>> fold_rev (fn (_, (n, T)) => fn t => q (n, T, t)) vs
  25.299 +  end
  25.300 +
  25.301 +end;
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/Tools/SMT/verit_isar.ML	Thu Aug 28 00:40:38 2014 +0200
    26.3 @@ -0,0 +1,59 @@
    26.4 +(*  Title:      HOL/Tools/SMT/verit_isar.ML
    26.5 +    Author:     Mathias Fleury, TU Muenchen
    26.6 +    Author:     Jasmin Blanchette, TU Muenchen
    26.7 +
    26.8 +VeriT proofs as generic ATP proofs for Isar proof reconstruction.
    26.9 +*)
   26.10 +
   26.11 +signature VERIT_ISAR =
   26.12 +sig
   26.13 +  type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step
   26.14 +  val atp_proof_of_veriT_proof: Proof.context -> term list -> thm list -> term list -> term ->
   26.15 +    (string * term) list -> int list -> int -> (int * string) list -> VeriT_Proof.veriT_step list ->
   26.16 +    (term, string) ATP_Proof.atp_step list
   26.17 +end;
   26.18 +
   26.19 +structure VeriT_Isar: VERIT_ISAR =
   26.20 +struct
   26.21 +
   26.22 +open ATP_Util
   26.23 +open ATP_Problem
   26.24 +open ATP_Proof
   26.25 +open ATP_Proof_Reconstruct
   26.26 +open SMTLIB_Isar
   26.27 +open VeriT_Proof
   26.28 +
   26.29 +fun atp_proof_of_veriT_proof ctxt ll_defs rewrite_rules hyp_ts concl_t fact_helper_ts prem_ids
   26.30 +    conjecture_id fact_helper_ids proof =
   26.31 +  let
   26.32 +    val thy = Proof_Context.theory_of ctxt
   26.33 +    fun steps_of (VeriT_Proof.VeriT_Step {id, rule, prems, concl, ...}) =
   26.34 +      let
   26.35 +        val concl' = postprocess_step_conclusion thy rewrite_rules ll_defs concl
   26.36 +        fun standard_step role = ((id, []), role, concl', rule, map (fn id => (id, [])) prems)
   26.37 +      in
   26.38 +        if rule = veriT_input_rule then
   26.39 +          let val ss = the_list (AList.lookup (op =) fact_helper_ids (the (Int.fromString id))) in
   26.40 +            (case distinguish_conjecture_and_hypothesis ss (the (Int.fromString id))
   26.41 +                conjecture_id prem_ids fact_helper_ts hyp_ts concl_t of
   26.42 +              NONE => []
   26.43 +            | SOME (role0, concl00) =>
   26.44 +              let
   26.45 +                val name0 = (id ^ "a", ss)
   26.46 +                val concl0 = unskolemize_names concl00
   26.47 +              in
   26.48 +                [(name0, role0, concl0, rule, []),
   26.49 +                 ((id, []), Plain, concl', veriT_rewrite_rule,
   26.50 +                  name0 :: normalizing_prems ctxt concl0)]
   26.51 +              end)
   26.52 +          end
   26.53 +        else if rule = veriT_tmp_ite_elim_rule then
   26.54 +          [standard_step Lemma]
   26.55 +        else
   26.56 +          [standard_step Plain]
   26.57 +      end
   26.58 +  in
   26.59 +    maps steps_of proof
   26.60 +  end
   26.61 +
   26.62 +end;
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/HOL/Tools/SMT/verit_proof.ML	Thu Aug 28 00:40:38 2014 +0200
    27.3 @@ -0,0 +1,333 @@
    27.4 +(*  Title:      HOL/Tools/SMT/verit_proof.ML
    27.5 +    Author:     Mathias Fleury, ENS Rennes
    27.6 +    Author:     Sascha Boehme, TU Muenchen
    27.7 +
    27.8 +VeriT proofs: parsing and abstract syntax tree.
    27.9 +*)
   27.10 +
   27.11 +signature VERIT_PROOF =
   27.12 +sig
   27.13 +  (*proofs*)
   27.14 +  datatype veriT_step = VeriT_Step of {
   27.15 +    id: string,
   27.16 +    rule: string,
   27.17 +    prems: string list,
   27.18 +    concl: term,
   27.19 +    fixes: string list}
   27.20 +
   27.21 +  (*proof parser*)
   27.22 +  val parse: typ Symtab.table -> term Symtab.table -> string list ->
   27.23 +    Proof.context -> veriT_step list * Proof.context
   27.24 +
   27.25 +  val veriT_step_prefix : string
   27.26 +  val veriT_input_rule: string
   27.27 +  val veriT_la_generic_rule : string
   27.28 +  val veriT_rewrite_rule : string
   27.29 +  val veriT_simp_arith_rule : string
   27.30 +  val veriT_tmp_ite_elim_rule : string
   27.31 +  val veriT_tmp_skolemize_rule : string
   27.32 +end;
   27.33 +
   27.34 +structure VeriT_Proof: VERIT_PROOF =
   27.35 +struct
   27.36 +
   27.37 +open SMTLIB_Proof
   27.38 +
   27.39 +datatype veriT_node = VeriT_Node of {
   27.40 +  id: string,
   27.41 +  rule: string,
   27.42 +  prems: string list,
   27.43 +  concl: term,
   27.44 +  bounds: string list}
   27.45 +
   27.46 +fun mk_node id rule prems concl bounds =
   27.47 +  VeriT_Node {id = id, rule = rule, prems = prems, concl = concl, bounds = bounds}
   27.48 +
   27.49 +datatype veriT_step = VeriT_Step of {
   27.50 +  id: string,
   27.51 +  rule: string,
   27.52 +  prems: string list,
   27.53 +  concl: term,
   27.54 +  fixes: string list}
   27.55 +
   27.56 +fun mk_step id rule prems concl fixes =
   27.57 +  VeriT_Step {id = id, rule = rule, prems = prems, concl = concl, fixes = fixes}
   27.58 +
   27.59 +val veriT_step_prefix = ".c"
   27.60 +val veriT_alpha_conv_rule = "tmp_alphaconv"
   27.61 +val veriT_input_rule = "input"
   27.62 +val veriT_la_generic_rule = "la_generic"
   27.63 +val veriT_rewrite_rule = "__rewrite" (* arbitrary *)
   27.64 +val veriT_simp_arith_rule = "simp_arith"
   27.65 +val veriT_tmp_ite_elim_rule = "tmp_ite_elim"
   27.66 +val veriT_tmp_skolemize_rule = "tmp_skolemize"
   27.67 +
   27.68 +(* proof parser *)
   27.69 +
   27.70 +fun node_of p cx =
   27.71 +  ([], cx)
   27.72 +  ||>> `(with_fresh_names (term_of p))
   27.73 +  |>> snd
   27.74 +
   27.75 +(*in order to get Z3-style quantification*)
   27.76 +fun repair_quantification (SMTLIB.S (SMTLIB.Sym "forall" :: l)) =
   27.77 +    let val (quantified_vars, t) = split_last (map repair_quantification l)
   27.78 +    in
   27.79 +      SMTLIB.S (SMTLIB.Sym "forall" :: SMTLIB.S quantified_vars :: t :: [])
   27.80 +    end
   27.81 +  | repair_quantification (SMTLIB.S (SMTLIB.Sym "exists" :: l)) =
   27.82 +    let val (quantified_vars, t) = split_last (map repair_quantification l)
   27.83 +    in
   27.84 +      SMTLIB.S (SMTLIB.Sym "exists" :: SMTLIB.S quantified_vars :: t :: [])
   27.85 +    end
   27.86 +  | repair_quantification (SMTLIB.S l) = SMTLIB.S (map repair_quantification l)
   27.87 +  | repair_quantification x = x
   27.88 +
   27.89 +fun replace_bound_var_by_free_var (q $ Abs (var, ty, u)) free_var =
   27.90 +    (case List.find (fn v => String.isPrefix v var) free_var of
   27.91 +      NONE => q $ Abs (var, ty, replace_bound_var_by_free_var u free_var)
   27.92 +    | SOME _ => replace_bound_var_by_free_var (Term.subst_bound (Free (var, ty), u)) free_var)
   27.93 +  | replace_bound_var_by_free_var (u $ v) free_vars = replace_bound_var_by_free_var u free_vars $
   27.94 +     replace_bound_var_by_free_var v free_vars
   27.95 +  | replace_bound_var_by_free_var u _ = u
   27.96 +
   27.97 +fun find_type_in_formula (Abs(v, ty, u)) var_name =
   27.98 +    if String.isPrefix var_name v then SOME ty else find_type_in_formula u var_name
   27.99 +  | find_type_in_formula (u $ v) var_name =
  27.100 +    (case find_type_in_formula u var_name of
  27.101 +      NONE => find_type_in_formula v var_name
  27.102 +    | a => a)
  27.103 +  | find_type_in_formula _ _ = NONE
  27.104 +
  27.105 +fun add_bound_variables_to_ctxt cx bounds concl =
  27.106 +    fold (fn a => fn b => update_binding a b)
  27.107 +      (map (fn s => ((s, Term (Free (s, the_default dummyT (find_type_in_formula concl s))))))
  27.108 +       bounds) cx
  27.109 +
  27.110 +fun update_step_and_cx (st as VeriT_Node {id, rule, prems, concl, bounds}) cx =
  27.111 +  if rule = veriT_tmp_ite_elim_rule then
  27.112 +    (mk_node id rule prems concl bounds, add_bound_variables_to_ctxt cx bounds concl)
  27.113 +  else if rule = veriT_tmp_skolemize_rule then
  27.114 +    let
  27.115 +      val concl' = replace_bound_var_by_free_var concl bounds
  27.116 +    in
  27.117 +      (mk_node id rule prems concl' [], add_bound_variables_to_ctxt cx bounds concl)
  27.118 +    end
  27.119 +  else
  27.120 +    (st, cx)
  27.121 +
  27.122 +(*FIXME: using a reference would be better to know th numbers of the steps to add*)
  27.123 +fun fix_subproof_steps ((((id_of_father_step, rule), prems), subproof), ((step_concl, bounds),
  27.124 +    cx)) =
  27.125 +  let
  27.126 +    fun mk_prop_of_term concl = (fastype_of concl = @{typ "bool"} ?
  27.127 +      curry (op $) @{term "Trueprop"}) concl
  27.128 +    fun inline_assumption assumption assumption_id (st as VeriT_Node {id, rule, prems, concl,
  27.129 +        bounds}) =
  27.130 +      if List.find (curry (op =) assumption_id) prems <> NONE then
  27.131 +        let
  27.132 +          val prems' = filter_out (curry (op =) assumption_id) prems
  27.133 +        in
  27.134 +          mk_node id rule (filter_out (curry (op =) assumption_id) prems')
  27.135 +            (Const (@{const_name "Pure.imp"}, @{typ "prop"} --> @{typ "prop"} --> @{typ "prop"})
  27.136 +            $ mk_prop_of_term assumption $ mk_prop_of_term concl) bounds
  27.137 +        end
  27.138 +      else
  27.139 +        st
  27.140 +    fun find_input_steps_and_inline [] last_step = ([], last_step)
  27.141 +      | find_input_steps_and_inline (VeriT_Node {id = id', rule, prems, concl, bounds} :: steps)
  27.142 +          last_step =
  27.143 +        if rule = veriT_input_rule then
  27.144 +          find_input_steps_and_inline (map (inline_assumption concl id') steps) last_step
  27.145 +        else
  27.146 +          apfst (cons (mk_node (id_of_father_step ^ id') rule prems concl bounds))
  27.147 +            (find_input_steps_and_inline steps (id_of_father_step ^ id'))
  27.148 +    val (subproof', last_step_id) = find_input_steps_and_inline subproof ""
  27.149 +    val prems' =
  27.150 +      if last_step_id = "" then prems
  27.151 +      else
  27.152 +        (case prems of
  27.153 +          NONE => SOME [last_step_id]
  27.154 +        | SOME l => SOME (last_step_id :: l))
  27.155 +  in
  27.156 +    (subproof', (((((id_of_father_step, rule), prems'), step_concl), bounds), cx))
  27.157 +  end
  27.158 +
  27.159 +(*
  27.160 +(set id rule :clauses(...) :args(..) :conclusion (...)).
  27.161 +or
  27.162 +(set id subproof (set ...) :conclusion (...)).
  27.163 +*)
  27.164 +
  27.165 +fun parse_proof_step cx =
  27.166 +  let
  27.167 +    fun rotate_pair (a, (b, c)) = ((a, b), c)
  27.168 +    fun get_id (SMTLIB.S [SMTLIB.Sym "set", SMTLIB.Sym id, SMTLIB.S l]) = (id, l)
  27.169 +      | get_id t = raise Fail ("unrecognized VeriT Proof" ^ PolyML.makestring t)
  27.170 +    fun parse_rule (SMTLIB.Sym rule :: l) = (rule, l)
  27.171 +    fun parse_source (SMTLIB.Key "clauses" :: SMTLIB.S source ::l) =
  27.172 +        (SOME (map (fn (SMTLIB.Sym id) => id) source), l)
  27.173 +      | parse_source l = (NONE, l)
  27.174 +    fun parse_subproof cx id_of_father_step ((subproof_step as SMTLIB.S (SMTLIB.Sym "set" :: _)) :: l) =
  27.175 +        let val (subproof_steps, cx') = parse_proof_step cx subproof_step in
  27.176 +          apfst (apfst (curry (op @) subproof_steps)) (parse_subproof cx' id_of_father_step l)
  27.177 +        end
  27.178 +      | parse_subproof cx _ l = (([], cx), l)
  27.179 +    fun skip_args (SMTLIB.Key "args" :: SMTLIB.S _ :: l) = l
  27.180 +      | skip_args l = l
  27.181 +    fun parse_conclusion (SMTLIB.Key "conclusion" :: SMTLIB.S concl :: []) = concl
  27.182 +    fun make_or_from_clausification l =
  27.183 +      foldl1 (fn ((concl1, bounds1), (concl2, bounds2)) =>
  27.184 +        (HOLogic.mk_disj (perhaps (try HOLogic.dest_Trueprop) concl1,
  27.185 +        perhaps (try HOLogic.dest_Trueprop) concl2), bounds1 @ bounds2)) l
  27.186 +    fun to_node (((((id, rule), prems), concl), bounds), cx) = (mk_node id rule
  27.187 +      (the_default [] prems) concl bounds, cx)
  27.188 +  in
  27.189 +    get_id
  27.190 +    ##> parse_rule
  27.191 +    #> rotate_pair
  27.192 +    ##> parse_source
  27.193 +    #> rotate_pair
  27.194 +    ##> skip_args
  27.195 +    #> (fn (((id, rule), prems), sub) => (((id, rule), prems), parse_subproof cx id sub))
  27.196 +    #> rotate_pair
  27.197 +    ##> parse_conclusion
  27.198 +    ##> map repair_quantification
  27.199 +    #> (fn ((((id, rule), prems), (subproof, cx)), terms) =>
  27.200 +         (((((id, rule), prems), subproof), fold_map (fn t => fn cx => node_of t cx) terms cx)))
  27.201 +    ##> apfst (fn [] => (@{const False}, []) | concls => make_or_from_clausification concls)
  27.202 +    #> fix_subproof_steps
  27.203 +    ##> to_node
  27.204 +    #> (fn (subproof, (step, cx)) => (subproof @ [step], cx))
  27.205 +    #-> fold_map update_step_and_cx
  27.206 +  end
  27.207 +
  27.208 +(*subproofs are written on multiple lines: SMTLIB can not parse then, because parentheses are
  27.209 +unbalanced on each line*)
  27.210 +fun seperate_into_steps lines =
  27.211 +  let
  27.212 +    fun count ("(" :: l) n = count l (n+1)
  27.213 +      | count (")" :: l) n = count l (n-1)
  27.214 +      | count (_ :: l) n = count l n
  27.215 +      | count [] n = n
  27.216 +    fun seperate (line :: l) actual_lines m =
  27.217 +        let val n = count (raw_explode line) 0 in
  27.218 +          if m + n = 0 then
  27.219 +            [actual_lines ^ line] :: seperate l "" 0
  27.220 +          else seperate l (actual_lines ^ line) (m + n)
  27.221 +        end
  27.222 +      | seperate [] _ 0 = []
  27.223 +  in
  27.224 +    seperate lines "" 0
  27.225 +  end
  27.226 +
  27.227 + (* VeriT adds @ before every variable. *)
  27.228 +fun remove_all_at (SMTLIB.Sym v :: l) = SMTLIB.Sym (perhaps (try (unprefix "@")) v) :: remove_all_at l
  27.229 +  | remove_all_at (SMTLIB.S l :: l') = SMTLIB.S (remove_all_at l) :: remove_all_at l'
  27.230 +  | remove_all_at (SMTLIB.Key v :: l) = SMTLIB.Key v :: remove_all_at l
  27.231 +  | remove_all_at (v :: l) = v :: remove_all_at l
  27.232 +  | remove_all_at [] = []
  27.233 +
  27.234 +fun find_in_which_step_defined var (VeriT_Node {id, bounds, ...} :: l) =
  27.235 +    (case List.find (fn v => String.isPrefix v var) bounds of
  27.236 +      NONE => find_in_which_step_defined var l
  27.237 +    | SOME _ => id)
  27.238 +  | find_in_which_step_defined var _ = raise Fail ("undefined " ^ var)
  27.239 +
  27.240 +(*Yes every case is possible: the introduced var is not on a special size of the equality sign.*)
  27.241 +fun find_ite_var_in_term (Const ("HOL.If", _) $ _ $
  27.242 +      (Const (@{const_name "HOL.eq"}, _) $ Free (var1, _) $ Free (var2, _) ) $
  27.243 +      (Const (@{const_name "HOL.eq"}, _) $ Free (var3, _) $ Free (var4, _) )) =
  27.244 +    let
  27.245 +      fun get_number_of_ite_transformed_var var =
  27.246 +        perhaps (try (unprefix "ite")) var
  27.247 +        |> Int.fromString
  27.248 +      fun is_equal_and_has_correct_substring var var' var'' =
  27.249 +        if var = var' andalso String.isPrefix "ite" var then SOME var'
  27.250 +        else if var = var'' andalso String.isPrefix "ite" var then SOME var'' else NONE
  27.251 +      val var1_introduced_var = is_equal_and_has_correct_substring var1 var3 var4
  27.252 +      val var2_introduced_var = is_equal_and_has_correct_substring var3 var1 var2
  27.253 +    in
  27.254 +      (case (var1_introduced_var, var2_introduced_var) of
  27.255 +        (SOME a, SOME b) =>
  27.256 +          (*ill-generated case, might be possible when applying the rule to max a a. Only if the
  27.257 +          variable have been introduced before. Probably an impossible edge case*)
  27.258 +          (case (get_number_of_ite_transformed_var a, get_number_of_ite_transformed_var b) of
  27.259 +            (SOME a, SOME b) => if a < b then var2_introduced_var else var1_introduced_var
  27.260 +            (*Otherwise, it is a name clase between a parameter name and the introduced variable.
  27.261 +             Or the name convention has been changed.*)
  27.262 +          | (NONE, SOME _) => var2_introduced_var
  27.263 +          | (SOME _, NONE) => var2_introduced_var)
  27.264 +      | (_, SOME _) => var2_introduced_var
  27.265 +      | (SOME _, _) => var1_introduced_var)
  27.266 +    end
  27.267 +  | find_ite_var_in_term (Const (@{const_name "If"}, _) $ _ $
  27.268 +      (Const (@{const_name "HOL.eq"}, _) $ Free (var, _) $ _ ) $
  27.269 +      (Const (@{const_name "HOL.eq"}, _) $ Free (var', _) $ _ )) =
  27.270 +    if var = var' then SOME var else NONE
  27.271 +  | find_ite_var_in_term (Const (@{const_name "If"}, _) $ _ $
  27.272 +      (Const (@{const_name "HOL.eq"}, _) $ _ $ Free (var, _)) $
  27.273 +      (Const (@{const_name "HOL.eq"}, _) $ _ $ Free (var', _))) =
  27.274 +    if var = var' then SOME var else NONE
  27.275 +  | find_ite_var_in_term (p $ q) =
  27.276 +    (case find_ite_var_in_term p of
  27.277 +      NONE => find_ite_var_in_term q
  27.278 +    | x => x)
  27.279 +  | find_ite_var_in_term (Abs (_, _, body)) = find_ite_var_in_term body
  27.280 +  | find_ite_var_in_term _ = NONE
  27.281 +
  27.282 +fun correct_veriT_step steps (st as VeriT_Node {id, rule, prems, concl, bounds}) =
  27.283 +  if rule = veriT_tmp_ite_elim_rule then
  27.284 +    if bounds = [] then
  27.285 +      (*if the introduced var has already been defined, adding the definition as a dependency*)
  27.286 +      let
  27.287 +        val new_prems =
  27.288 +          (case find_ite_var_in_term concl of
  27.289 +            NONE => prems
  27.290 +          | SOME var => find_in_which_step_defined var steps :: prems)
  27.291 +      in
  27.292 +        VeriT_Node {id = id, rule = rule, prems = new_prems, concl = concl, bounds = bounds}
  27.293 +      end
  27.294 +    else
  27.295 +      (*some new variables are created*)
  27.296 +      let
  27.297 +        val concl' = replace_bound_var_by_free_var concl bounds
  27.298 +      in
  27.299 +        mk_node id rule prems concl' []
  27.300 +      end
  27.301 +  else
  27.302 +    st
  27.303 +
  27.304 +fun remove_alpha_conversion _ [] = []
  27.305 +  | remove_alpha_conversion replace_table (VeriT_Node {id, rule, prems, concl, bounds} :: steps) =
  27.306 +    let
  27.307 +      fun correct_dependency prems =
  27.308 +        map (fn x => perhaps (Symtab.lookup replace_table) x) prems
  27.309 +      fun find_predecessor prem = perhaps (Symtab.lookup replace_table) prem
  27.310 +    in
  27.311 +      if rule = veriT_alpha_conv_rule then
  27.312 +        remove_alpha_conversion (Symtab.update (id, find_predecessor (hd prems))
  27.313 +          replace_table) steps
  27.314 +      else
  27.315 +        VeriT_Node {id = id, rule = rule, prems = correct_dependency prems,
  27.316 +          concl = concl, bounds = bounds} :: remove_alpha_conversion replace_table steps
  27.317 +    end
  27.318 +
  27.319 +fun correct_veriT_steps steps =
  27.320 +  steps
  27.321 +  |> map (correct_veriT_step steps)
  27.322 +  |> remove_alpha_conversion Symtab.empty
  27.323 +
  27.324 +fun parse typs funs lines ctxt =
  27.325 +  let
  27.326 +    val smtlib_lines_without_at = remove_all_at (map SMTLIB.parse (seperate_into_steps lines))
  27.327 +    val (u, env) = apfst flat (fold_map (fn l => fn cx => parse_proof_step cx l)
  27.328 +      smtlib_lines_without_at (empty_context ctxt typs funs))
  27.329 +    val t = correct_veriT_steps u
  27.330 +    fun node_to_step (VeriT_Node {id, rule, prems, concl, bounds, ...}) =
  27.331 +      mk_step id rule prems concl bounds
  27.332 +   in
  27.333 +    (map node_to_step t, ctxt_of env)
  27.334 +  end
  27.335 +
  27.336 +end;
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/HOL/Tools/SMT/verit_proof_parse.ML	Thu Aug 28 00:40:38 2014 +0200
    28.3 @@ -0,0 +1,104 @@
    28.4 +(*  Title:      HOL/Tools/SMT/verit_proof_parse.ML
    28.5 +    Author:     Mathias Fleury, TU Muenchen
    28.6 +    Author:     Jasmin Blanchette, TU Muenchen
    28.7 +
    28.8 +VeriT proof parsing.
    28.9 +*)
   28.10 +
   28.11 +signature VERIT_PROOF_PARSE =
   28.12 +sig
   28.13 +  type ('a, 'b) atp_step = ('a, 'b) ATP_Proof.atp_step
   28.14 +  val parse_proof: Proof.context -> SMT_Translate.replay_data ->
   28.15 +    ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list ->
   28.16 +    SMT_Solver.parsed_proof
   28.17 +end;
   28.18 +
   28.19 +structure VeriT_Proof_Parse: VERIT_PROOF_PARSE =
   28.20 +struct
   28.21 +
   28.22 +open ATP_Util
   28.23 +open ATP_Problem
   28.24 +open ATP_Proof
   28.25 +open ATP_Proof_Reconstruct
   28.26 +open VeriT_Isar
   28.27 +open VeriT_Proof
   28.28 +
   28.29 +fun find_and_add_missing_dependances steps assms ll_offset =
   28.30 +  let
   28.31 +    fun prems_to_theorem_number [] id repl = (([], []), (id, repl))
   28.32 +      | prems_to_theorem_number (x :: ths) id replaced =
   28.33 +        (case Int.fromString (perhaps (try (unprefix SMTLIB_Interface.assert_prefix)) x) of
   28.34 +          NONE =>
   28.35 +          let
   28.36 +            val ((prems, iidths), (id', replaced')) = prems_to_theorem_number ths id replaced
   28.37 +          in
   28.38 +            ((x :: prems, iidths), (id', replaced'))
   28.39 +          end
   28.40 +        | SOME th =>
   28.41 +          (case Option.map snd (List.find (fst #> curry (op =) x) replaced) of
   28.42 +            NONE =>
   28.43 +            let
   28.44 +              val id' = if th = ll_offset then 0 else id - ll_offset (* 0: for the conjecture*)
   28.45 +              val ((prems, iidths), (id'', replaced')) =
   28.46 +                prems_to_theorem_number ths (if th <> ll_offset then id + 1 else id)
   28.47 +                  ((x, string_of_int id') :: replaced)
   28.48 +            in
   28.49 +              ((string_of_int id' :: prems, (th, (id', th - ll_offset)) :: iidths),
   28.50 +               (id'', replaced'))
   28.51 +            end
   28.52 +          | SOME x =>
   28.53 +            let
   28.54 +              val ((prems, iidths), (id', replaced')) = prems_to_theorem_number ths id replaced
   28.55 +            in ((x :: prems, iidths), (id', replaced')) end))
   28.56 +    fun update_step (VeriT_Proof.VeriT_Step {prems, id = id0, rule = rule0,
   28.57 +        concl = concl0, fixes = fixes0}) (id, replaced) =
   28.58 +      let val ((prems', iidths), (id', replaced)) = prems_to_theorem_number prems id replaced
   28.59 +      in
   28.60 +        ((VeriT_Proof.VeriT_Step {id = id0, rule = rule0, prems = prems', concl = concl0,
   28.61 +           fixes = fixes0}, iidths), (id', replaced))
   28.62 +      end
   28.63 +  in
   28.64 +    fold_map update_step steps (1, [])
   28.65 +    |> fst
   28.66 +    |> `(map snd)
   28.67 +    ||> (map fst)
   28.68 +    |>> flat
   28.69 +    |>> map (fn (_, (id, tm_id)) => let val (i, tm) = nth assms tm_id in (i, (id, tm)) end)
   28.70 +  end
   28.71 +
   28.72 +fun add_missing_steps iidths =
   28.73 +  let
   28.74 +    fun add_single_step (_, (id, th)) = VeriT_Proof.VeriT_Step {id = string_of_int id,
   28.75 +      rule = veriT_input_rule, prems = [], concl = prop_of th, fixes = []}
   28.76 +  in map add_single_step iidths end
   28.77 +
   28.78 +fun parse_proof _
   28.79 +    ({context = ctxt, typs, terms, ll_defs, rewrite_rules, assms} : SMT_Translate.replay_data)
   28.80 +    xfacts prems concl output =
   28.81 +  let
   28.82 +    val (steps, _) = VeriT_Proof.parse typs terms output ctxt
   28.83 +    val (iidths, steps'') = find_and_add_missing_dependances steps assms (length ll_defs)
   28.84 +    val steps' = add_missing_steps iidths @ steps''
   28.85 +    fun id_of_index i = the_default ~1 (Option.map fst (AList.lookup (op =) iidths i))
   28.86 +
   28.87 +    val prems_i = 1
   28.88 +    val facts_i = prems_i + length prems
   28.89 +    val conjecture_i = 0
   28.90 +    val ll_offset = id_of_index conjecture_i
   28.91 +    val prem_ids = map id_of_index (prems_i upto facts_i - 1)
   28.92 +    val helper_ids = map_filter (try (fn (~1, idth) => idth)) iidths
   28.93 +
   28.94 +    val fact_ids = map_filter (fn (i, (id, _)) =>
   28.95 +      (try (apsnd (nth xfacts)) (id, i - facts_i))) iidths
   28.96 +    val fact_helper_ts =
   28.97 +      map (fn (_, th) => (ATP_Util.short_thm_name ctxt th, prop_of th)) helper_ids @
   28.98 +      map (fn (_, ((s, _), th)) => (s, prop_of th)) fact_ids
   28.99 +    val fact_helper_ids =
  28.100 +      map (apsnd (ATP_Util.short_thm_name ctxt)) helper_ids @ map (apsnd (fst o fst)) fact_ids
  28.101 +  in
  28.102 +    {outcome = NONE, fact_ids = fact_ids,
  28.103 +     atp_proof = fn () => atp_proof_of_veriT_proof ctxt ll_defs rewrite_rules prems concl
  28.104 +       fact_helper_ts prem_ids ll_offset fact_helper_ids steps'}
  28.105 +  end
  28.106 +
  28.107 +end;
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/Tools/SMT/z3_interface.ML	Thu Aug 28 00:40:38 2014 +0200
    29.3 @@ -0,0 +1,192 @@
    29.4 +(*  Title:      HOL/Tools/SMT/z3_interface.ML
    29.5 +    Author:     Sascha Boehme, TU Muenchen
    29.6 +
    29.7 +Interface to Z3 based on a relaxed version of SMT-LIB.
    29.8 +*)
    29.9 +
   29.10 +signature Z3_INTERFACE =
   29.11 +sig
   29.12 +  val smtlib_z3C: SMT_Util.class
   29.13 +
   29.14 +  datatype sym = Sym of string * sym list
   29.15 +  type mk_builtins = {
   29.16 +    mk_builtin_typ: sym -> typ option,
   29.17 +    mk_builtin_num: theory -> int -> typ -> cterm option,
   29.18 +    mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
   29.19 +  val add_mk_builtins: mk_builtins -> Context.generic -> Context.generic
   29.20 +  val mk_builtin_typ: Proof.context -> sym -> typ option
   29.21 +  val mk_builtin_num: Proof.context -> int -> typ -> cterm option
   29.22 +  val mk_builtin_fun: Proof.context -> sym -> cterm list -> cterm option
   29.23 +
   29.24 +  val is_builtin_theory_term: Proof.context -> term -> bool
   29.25 +end;
   29.26 +
   29.27 +structure Z3_Interface: Z3_INTERFACE =
   29.28 +struct
   29.29 +
   29.30 +val smtlib_z3C = SMTLIB_Interface.smtlibC @ ["z3"]
   29.31 +
   29.32 +
   29.33 +(* interface *)
   29.34 +
   29.35 +local
   29.36 +  fun translate_config ctxt =
   29.37 +    {logic = K "", has_datatypes = true,
   29.38 +     serialize = #serialize (SMTLIB_Interface.translate_config ctxt)}
   29.39 +
   29.40 +  fun is_div_mod @{const div (int)} = true
   29.41 +    | is_div_mod @{const mod (int)} = true
   29.42 +    | is_div_mod _ = false
   29.43 +
   29.44 +  val have_int_div_mod = exists (Term.exists_subterm is_div_mod o Thm.prop_of)
   29.45 +
   29.46 +  fun add_div_mod _ (thms, extra_thms) =
   29.47 +    if have_int_div_mod thms orelse have_int_div_mod extra_thms then
   29.48 +      (thms, @{thms div_as_z3div mod_as_z3mod} @ extra_thms)
   29.49 +    else (thms, extra_thms)
   29.50 +
   29.51 +  val setup_builtins =
   29.52 +    SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const times (int)}, "*") #>
   29.53 +    SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const z3div}, "div") #>
   29.54 +    SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const z3mod}, "mod")
   29.55 +in
   29.56 +
   29.57 +val _ = Theory.setup (Context.theory_map (
   29.58 +  setup_builtins #>
   29.59 +  SMT_Normalize.add_extra_norm (smtlib_z3C, add_div_mod) #>
   29.60 +  SMT_Translate.add_config (smtlib_z3C, translate_config)))
   29.61 +
   29.62 +end
   29.63 +
   29.64 +
   29.65 +(* constructors *)
   29.66 +
   29.67 +datatype sym = Sym of string * sym list
   29.68 +
   29.69 +
   29.70 +(** additional constructors **)
   29.71 +
   29.72 +type mk_builtins = {
   29.73 +  mk_builtin_typ: sym -> typ option,
   29.74 +  mk_builtin_num: theory -> int -> typ -> cterm option,
   29.75 +  mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
   29.76 +
   29.77 +fun chained _ [] = NONE
   29.78 +  | chained f (b :: bs) = (case f b of SOME y => SOME y | NONE => chained f bs)
   29.79 +
   29.80 +fun chained_mk_builtin_typ bs sym =
   29.81 +  chained (fn {mk_builtin_typ=mk, ...} : mk_builtins => mk sym) bs
   29.82 +
   29.83 +fun chained_mk_builtin_num ctxt bs i T =
   29.84 +  let val thy = Proof_Context.theory_of ctxt
   29.85 +  in chained (fn {mk_builtin_num=mk, ...} : mk_builtins => mk thy i T) bs end
   29.86 +
   29.87 +fun chained_mk_builtin_fun ctxt bs s cts =
   29.88 +  let val thy = Proof_Context.theory_of ctxt
   29.89 +  in chained (fn {mk_builtin_fun=mk, ...} : mk_builtins => mk thy s cts) bs end
   29.90 +
   29.91 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
   29.92 +
   29.93 +structure Mk_Builtins = Generic_Data
   29.94 +(
   29.95 +  type T = (int * mk_builtins) list
   29.96 +  val empty = []
   29.97 +  val extend = I
   29.98 +  fun merge data = Ord_List.merge fst_int_ord data
   29.99 +)
  29.100 +
  29.101 +fun add_mk_builtins mk = Mk_Builtins.map (Ord_List.insert fst_int_ord (serial (), mk))
  29.102 +
  29.103 +fun get_mk_builtins ctxt = map snd (Mk_Builtins.get (Context.Proof ctxt))
  29.104 +
  29.105 +
  29.106 +(** basic and additional constructors **)
  29.107 +
  29.108 +fun mk_builtin_typ _ (Sym ("Bool", _)) = SOME @{typ bool}
  29.109 +  | mk_builtin_typ _ (Sym ("Int", _)) = SOME @{typ int}
  29.110 +  | mk_builtin_typ _ (Sym ("bool", _)) = SOME @{typ bool}  (*FIXME: legacy*)
  29.111 +  | mk_builtin_typ _ (Sym ("int", _)) = SOME @{typ int}  (*FIXME: legacy*)
  29.112 +  | mk_builtin_typ ctxt sym = chained_mk_builtin_typ (get_mk_builtins ctxt) sym
  29.113 +
  29.114 +fun mk_builtin_num _ i @{typ int} = SOME (Numeral.mk_cnumber @{ctyp int} i)
  29.115 +  | mk_builtin_num ctxt i T =
  29.116 +      chained_mk_builtin_num ctxt (get_mk_builtins ctxt) i T
  29.117 +
  29.118 +val mk_true = Thm.cterm_of @{theory} (@{const Not} $ @{const False})
  29.119 +val mk_false = Thm.cterm_of @{theory} @{const False}
  29.120 +val mk_not = Thm.apply (Thm.cterm_of @{theory} @{const Not})
  29.121 +val mk_implies = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.implies})
  29.122 +val mk_iff = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.eq (bool)})
  29.123 +val conj = Thm.cterm_of @{theory} @{const HOL.conj}
  29.124 +val disj = Thm.cterm_of @{theory} @{const HOL.disj}
  29.125 +
  29.126 +fun mk_nary _ cu [] = cu
  29.127 +  | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
  29.128 +
  29.129 +val eq = SMT_Util.mk_const_pat @{theory} @{const_name HOL.eq} SMT_Util.destT1
  29.130 +fun mk_eq ct cu = Thm.mk_binop (SMT_Util.instT' ct eq) ct cu
  29.131 +
  29.132 +val if_term =
  29.133 +  SMT_Util.mk_const_pat @{theory} @{const_name If} (SMT_Util.destT1 o SMT_Util.destT2)
  29.134 +fun mk_if cc ct = Thm.mk_binop (Thm.apply (SMT_Util.instT' ct if_term) cc) ct
  29.135 +
  29.136 +val access = SMT_Util.mk_const_pat @{theory} @{const_name fun_app} SMT_Util.destT1
  29.137 +fun mk_access array = Thm.apply (SMT_Util.instT' array access) array
  29.138 +
  29.139 +val update =
  29.140 +  SMT_Util.mk_const_pat @{theory} @{const_name fun_upd} (Thm.dest_ctyp o SMT_Util.destT1)
  29.141 +fun mk_update array index value =
  29.142 +  let val cTs = Thm.dest_ctyp (Thm.ctyp_of_term array)
  29.143 +  in Thm.apply (Thm.mk_binop (SMT_Util.instTs cTs update) array index) value end
  29.144 +
  29.145 +val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (int)})
  29.146 +val add = Thm.cterm_of @{theory} @{const plus (int)}
  29.147 +val int0 = Numeral.mk_cnumber @{ctyp int} 0
  29.148 +val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (int)})
  29.149 +val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (int)})
  29.150 +val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3div})
  29.151 +val mk_mod = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3mod})
  29.152 +val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (int)})
  29.153 +val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (int)})
  29.154 +
  29.155 +fun mk_builtin_fun ctxt sym cts =
  29.156 +  (case (sym, cts) of
  29.157 +    (Sym ("true", _), []) => SOME mk_true
  29.158 +  | (Sym ("false", _), []) => SOME mk_false
  29.159 +  | (Sym ("not", _), [ct]) => SOME (mk_not ct)
  29.160 +  | (Sym ("and", _), _) => SOME (mk_nary conj mk_true cts)
  29.161 +  | (Sym ("or", _), _) => SOME (mk_nary disj mk_false cts)
  29.162 +  | (Sym ("implies", _), [ct, cu]) => SOME (mk_implies ct cu)
  29.163 +  | (Sym ("iff", _), [ct, cu]) => SOME (mk_iff ct cu)
  29.164 +  | (Sym ("~", _), [ct, cu]) => SOME (mk_iff ct cu)
  29.165 +  | (Sym ("xor", _), [ct, cu]) => SOME (mk_not (mk_iff ct cu))
  29.166 +  | (Sym ("if", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3)
  29.167 +  | (Sym ("ite", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3) (* FIXME: remove *)
  29.168 +  | (Sym ("=", _), [ct, cu]) => SOME (mk_eq ct cu)
  29.169 +  | (Sym ("select", _), [ca, ck]) => SOME (Thm.apply (mk_access ca) ck)
  29.170 +  | (Sym ("store", _), [ca, ck, cv]) => SOME (mk_update ca ck cv)
  29.171 +  | _ =>
  29.172 +    (case (sym, try (#T o Thm.rep_cterm o hd) cts, cts) of
  29.173 +      (Sym ("+", _), SOME @{typ int}, _) => SOME (mk_nary add int0 cts)
  29.174 +    | (Sym ("-", _), SOME @{typ int}, [ct]) => SOME (mk_uminus ct)
  29.175 +    | (Sym ("-", _), SOME @{typ int}, [ct, cu]) => SOME (mk_sub ct cu)
  29.176 +    | (Sym ("*", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mul ct cu)
  29.177 +    | (Sym ("div", _), SOME @{typ int}, [ct, cu]) => SOME (mk_div ct cu)
  29.178 +    | (Sym ("mod", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mod ct cu)
  29.179 +    | (Sym ("<", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt ct cu)
  29.180 +    | (Sym ("<=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le ct cu)
  29.181 +    | (Sym (">", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt cu ct)
  29.182 +    | (Sym (">=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le cu ct)
  29.183 +    | _ => chained_mk_builtin_fun ctxt (get_mk_builtins ctxt) sym cts))
  29.184 +
  29.185 +
  29.186 +(* abstraction *)
  29.187 +
  29.188 +fun is_builtin_theory_term ctxt t =
  29.189 +  if SMT_Builtin.is_builtin_num ctxt t then true
  29.190 +  else
  29.191 +    (case Term.strip_comb t of
  29.192 +      (Const c, ts) => SMT_Builtin.is_builtin_fun ctxt c ts
  29.193 +    | _ => false)
  29.194 +
  29.195 +end;
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/Tools/SMT/z3_isar.ML	Thu Aug 28 00:40:38 2014 +0200
    30.3 @@ -0,0 +1,123 @@
    30.4 +(*  Title:      HOL/Tools/SMT/z3_isar.ML
    30.5 +    Author:     Jasmin Blanchette, TU Muenchen
    30.6 +
    30.7 +Z3 proofs as generic ATP proofs for Isar proof reconstruction.
    30.8 +*)
    30.9 +
   30.10 +signature Z3_ISAR =
   30.11 +sig
   30.12 +  val atp_proof_of_z3_proof: Proof.context -> term list -> thm list -> term list -> term ->
   30.13 +    (string * term) list -> int list -> int -> (int * string) list -> Z3_Proof.z3_step list ->
   30.14 +    (term, string) ATP_Proof.atp_step list
   30.15 +end;
   30.16 +
   30.17 +structure Z3_Isar: Z3_ISAR =
   30.18 +struct
   30.19 +
   30.20 +open ATP_Util
   30.21 +open ATP_Problem
   30.22 +open ATP_Proof
   30.23 +open ATP_Proof_Reconstruct
   30.24 +open SMTLIB_Isar
   30.25 +
   30.26 +val z3_apply_def_rule = Z3_Proof.string_of_rule Z3_Proof.Apply_Def
   30.27 +val z3_hypothesis_rule = Z3_Proof.string_of_rule Z3_Proof.Hypothesis
   30.28 +val z3_intro_def_rule = Z3_Proof.string_of_rule Z3_Proof.Intro_Def
   30.29 +val z3_lemma_rule = Z3_Proof.string_of_rule Z3_Proof.Lemma
   30.30 +
   30.31 +fun inline_z3_defs _ [] = []
   30.32 +  | inline_z3_defs defs ((name, role, t, rule, deps) :: lines) =
   30.33 +    if rule = z3_intro_def_rule then
   30.34 +      let val def = t |> HOLogic.dest_Trueprop |> HOLogic.dest_eq |> swap in
   30.35 +        inline_z3_defs (insert (op =) def defs)
   30.36 +          (map (replace_dependencies_in_line (name, [])) lines)
   30.37 +      end
   30.38 +    else if rule = z3_apply_def_rule then
   30.39 +      inline_z3_defs defs (map (replace_dependencies_in_line (name, [])) lines)
   30.40 +    else
   30.41 +      (name, role, Term.subst_atomic defs t, rule, deps) :: inline_z3_defs defs lines
   30.42 +
   30.43 +fun add_z3_hypotheses [] = I
   30.44 +  | add_z3_hypotheses hyps =
   30.45 +    HOLogic.dest_Trueprop
   30.46 +    #> curry s_imp (Library.foldr1 s_conj (map HOLogic.dest_Trueprop hyps))
   30.47 +    #> HOLogic.mk_Trueprop
   30.48 +
   30.49 +fun inline_z3_hypotheses _ _ [] = []
   30.50 +  | inline_z3_hypotheses hyp_names hyps ((name, role, t, rule, deps) :: lines) =
   30.51 +    if rule = z3_hypothesis_rule then
   30.52 +      inline_z3_hypotheses (name :: hyp_names) (AList.map_default (op =) (t, []) (cons name) hyps)
   30.53 +        lines
   30.54 +    else
   30.55 +      let val deps' = subtract (op =) hyp_names deps in
   30.56 +        if rule = z3_lemma_rule then
   30.57 +          (name, role, t, rule, deps') :: inline_z3_hypotheses hyp_names hyps lines
   30.58 +        else
   30.59 +          let
   30.60 +            val add_hyps = filter_out (null o inter (op =) deps o snd) hyps
   30.61 +            val t' = add_z3_hypotheses (map fst add_hyps) t
   30.62 +            val deps' = subtract (op =) hyp_names deps
   30.63 +            val hyps' = fold (AList.update (op =) o apsnd (insert (op =) name)) add_hyps hyps
   30.64 +          in
   30.65 +            (name, role, t', rule, deps') :: inline_z3_hypotheses hyp_names hyps' lines
   30.66 +          end
   30.67 +      end
   30.68 +
   30.69 +fun dest_alls (Const (@{const_name Pure.all}, _) $ Abs (abs as (_, T, _))) =
   30.70 +    let val (s', t') = Term.dest_abs abs in
   30.71 +      dest_alls t' |>> cons (s', T)
   30.72 +    end
   30.73 +  | dest_alls t = ([], t)
   30.74 +
   30.75 +val reorder_foralls =
   30.76 +  dest_alls
   30.77 +  #>> sort_wrt fst
   30.78 +  #-> fold_rev (Logic.all o Free);
   30.79 +
   30.80 +fun atp_proof_of_z3_proof ctxt ll_defs rewrite_rules hyp_ts concl_t fact_helper_ts prem_ids
   30.81 +    conjecture_id fact_helper_ids proof =
   30.82 +  let
   30.83 +    val thy = Proof_Context.theory_of ctxt
   30.84 +
   30.85 +    fun steps_of (Z3_Proof.Z3_Step {id, rule, prems, concl, ...}) =
   30.86 +      let
   30.87 +        val sid = string_of_int id
   30.88 +
   30.89 +        val concl' = concl
   30.90 +          |> reorder_foralls (* crucial for skolemization steps *)
   30.91 +          |> postprocess_step_conclusion thy rewrite_rules ll_defs
   30.92 +        fun standard_step role =
   30.93 +          ((sid, []), role, concl', Z3_Proof.string_of_rule rule,
   30.94 +           map (fn id => (string_of_int id, [])) prems)
   30.95 +      in
   30.96 +        (case rule of
   30.97 +          Z3_Proof.Asserted =>
   30.98 +          let val ss = the_list (AList.lookup (op =) fact_helper_ids id) in
   30.99 +            (case distinguish_conjecture_and_hypothesis ss id conjecture_id prem_ids fact_helper_ts
  30.100 +                hyp_ts concl_t of
  30.101 +              NONE => []
  30.102 +            | SOME (role0, concl00) =>
  30.103 +              let
  30.104 +                val name0 = (sid ^ "a", ss)
  30.105 +                val concl0 = unskolemize_names concl00
  30.106 +              in
  30.107 +                (if role0 = Axiom then []
  30.108 +                 else [(name0, role0, concl0, Z3_Proof.string_of_rule rule, [])]) @
  30.109 +                [((sid, []), Plain, concl', Z3_Proof.string_of_rule Z3_Proof.Rewrite,
  30.110 +                  name0 :: normalizing_prems ctxt concl0)]
  30.111 +              end)
  30.112 +          end
  30.113 +        | Z3_Proof.Rewrite => [standard_step Lemma]
  30.114 +        | Z3_Proof.Rewrite_Star => [standard_step Lemma]
  30.115 +        | Z3_Proof.Skolemize => [standard_step Lemma]
  30.116 +        | Z3_Proof.Th_Lemma _ => [standard_step Lemma]
  30.117 +        | _ => [standard_step Plain])
  30.118 +      end
  30.119 +  in
  30.120 +    proof
  30.121 +    |> maps steps_of
  30.122 +    |> inline_z3_defs []
  30.123 +    |> inline_z3_hypotheses [] []
  30.124 +  end
  30.125 +
  30.126 +end;
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/Tools/SMT/z3_proof.ML	Thu Aug 28 00:40:38 2014 +0200
    31.3 @@ -0,0 +1,303 @@
    31.4 +(*  Title:      HOL/Tools/SMT/z3_proof.ML
    31.5 +    Author:     Sascha Boehme, TU Muenchen
    31.6 +
    31.7 +Z3 proofs: parsing and abstract syntax tree.
    31.8 +*)
    31.9 +
   31.10 +signature Z3_PROOF =
   31.11 +sig
   31.12 +  (*proof rules*)
   31.13 +  datatype z3_rule =
   31.14 +    True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | Symmetry | Transitivity |
   31.15 +    Transitivity_Star | Monotonicity | Quant_Intro | Distributivity | And_Elim | Not_Or_Elim |
   31.16 +    Rewrite | Rewrite_Star | Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars |
   31.17 +    Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False |
   31.18 +    Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star |
   31.19 +    Cnf_Star | Skolemize | Modus_Ponens_Oeq | Th_Lemma of string
   31.20 +
   31.21 +  val is_assumption: z3_rule -> bool
   31.22 +  val string_of_rule: z3_rule -> string
   31.23 +
   31.24 +  (*proofs*)
   31.25 +  datatype z3_step = Z3_Step of {
   31.26 +    id: int,
   31.27 +    rule: z3_rule,
   31.28 +    prems: int list,
   31.29 +    concl: term,
   31.30 +    fixes: string list,
   31.31 +    is_fix_step: bool}
   31.32 +
   31.33 +  (*proof parser*)
   31.34 +  val parse: typ Symtab.table -> term Symtab.table -> string list ->
   31.35 +    Proof.context -> z3_step list * Proof.context
   31.36 +end;
   31.37 +
   31.38 +structure Z3_Proof: Z3_PROOF =
   31.39 +struct
   31.40 +
   31.41 +open SMTLIB_Proof
   31.42 +
   31.43 +
   31.44 +(* proof rules *)
   31.45 +
   31.46 +datatype z3_rule =
   31.47 +  True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity | Symmetry | Transitivity |
   31.48 +  Transitivity_Star | Monotonicity | Quant_Intro | Distributivity | And_Elim | Not_Or_Elim |
   31.49 +  Rewrite | Rewrite_Star | Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars |
   31.50 +  Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False |
   31.51 +  Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star |
   31.52 +  Cnf_Star | Skolemize | Modus_Ponens_Oeq | Th_Lemma of string
   31.53 +  (* some proof rules include further information that is currently dropped by the parser *)
   31.54 +
   31.55 +val rule_names = Symtab.make [
   31.56 +  ("true-axiom", True_Axiom),
   31.57 +  ("asserted", Asserted),
   31.58 +  ("goal", Goal),
   31.59 +  ("mp", Modus_Ponens),
   31.60 +  ("refl", Reflexivity),
   31.61 +  ("symm", Symmetry),
   31.62 +  ("trans", Transitivity),
   31.63 +  ("trans*", Transitivity_Star),
   31.64 +  ("monotonicity", Monotonicity),
   31.65 +  ("quant-intro", Quant_Intro),
   31.66 +  ("distributivity", Distributivity),
   31.67 +  ("and-elim", And_Elim),
   31.68 +  ("not-or-elim", Not_Or_Elim),
   31.69 +  ("rewrite", Rewrite),
   31.70 +  ("rewrite*", Rewrite_Star),
   31.71 +  ("pull-quant", Pull_Quant),
   31.72 +  ("pull-quant*", Pull_Quant_Star),
   31.73 +  ("push-quant", Push_Quant),
   31.74 +  ("elim-unused", Elim_Unused_Vars),
   31.75 +  ("der", Dest_Eq_Res),
   31.76 +  ("quant-inst", Quant_Inst),
   31.77 +  ("hypothesis", Hypothesis),
   31.78 +  ("lemma", Lemma),
   31.79 +  ("unit-resolution", Unit_Resolution),
   31.80 +  ("iff-true", Iff_True),
   31.81 +  ("iff-false", Iff_False),
   31.82 +  ("commutativity", Commutativity),
   31.83 +  ("def-axiom", Def_Axiom),
   31.84 +  ("intro-def", Intro_Def),
   31.85 +  ("apply-def", Apply_Def),
   31.86 +  ("iff~", Iff_Oeq),
   31.87 +  ("nnf-pos", Nnf_Pos),
   31.88 +  ("nnf-neg", Nnf_Neg),
   31.89 +  ("nnf*", Nnf_Star),
   31.90 +  ("cnf*", Cnf_Star),
   31.91 +  ("sk", Skolemize),
   31.92 +  ("mp~", Modus_Ponens_Oeq)]
   31.93 +
   31.94 +fun is_assumption Asserted = true
   31.95 +  | is_assumption Goal = true
   31.96 +  | is_assumption Hypothesis = true
   31.97 +  | is_assumption Intro_Def = true
   31.98 +  | is_assumption Skolemize = true
   31.99 +  | is_assumption _ = false
  31.100 +
  31.101 +fun rule_of_string name =
  31.102 +  (case Symtab.lookup rule_names name of
  31.103 +    SOME rule => rule
  31.104 +  | NONE => error ("unknown Z3 proof rule " ^ quote name))
  31.105 +
  31.106 +fun string_of_rule (Th_Lemma kind) = "th-lemma" ^ (if kind = "" then "" else " " ^ kind)
  31.107 +  | string_of_rule r =
  31.108 +      let fun eq_rule (s, r') = if r = r' then SOME s else NONE
  31.109 +      in the (Symtab.get_first eq_rule rule_names) end
  31.110 +
  31.111 +
  31.112 +(* proofs *)
  31.113 +
  31.114 +datatype z3_node = Z3_Node of {
  31.115 +  id: int,
  31.116 +  rule: z3_rule,
  31.117 +  prems: z3_node list,
  31.118 +  concl: term,
  31.119 +  bounds: string list}
  31.120 +
  31.121 +fun mk_node id rule prems concl bounds =
  31.122 +  Z3_Node {id = id, rule = rule, prems = prems, concl = concl, bounds = bounds}
  31.123 +
  31.124 +datatype z3_step = Z3_Step of {
  31.125 +  id: int,
  31.126 +  rule: z3_rule,
  31.127 +  prems: int list,
  31.128 +  concl: term,
  31.129 +  fixes: string list,
  31.130 +  is_fix_step: bool}
  31.131 +
  31.132 +fun mk_step id rule prems concl fixes is_fix_step =
  31.133 +  Z3_Step {id = id, rule = rule, prems = prems, concl = concl, fixes = fixes,
  31.134 +    is_fix_step = is_fix_step}
  31.135 +
  31.136 +
  31.137 +(* proof parser *)
  31.138 +
  31.139 +fun rule_of (SMTLIB.Sym name) = rule_of_string name
  31.140 +  | rule_of (SMTLIB.S (SMTLIB.Sym "_" :: SMTLIB.Sym name :: args)) =
  31.141 +      (case (name, args) of
  31.142 +        ("th-lemma", SMTLIB.Sym kind :: _) => Th_Lemma kind
  31.143 +      | _ => rule_of_string name)
  31.144 +  | rule_of r = raise SMTLIB_PARSE ("bad Z3 proof rule format", r)
  31.145 +
  31.146 +fun node_of p cx =
  31.147 +  (case p of
  31.148 +    SMTLIB.Sym name =>
  31.149 +      (case lookup_binding cx name of
  31.150 +        Proof node => (node, cx)
  31.151 +      | Tree p' =>
  31.152 +          cx
  31.153 +          |> node_of p'
  31.154 +          |-> (fn node => pair node o update_binding (name, Proof node))
  31.155 +      | _ => raise SMTLIB_PARSE ("bad Z3 proof format", p))
  31.156 +  | SMTLIB.S [SMTLIB.Sym "let", SMTLIB.S bindings, p] =>
  31.157 +      with_bindings (map dest_binding bindings) (node_of p) cx
  31.158 +  | SMTLIB.S (name :: parts) =>
  31.159 +      let
  31.160 +        val (ps, p) = split_last parts
  31.161 +        val r = rule_of name
  31.162 +      in
  31.163 +        cx
  31.164 +        |> fold_map node_of ps
  31.165 +        ||>> `(with_fresh_names (term_of p))
  31.166 +        ||>> next_id
  31.167 +        |>> (fn ((prems, (t, ns)), id) => mk_node id r prems t ns)
  31.168 +      end
  31.169 +  | _ => raise SMTLIB_PARSE ("bad Z3 proof format", p))
  31.170 +
  31.171 +fun dest_name (SMTLIB.Sym name) = name
  31.172 +  | dest_name t = raise SMTLIB_PARSE ("bad name", t)
  31.173 +
  31.174 +fun dest_seq (SMTLIB.S ts) = ts
  31.175 +  | dest_seq t = raise SMTLIB_PARSE ("bad Z3 proof format", t)
  31.176 +
  31.177 +fun parse' (SMTLIB.S (SMTLIB.Sym "set-logic" :: _) :: ts) cx = parse' ts cx
  31.178 +  | parse' (SMTLIB.S [SMTLIB.Sym "declare-fun", n, tys, ty] :: ts) cx =
  31.179 +      let
  31.180 +        val name = dest_name n
  31.181 +        val Ts = map (type_of cx) (dest_seq tys)
  31.182 +        val T = type_of cx ty
  31.183 +      in parse' ts (declare_fun name (Ts ---> T) cx) end
  31.184 +  | parse' (SMTLIB.S [SMTLIB.Sym "proof", p] :: _) cx = node_of p cx
  31.185 +  | parse' ts _ = raise SMTLIB_PARSE ("bad Z3 proof declarations", SMTLIB.S ts)
  31.186 +
  31.187 +fun parse_proof typs funs lines ctxt =
  31.188 +  let
  31.189 +    val ts = dest_seq (SMTLIB.parse lines)
  31.190 +    val (node, cx) = parse' ts (empty_context ctxt typs funs)
  31.191 +  in (node, ctxt_of cx) end
  31.192 +  handle SMTLIB.PARSE (l, msg) => error ("parsing error at line " ^ string_of_int l ^ ": " ^ msg)
  31.193 +       | SMTLIB_PARSE (msg, t) => error (msg ^ ": " ^ SMTLIB.str_of t)
  31.194 +
  31.195 +
  31.196 +(* handling of bound variables *)
  31.197 +
  31.198 +fun subst_of tyenv =
  31.199 +  let fun add (ix, (S, T)) = cons (TVar (ix, S), T)
  31.200 +  in Vartab.fold add tyenv [] end
  31.201 +
  31.202 +fun substTs_same subst =
  31.203 +  let val applyT = Same.function (AList.lookup (op =) subst)
  31.204 +  in Term_Subst.map_atypsT_same applyT end
  31.205 +
  31.206 +fun subst_types ctxt env bounds t =
  31.207 +  let
  31.208 +    val match = Sign.typ_match (Proof_Context.theory_of ctxt)
  31.209 +
  31.210 +    val t' = singleton (Variable.polymorphic ctxt) t
  31.211 +    val patTs = map snd (Term.strip_qnt_vars @{const_name Pure.all} t')
  31.212 +    val objTs = map (the o Symtab.lookup env) bounds
  31.213 +    val subst = subst_of (fold match (patTs ~~ objTs) Vartab.empty)
  31.214 +  in Same.commit (Term_Subst.map_types_same (substTs_same subst)) t' end
  31.215 +
  31.216 +fun eq_quant (@{const_name HOL.All}, _) (@{const_name HOL.All}, _) = true
  31.217 +  | eq_quant (@{const_name HOL.Ex}, _) (@{const_name HOL.Ex}, _) = true
  31.218 +  | eq_quant _ _ = false
  31.219 +
  31.220 +fun opp_quant (@{const_name HOL.All}, _) (@{const_name HOL.Ex}, _) = true
  31.221 +  | opp_quant (@{const_name HOL.Ex}, _) (@{const_name HOL.All}, _) = true
  31.222 +  | opp_quant _ _ = false
  31.223 +
  31.224 +fun with_quant pred i (Const q1 $ Abs (_, T1, t1), Const q2 $ Abs (_, T2, t2)) =
  31.225 +      if pred q1 q2 andalso T1 = T2 then
  31.226 +        let val t = Var (("", i), T1)
  31.227 +        in SOME (pairself Term.subst_bound ((t, t1), (t, t2))) end
  31.228 +      else NONE
  31.229 +  | with_quant _ _ _ = NONE
  31.230 +
  31.231 +fun dest_quant_pair i (@{term HOL.Not} $ t1, t2) =
  31.232 +      Option.map (apfst HOLogic.mk_not) (with_quant opp_quant i (t1, t2))
  31.233 +  | dest_quant_pair i (t1, t2) = with_quant eq_quant i (t1, t2)
  31.234 +
  31.235 +fun dest_quant i t =
  31.236 +  (case dest_quant_pair i (HOLogic.dest_eq (HOLogic.dest_Trueprop t)) of
  31.237 +    SOME (t1, t2) => HOLogic.mk_Trueprop (HOLogic.mk_eq (t1, t2))
  31.238 +  | NONE => raise TERM ("lift_quant", [t]))
  31.239 +
  31.240 +fun match_types ctxt pat obj =
  31.241 +  (Vartab.empty, Vartab.empty)
  31.242 +  |> Pattern.first_order_match (Proof_Context.theory_of ctxt) (pat, obj)
  31.243 +
  31.244 +fun strip_match ctxt pat i obj =
  31.245 +  (case try (match_types ctxt pat) obj of
  31.246 +    SOME (tyenv, _) => subst_of tyenv
  31.247 +  | NONE => strip_match ctxt pat (i + 1) (dest_quant i obj))
  31.248 +
  31.249 +fun dest_all i (Const (@{const_name Pure.all}, _) $ (a as Abs (_, T, _))) =
  31.250 +      dest_all (i + 1) (Term.betapply (a, Var (("", i), T)))
  31.251 +  | dest_all i t = (i, t)
  31.252 +
  31.253 +fun dest_alls t = dest_all (Term.maxidx_of_term t + 1) t
  31.254 +
  31.255 +fun match_rule ctxt env (Z3_Node {bounds = bs', concl = t', ...}) bs t =
  31.256 +  let
  31.257 +    val t'' = singleton (Variable.polymorphic ctxt) t'
  31.258 +    val (i, obj) = dest_alls (subst_types ctxt env bs t)
  31.259 +  in
  31.260 +    (case try (strip_match ctxt (snd (dest_alls t'')) i) obj of
  31.261 +      NONE => NONE
  31.262 +    | SOME subst =>
  31.263 +        let
  31.264 +          val applyT = Same.commit (substTs_same subst)
  31.265 +          val patTs = map snd (Term.strip_qnt_vars @{const_name Pure.all} t'')
  31.266 +        in SOME (Symtab.make (bs' ~~ map applyT patTs)) end)
  31.267 +  end
  31.268 +
  31.269 +
  31.270 +(* linearizing proofs and resolving types of bound variables *)
  31.271 +
  31.272 +fun has_step (tab, _) = Inttab.defined tab
  31.273 +
  31.274 +fun add_step id rule bounds concl is_fix_step ids (tab, sts) =
  31.275 +  let val step = mk_step id rule ids concl bounds is_fix_step
  31.276 +  in (id, (Inttab.update (id, ()) tab, step :: sts)) end
  31.277 +
  31.278 +fun is_fix_rule rule prems =
  31.279 +  member (op =) [Quant_Intro, Nnf_Pos, Nnf_Neg] rule andalso length prems = 1
  31.280 +
  31.281 +fun lin_proof ctxt env (Z3_Node {id, rule, prems, concl, bounds}) steps =
  31.282 +  if has_step steps id then (id, steps)
  31.283 +  else
  31.284 +    let
  31.285 +      val t = subst_types ctxt env bounds concl
  31.286 +      val add = add_step id rule bounds t
  31.287 +      fun rec_apply e b = fold_map (lin_proof ctxt e) prems #-> add b
  31.288 +    in
  31.289 +      if is_fix_rule rule prems then
  31.290 +        (case match_rule ctxt env (hd prems) bounds t of
  31.291 +          NONE => rec_apply env false steps
  31.292 +        | SOME env' => rec_apply env' true steps)
  31.293 +      else rec_apply env false steps
  31.294 +    end
  31.295 +
  31.296 +fun linearize ctxt node =
  31.297 +  rev (snd (snd (lin_proof ctxt Symtab.empty node (Inttab.empty, []))))
  31.298 +
  31.299 +
  31.300 +(* overall proof parser *)
  31.301 +
  31.302 +fun parse typs funs lines ctxt =
  31.303 +  let val (node, ctxt') = parse_proof typs funs lines ctxt
  31.304 +  in (linearize ctxt' node, ctxt') end
  31.305 +
  31.306 +end;
    32.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.2 +++ b/src/HOL/Tools/SMT/z3_real.ML	Thu Aug 28 00:40:38 2014 +0200
    32.3 @@ -0,0 +1,32 @@
    32.4 +(*  Title:      HOL/Tools/SMT/z3_real.ML
    32.5 +    Author:     Sascha Boehme, TU Muenchen
    32.6 +
    32.7 +Z3 setup for reals.
    32.8 +*)
    32.9 +
   32.10 +structure Z3_Real: sig end =
   32.11 +struct
   32.12 +
   32.13 +fun real_type_parser (SMTLIB.Sym "Real", []) = SOME @{typ Real.real}
   32.14 +  | real_type_parser _ = NONE
   32.15 +
   32.16 +fun real_term_parser (SMTLIB.Dec (i, 0), []) = SOME (HOLogic.mk_number @{typ Real.real} i)
   32.17 +  | real_term_parser (SMTLIB.Sym "/", [t1, t2]) =
   32.18 +      SOME (@{term "inverse_class.divide :: real => _"} $ t1 $ t2)
   32.19 +  | real_term_parser (SMTLIB.Sym "to_real", [t]) = SOME (@{term "Real.real :: int => _"} $ t)
   32.20 +  | real_term_parser _ = NONE
   32.21 +
   32.22 +fun abstract abs t =
   32.23 +  (case t of
   32.24 +    (c as @{term "inverse_class.divide :: real => _"}) $ t1 $ t2 =>
   32.25 +      abs t1 ##>> abs t2 #>> (fn (u1, u2) => SOME (c $ u1 $ u2))
   32.26 +  | (c as @{term "Real.real :: int => _"}) $ t =>
   32.27 +      abs t #>> (fn u => SOME (c $ u))
   32.28 +  | _ => pair NONE)
   32.29 +
   32.30 +val _ = Theory.setup (Context.theory_map (
   32.31 +  SMTLIB_Proof.add_type_parser real_type_parser #>
   32.32 +  SMTLIB_Proof.add_term_parser real_term_parser #>
   32.33 +  Z3_Replay_Methods.add_arith_abstracter abstract))
   32.34 +
   32.35 +end;
    33.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.2 +++ b/src/HOL/Tools/SMT/z3_replay.ML	Thu Aug 28 00:40:38 2014 +0200
    33.3 @@ -0,0 +1,217 @@
    33.4 +(*  Title:      HOL/Tools/SMT/z3_replay.ML
    33.5 +    Author:     Sascha Boehme, TU Muenchen
    33.6 +    Author:     Jasmin Blanchette, TU Muenchen
    33.7 +
    33.8 +Z3 proof parsing and replay.
    33.9 +*)
   33.10 +
   33.11 +signature Z3_REPLAY =
   33.12 +sig
   33.13 +  val parse_proof: Proof.context -> SMT_Translate.replay_data ->
   33.14 +    ((string * ATP_Problem_Generate.stature) * thm) list -> term list -> term -> string list ->
   33.15 +    SMT_Solver.parsed_proof
   33.16 +  val replay: Proof.context -> SMT_Translate.replay_data -> string list -> thm
   33.17 +end;
   33.18 +
   33.19 +structure Z3_Replay: Z3_REPLAY =
   33.20 +struct
   33.21 +
   33.22 +fun params_of t = Term.strip_qnt_vars @{const_name Pure.all} t
   33.23 +
   33.24 +fun varify ctxt thm =
   33.25 +  let
   33.26 +    val maxidx = Thm.maxidx_of thm + 1
   33.27 +    val vs = params_of (Thm.prop_of thm)
   33.28 +    val vars = map_index (fn (i, (n, T)) => Var ((n, i + maxidx), T)) vs
   33.29 +  in Drule.forall_elim_list (map (SMT_Util.certify ctxt) vars) thm end
   33.30 +
   33.31 +fun add_paramTs names t =
   33.32 +  fold2 (fn n => fn (_, T) => AList.update (op =) (n, T)) names (params_of t)
   33.33 +
   33.34 +fun new_fixes ctxt nTs =
   33.35 +  let
   33.36 +    val (ns, ctxt') = Variable.variant_fixes (replicate (length nTs) "") ctxt
   33.37 +    fun mk (n, T) n' = (n, SMT_Util.certify ctxt' (Free (n', T)))
   33.38 +  in (ctxt', Symtab.make (map2 mk nTs ns)) end
   33.39 +
   33.40 +fun forall_elim_term ct (Const (@{const_name Pure.all}, _) $ (a as Abs _)) =
   33.41 +      Term.betapply (a, Thm.term_of ct)
   33.42 +  | forall_elim_term _ qt = raise TERM ("forall_elim'", [qt])
   33.43 +
   33.44 +fun apply_fixes elim env = fold (elim o the o Symtab.lookup env)
   33.45 +
   33.46 +val apply_fixes_prem = uncurry o apply_fixes Thm.forall_elim
   33.47 +val apply_fixes_concl = apply_fixes forall_elim_term
   33.48 +
   33.49 +fun export_fixes env names = Drule.forall_intr_list (map (the o Symtab.lookup env) names)
   33.50 +
   33.51 +fun under_fixes f ctxt (prems, nthms) names concl =
   33.52 +  let
   33.53 +    val thms1 = map (varify ctxt) prems
   33.54 +    val (ctxt', env) =
   33.55 +      add_paramTs names concl []
   33.56 +      |> fold (uncurry add_paramTs o apsnd Thm.prop_of) nthms
   33.57 +      |> new_fixes ctxt
   33.58 +    val thms2 = map (apply_fixes_prem env) nthms
   33.59 +    val t = apply_fixes_concl env names concl
   33.60 +  in export_fixes env names (f ctxt' (thms1 @ thms2) t) end
   33.61 +
   33.62 +fun replay_thm ctxt assumed nthms (Z3_Proof.Z3_Step {id, rule, concl, fixes, is_fix_step, ...}) =
   33.63 +  if Z3_Proof.is_assumption rule then
   33.64 +    (case Inttab.lookup assumed id of
   33.65 +      SOME (_, thm) => thm
   33.66 +    | NONE => Thm.assume (SMT_Util.certify ctxt concl))
   33.67 +  else
   33.68 +    under_fixes (Z3_Replay_Methods.method_for rule) ctxt
   33.69 +      (if is_fix_step then (map snd nthms, []) else ([], nthms)) fixes concl
   33.70 +
   33.71 +fun replay_step ctxt assumed (step as Z3_Proof.Z3_Step {id, prems, fixes, ...}) proofs =
   33.72 +  let val nthms = map (the o Inttab.lookup proofs) prems
   33.73 +  in Inttab.update (id, (fixes, replay_thm ctxt assumed nthms step)) proofs end
   33.74 +
   33.75 +local
   33.76 +  val remove_trigger = mk_meta_eq @{thm trigger_def}
   33.77 +  val remove_fun_app = mk_meta_eq @{thm fun_app_def}
   33.78 +
   33.79 +  fun rewrite_conv _ [] = Conv.all_conv
   33.80 +    | rewrite_conv ctxt eqs = Simplifier.full_rewrite (empty_simpset ctxt addsimps eqs)
   33.81 +
   33.82 +  val prep_rules = [@{thm Let_def}, remove_trigger, remove_fun_app, Z3_Replay_Literals.rewrite_true]
   33.83 +
   33.84 +  fun rewrite _ [] = I
   33.85 +    | rewrite ctxt eqs = Conv.fconv_rule (rewrite_conv ctxt eqs)
   33.86 +
   33.87 +  fun lookup_assm assms_net ct =
   33.88 +    Z3_Replay_Util.net_instances assms_net ct
   33.89 +    |> map (fn ithm as (_, thm) => (ithm, Thm.cprop_of thm aconvc ct))
   33.90 +in
   33.91 +
   33.92 +fun add_asserted outer_ctxt rewrite_rules assms steps ctxt =
   33.93 +  let
   33.94 +    val eqs = map (rewrite ctxt [Z3_Replay_Literals.rewrite_true]) rewrite_rules
   33.95 +    val eqs' = union Thm.eq_thm eqs prep_rules
   33.96 +
   33.97 +    val assms_net =
   33.98 +      assms
   33.99 +      |> map (apsnd (rewrite ctxt eqs'))
  33.100 +      |> map (apsnd (Conv.fconv_rule Thm.eta_conversion))
  33.101 +      |> Z3_Replay_Util.thm_net_of snd
  33.102 +
  33.103 +    fun revert_conv ctxt = rewrite_conv ctxt eqs' then_conv Thm.eta_conversion
  33.104 +
  33.105 +    fun assume thm ctxt =
  33.106 +      let
  33.107 +        val ct = Thm.cprem_of thm 1
  33.108 +        val (thm', ctxt') = yield_singleton Assumption.add_assumes ct ctxt
  33.109 +      in (thm' RS thm, ctxt') end
  33.110 +
  33.111 +    fun add1 id fixes thm1 ((i, th), exact) ((iidths, thms), (ctxt, ptab)) =
  33.112 +      let
  33.113 +        val (thm, ctxt') = if exact then (Thm.implies_elim thm1 th, ctxt) else assume thm1 ctxt
  33.114 +        val thms' = if exact then thms else th :: thms
  33.115 +      in (((i, (id, th)) :: iidths, thms'), (ctxt', Inttab.update (id, (fixes, thm)) ptab)) end
  33.116 +
  33.117 +    fun add (Z3_Proof.Z3_Step {id, rule, concl, fixes, ...})
  33.118 +        (cx as ((iidths, thms), (ctxt, ptab))) =
  33.119 +      if Z3_Proof.is_assumption rule andalso rule <> Z3_Proof.Hypothesis then
  33.120 +        let
  33.121 +          val ct = SMT_Util.certify ctxt concl
  33.122 +          val thm1 = Thm.trivial ct |> Conv.fconv_rule (Conv.arg1_conv (revert_conv outer_ctxt))
  33.123 +          val thm2 = singleton (Variable.export ctxt outer_ctxt) thm1
  33.124 +        in
  33.125 +          (case lookup_assm assms_net (Thm.cprem_of thm2 1) of
  33.126 +            [] =>
  33.127 +              let val (thm, ctxt') = assume thm1 ctxt
  33.128 +              in ((iidths, thms), (ctxt', Inttab.update (id, (fixes, thm)) ptab)) end
  33.129 +          | ithms => fold (add1 id fixes thm1) ithms cx)
  33.130 +        end
  33.131 +      else
  33.132 +        cx
  33.133 +  in fold add steps (([], []), (ctxt, Inttab.empty)) end
  33.134 +
  33.135 +end
  33.136 +
  33.137 +(* |- (EX x. P x) = P c     |- ~ (ALL x. P x) = ~ P c *)
  33.138 +local
  33.139 +  val sk_rules = @{lemma
  33.140 +    "c = (SOME x. P x) ==> (EX x. P x) = P c"
  33.141 +    "c = (SOME x. ~ P x) ==> (~ (ALL x. P x)) = (~ P c)"
  33.142 +    by (metis someI_ex)+}
  33.143 +in
  33.144 +
  33.145 +fun discharge_sk_tac i st =
  33.146 +  (rtac @{thm trans} i
  33.147 +   THEN resolve_tac sk_rules i
  33.148 +   THEN (rtac @{thm refl} ORELSE' discharge_sk_tac) (i+1)
  33.149 +   THEN rtac @{thm refl} i) st
  33.150 +
  33.151 +end
  33.152 +
  33.153 +fun make_discharge_rules rules = rules @ [@{thm allI}, @{thm refl}, @{thm reflexive},
  33.154 +  Z3_Replay_Literals.true_thm]
  33.155 +
  33.156 +val intro_def_rules = @{lemma
  33.157 +  "(~ P | P) & (P | ~ P)"
  33.158 +  "(P | ~ P) & (~ P | P)"
  33.159 +  by fast+}
  33.160 +
  33.161 +fun discharge_assms_tac rules =
  33.162 +  REPEAT (HEADGOAL (resolve_tac (intro_def_rules @ rules) ORELSE' SOLVED' discharge_sk_tac))
  33.163 +
  33.164 +fun discharge_assms ctxt rules thm =
  33.165 +  (if Thm.nprems_of thm = 0 then
  33.166 +     thm
  33.167 +   else
  33.168 +     (case Seq.pull (discharge_assms_tac rules thm) of
  33.169 +       SOME (thm', _) => thm'
  33.170 +     | NONE => raise THM ("failed to discharge premise", 1, [thm])))
  33.171 +  |> Goal.norm_result ctxt
  33.172 +
  33.173 +fun discharge rules outer_ctxt inner_ctxt =
  33.174 +  singleton (Proof_Context.export inner_ctxt outer_ctxt)
  33.175 +  #> discharge_assms outer_ctxt (make_discharge_rules rules)
  33.176 +
  33.177 +fun parse_proof outer_ctxt
  33.178 +    ({context = ctxt, typs, terms, ll_defs, rewrite_rules, assms} : SMT_Translate.replay_data)
  33.179 +    xfacts prems concl output =
  33.180 +  let
  33.181 +    val (steps, ctxt2) = Z3_Proof.parse typs terms output ctxt
  33.182 +    val ((iidths, _), _) = add_asserted outer_ctxt rewrite_rules assms steps ctxt2
  33.183 +
  33.184 +    fun id_of_index i = the_default ~1 (Option.map fst (AList.lookup (op =) iidths i))
  33.185 +
  33.186 +    val conjecture_i = 0
  33.187 +    val prems_i = 1
  33.188 +    val facts_i = prems_i + length prems
  33.189 +
  33.190 +    val conjecture_id = id_of_index conjecture_i
  33.191 +    val prem_ids = map id_of_index (prems_i upto facts_i - 1)
  33.192 +    val helper_ids = map_filter (try (fn (~1, idth) => idth)) iidths
  33.193 +    val fact_ids = map_filter (fn (i, (id, _)) => try (apsnd (nth xfacts)) (id, i - facts_i)) iidths
  33.194 +    val fact_helper_ts =
  33.195 +      map (fn (_, th) => (ATP_Util.short_thm_name ctxt th, prop_of th)) helper_ids @
  33.196 +      map (fn (_, ((s, _), th)) => (s, prop_of th)) fact_ids
  33.197 +    val fact_helper_ids =
  33.198 +      map (apsnd (ATP_Util.short_thm_name ctxt)) helper_ids @ map (apsnd (fst o fst)) fact_ids
  33.199 +  in
  33.200 +    {outcome = NONE, fact_ids = fact_ids,
  33.201 +     atp_proof = fn () => Z3_Isar.atp_proof_of_z3_proof ctxt ll_defs rewrite_rules prems concl
  33.202 +       fact_helper_ts prem_ids conjecture_id fact_helper_ids steps}
  33.203 +  end
  33.204 +
  33.205 +fun replay outer_ctxt
  33.206 +    ({context = ctxt, typs, terms, rewrite_rules, assms, ...} : SMT_Translate.replay_data) output =
  33.207 +  let
  33.208 +    val (steps, ctxt2) = Z3_Proof.parse typs terms output ctxt
  33.209 +    val ((_, rules), (ctxt3, assumed)) = add_asserted outer_ctxt rewrite_rules assms steps ctxt2
  33.210 +    val ctxt4 =
  33.211 +      ctxt3
  33.212 +      |> put_simpset (Z3_Replay_Util.make_simpset ctxt3 [])
  33.213 +      |> Config.put SAT.solver (Config.get ctxt3 SMT_Config.sat_solver)
  33.214 +    val proofs = fold (replay_step ctxt4 assumed) steps assumed
  33.215 +    val (_, Z3_Proof.Z3_Step {id, ...}) = split_last steps
  33.216 +  in
  33.217 +    Inttab.lookup proofs id |> the |> snd |> discharge rules outer_ctxt ctxt4
  33.218 +  end
  33.219 +
  33.220 +end;
    34.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.2 +++ b/src/HOL/Tools/SMT/z3_replay_literals.ML	Thu Aug 28 00:40:38 2014 +0200
    34.3 @@ -0,0 +1,351 @@
    34.4 +(*  Title:      HOL/Tools/SMT/z3_replay_literals.ML
    34.5 +    Author:     Sascha Boehme, TU Muenchen
    34.6 +
    34.7 +Proof tools related to conjunctions and disjunctions.
    34.8 +*)
    34.9 +
   34.10 +signature Z3_REPLAY_LITERALS =
   34.11 +sig
   34.12 +  (*literal table*)
   34.13 +  type littab = thm Termtab.table
   34.14 +  val make_littab: thm list -> littab
   34.15 +  val insert_lit: thm -> littab -> littab
   34.16 +  val delete_lit: thm -> littab -> littab
   34.17 +  val lookup_lit: littab -> term -> thm option
   34.18 +  val get_first_lit: (term -> bool) -> littab -> thm option
   34.19 +
   34.20 +  (*rules*)
   34.21 +  val true_thm: thm
   34.22 +  val rewrite_true: thm
   34.23 +
   34.24 +  (*properties*)
   34.25 +  val is_conj: term -> bool
   34.26 +  val is_disj: term -> bool
   34.27 +  val exists_lit: bool -> (term -> bool) -> term -> bool
   34.28 +  val negate: cterm -> cterm
   34.29 +
   34.30 +  (*proof tools*)
   34.31 +  val explode: bool -> bool -> bool -> term list -> thm -> thm list
   34.32 +  val join: bool -> littab -> term -> thm
   34.33 +  val prove_conj_disj_eq: cterm -> thm
   34.34 +end;
   34.35 +
   34.36 +structure Z3_Replay_Literals: Z3_REPLAY_LITERALS =
   34.37 +struct
   34.38 +
   34.39 +(* literal table *)
   34.40 +
   34.41 +type littab = thm Termtab.table
   34.42 +
   34.43 +fun make_littab thms = fold (Termtab.update o `SMT_Util.prop_of) thms Termtab.empty
   34.44 +
   34.45 +fun insert_lit thm = Termtab.update (`SMT_Util.prop_of thm)
   34.46 +fun delete_lit thm = Termtab.delete (SMT_Util.prop_of thm)
   34.47 +fun lookup_lit lits = Termtab.lookup lits
   34.48 +fun get_first_lit f =
   34.49 +  Termtab.get_first (fn (t, thm) => if f t then SOME thm else NONE)
   34.50 +
   34.51 +
   34.52 +(* rules *)
   34.53 +
   34.54 +val true_thm = @{lemma "~False" by simp}
   34.55 +val rewrite_true = @{lemma "True == ~ False" by simp}
   34.56 +
   34.57 +
   34.58 +(* properties and term operations *)
   34.59 +
   34.60 +val is_neg = (fn @{const Not} $ _ => true | _ => false)
   34.61 +fun is_neg' f = (fn @{const Not} $ t => f t | _ => false)
   34.62 +val is_dneg = is_neg' is_neg
   34.63 +val is_conj = (fn @{const HOL.conj} $ _ $ _ => true | _ => false)
   34.64 +val is_disj = (fn @{const HOL.disj} $ _ $ _ => true | _ => false)
   34.65 +
   34.66 +fun dest_disj_term' f = (fn
   34.67 +    @{const Not} $ (@{const HOL.disj} $ t $ u) => SOME (f t, f u)
   34.68 +  | _ => NONE)
   34.69 +
   34.70 +val dest_conj_term = (fn @{const HOL.conj} $ t $ u => SOME (t, u) | _ => NONE)
   34.71 +val dest_disj_term =
   34.72 +  dest_disj_term' (fn @{const Not} $ t => t | t => @{const Not} $ t)
   34.73 +
   34.74 +fun exists_lit is_conj P =
   34.75 +  let
   34.76 +    val dest = if is_conj then dest_conj_term else dest_disj_term
   34.77 +    fun exists t = P t orelse
   34.78 +      (case dest t of
   34.79 +        SOME (t1, t2) => exists t1 orelse exists t2
   34.80 +      | NONE => false)
   34.81 +  in exists end
   34.82 +
   34.83 +val negate = Thm.apply (Thm.cterm_of @{theory} @{const Not})
   34.84 +
   34.85 +
   34.86 +(* proof tools *)
   34.87 +
   34.88 +(** explosion of conjunctions and disjunctions **)
   34.89 +
   34.90 +local
   34.91 +  val precomp = Z3_Replay_Util.precompose2
   34.92 +
   34.93 +  fun destc ct = Thm.dest_binop (Thm.dest_arg ct)
   34.94 +  val dest_conj1 = precomp destc @{thm conjunct1}
   34.95 +  val dest_conj2 = precomp destc @{thm conjunct2}
   34.96 +  fun dest_conj_rules t =
   34.97 +    dest_conj_term t |> Option.map (K (dest_conj1, dest_conj2))
   34.98 +
   34.99 +  fun destd f ct = f (Thm.dest_binop (Thm.dest_arg (Thm.dest_arg ct)))
  34.100 +  val dn1 = apfst Thm.dest_arg and dn2 = apsnd Thm.dest_arg
  34.101 +  val dest_disj1 = precomp (destd I) @{lemma "~(P | Q) ==> ~P" by fast}
  34.102 +  val dest_disj2 = precomp (destd dn1) @{lemma "~(~P | Q) ==> P" by fast}
  34.103 +  val dest_disj3 = precomp (destd I) @{lemma "~(P | Q) ==> ~Q" by fast}
  34.104 +  val dest_disj4 = precomp (destd dn2) @{lemma "~(P | ~Q) ==> Q" by fast}
  34.105 +
  34.106 +  fun dest_disj_rules t =
  34.107 +    (case dest_disj_term' is_neg t of
  34.108 +      SOME (true, true) => SOME (dest_disj2, dest_disj4)
  34.109 +    | SOME (true, false) => SOME (dest_disj2, dest_disj3)
  34.110 +    | SOME (false, true) => SOME (dest_disj1, dest_disj4)
  34.111 +    | SOME (false, false) => SOME (dest_disj1, dest_disj3)
  34.112 +    | NONE => NONE)
  34.113 +
  34.114 +  fun destn ct = [Thm.dest_arg (Thm.dest_arg (Thm.dest_arg ct))]
  34.115 +  val dneg_rule = Z3_Replay_Util.precompose destn @{thm notnotD}
  34.116 +in
  34.117 +
  34.118 +(*
  34.119 +  explode a term into literals and collect all rules to be able to deduce
  34.120 +  particular literals afterwards
  34.121 +*)
  34.122 +fun explode_term is_conj =
  34.123 +  let
  34.124 +    val dest = if is_conj then dest_conj_term else dest_disj_term
  34.125 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  34.126 +
  34.127 +    fun add (t, rs) = Termtab.map_default (t, rs)
  34.128 +      (fn rs' => if length rs' < length rs then rs' else rs)
  34.129 +
  34.130 +    fun explode1 rules t =
  34.131 +      (case dest t of
  34.132 +        SOME (t1, t2) =>
  34.133 +          let val (rule1, rule2) = the (dest_rules t)
  34.134 +          in
  34.135 +            explode1 (rule1 :: rules) t1 #>
  34.136 +            explode1 (rule2 :: rules) t2 #>
  34.137 +            add (t, rev rules)
  34.138 +          end
  34.139 +      | NONE => add (t, rev rules))
  34.140 +
  34.141 +    fun explode0 (@{const Not} $ (@{const Not} $ t)) =
  34.142 +          Termtab.make [(t, [dneg_rule])]
  34.143 +      | explode0 t = explode1 [] t Termtab.empty
  34.144 +
  34.145 +  in explode0 end
  34.146 +
  34.147 +(*
  34.148 +  extract a literal by applying previously collected rules
  34.149 +*)
  34.150 +fun extract_lit thm rules = fold Z3_Replay_Util.compose rules thm
  34.151 +
  34.152 +
  34.153 +(*
  34.154 +  explode a theorem into its literals
  34.155 +*)
  34.156 +fun explode is_conj full keep_intermediate stop_lits =
  34.157 +  let
  34.158 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  34.159 +    val tab = fold (Termtab.update o rpair ()) stop_lits Termtab.empty
  34.160 +
  34.161 +    fun explode1 thm =
  34.162 +      if Termtab.defined tab (SMT_Util.prop_of thm) then cons thm
  34.163 +      else
  34.164 +        (case dest_rules (SMT_Util.prop_of thm) of
  34.165 +          SOME (rule1, rule2) =>
  34.166 +            explode2 rule1 thm #>
  34.167 +            explode2 rule2 thm #>
  34.168 +            keep_intermediate ? cons thm
  34.169 +        | NONE => cons thm)
  34.170 +
  34.171 +    and explode2 dest_rule thm =
  34.172 +      if full orelse
  34.173 +        exists_lit is_conj (Termtab.defined tab) (SMT_Util.prop_of thm)
  34.174 +      then explode1 (Z3_Replay_Util.compose dest_rule thm)
  34.175 +      else cons (Z3_Replay_Util.compose dest_rule thm)
  34.176 +
  34.177 +    fun explode0 thm =
  34.178 +      if not is_conj andalso is_dneg (SMT_Util.prop_of thm)
  34.179 +      then [Z3_Replay_Util.compose dneg_rule thm]
  34.180 +      else explode1 thm []
  34.181 +
  34.182 +  in explode0 end
  34.183 +
  34.184 +end
  34.185 +
  34.186 +
  34.187 +(** joining of literals to conjunctions or disjunctions **)
  34.188 +
  34.189 +local
  34.190 +  fun on_cprem i f thm = f (Thm.cprem_of thm i)
  34.191 +  fun on_cprop f thm = f (Thm.cprop_of thm)
  34.192 +  fun precomp2 f g thm = (on_cprem 1 f thm, on_cprem 2 g thm, f, g, thm)
  34.193 +  fun comp2 (cv1, cv2, f, g, rule) thm1 thm2 =
  34.194 +    Thm.instantiate ([], [(cv1, on_cprop f thm1), (cv2, on_cprop g thm2)]) rule
  34.195 +    |> Z3_Replay_Util.discharge thm1 |> Z3_Replay_Util.discharge thm2
  34.196 +
  34.197 +  fun d1 ct = Thm.dest_arg ct and d2 ct = Thm.dest_arg (Thm.dest_arg ct)
  34.198 +
  34.199 +  val conj_rule = precomp2 d1 d1 @{thm conjI}
  34.200 +  fun comp_conj ((_, thm1), (_, thm2)) = comp2 conj_rule thm1 thm2
  34.201 +
  34.202 +  val disj1 = precomp2 d2 d2 @{lemma "~P ==> ~Q ==> ~(P | Q)" by fast}
  34.203 +  val disj2 = precomp2 d2 d1 @{lemma "~P ==> Q ==> ~(P | ~Q)" by fast}
  34.204 +  val disj3 = precomp2 d1 d2 @{lemma "P ==> ~Q ==> ~(~P | Q)" by fast}
  34.205 +  val disj4 = precomp2 d1 d1 @{lemma "P ==> Q ==> ~(~P | ~Q)" by fast}
  34.206 +
  34.207 +  fun comp_disj ((false, thm1), (false, thm2)) = comp2 disj1 thm1 thm2
  34.208 +    | comp_disj ((false, thm1), (true, thm2)) = comp2 disj2 thm1 thm2
  34.209 +    | comp_disj ((true, thm1), (false, thm2)) = comp2 disj3 thm1 thm2
  34.210 +    | comp_disj ((true, thm1), (true, thm2)) = comp2 disj4 thm1 thm2
  34.211 +
  34.212 +  fun dest_conj (@{const HOL.conj} $ t $ u) = ((false, t), (false, u))
  34.213 +    | dest_conj t = raise TERM ("dest_conj", [t])
  34.214 +
  34.215 +  val neg = (fn @{const Not} $ t => (true, t) | t => (false, @{const Not} $ t))
  34.216 +  fun dest_disj (@{const Not} $ (@{const HOL.disj} $ t $ u)) = (neg t, neg u)
  34.217 +    | dest_disj t = raise TERM ("dest_disj", [t])
  34.218 +
  34.219 +  val precomp = Z3_Replay_Util.precompose
  34.220 +  val dnegE = precomp (single o d2 o d1) @{thm notnotD}
  34.221 +  val dnegI = precomp (single o d1) @{lemma "P ==> ~~P" by fast}
  34.222 +  fun as_dneg f t = f (@{const Not} $ (@{const Not} $ t))
  34.223 +
  34.224 +  val precomp2 = Z3_Replay_Util.precompose2
  34.225 +  fun dni f = apsnd f o Thm.dest_binop o f o d1
  34.226 +  val negIffE = precomp2 (dni d1) @{lemma "~(P = (~Q)) ==> Q = P" by fast}
  34.227 +  val negIffI = precomp2 (dni I) @{lemma "P = Q ==> ~(Q = (~P))" by fast}
  34.228 +  val iff_const = @{const HOL.eq (bool)}
  34.229 +  fun as_negIff f (@{const HOL.eq (bool)} $ t $ u) =
  34.230 +        f (@{const Not} $ (iff_const $ u $ (@{const Not} $ t)))
  34.231 +    | as_negIff _ _ = NONE
  34.232 +in
  34.233 +
  34.234 +fun join is_conj littab t =
  34.235 +  let
  34.236 +    val comp = if is_conj then comp_conj else comp_disj
  34.237 +    val dest = if is_conj then dest_conj else dest_disj
  34.238 +
  34.239 +    val lookup = lookup_lit littab
  34.240 +
  34.241 +    fun lookup_rule t =
  34.242 +      (case t of
  34.243 +        @{const Not} $ (@{const Not} $ t) => (Z3_Replay_Util.compose dnegI, lookup t)
  34.244 +      | @{const Not} $ (@{const HOL.eq (bool)} $ t $ (@{const Not} $ u)) =>
  34.245 +          (Z3_Replay_Util.compose negIffI, lookup (iff_const $ u $ t))
  34.246 +      | @{const Not} $ ((eq as Const (@{const_name HOL.eq}, _)) $ t $ u) =>
  34.247 +          let fun rewr lit = lit COMP @{thm not_sym}
  34.248 +          in (rewr, lookup (@{const Not} $ (eq $ u $ t))) end
  34.249 +      | _ =>
  34.250 +          (case as_dneg lookup t of
  34.251 +            NONE => (Z3_Replay_Util.compose negIffE, as_negIff lookup t)
  34.252 +          | x => (Z3_Replay_Util.compose dnegE, x)))
  34.253 +
  34.254 +    fun join1 (s, t) =
  34.255 +      (case lookup t of
  34.256 +        SOME lit => (s, lit)
  34.257 +      | NONE =>
  34.258 +          (case lookup_rule t of
  34.259 +            (rewrite, SOME lit) => (s, rewrite lit)
  34.260 +          | (_, NONE) => (s, comp (pairself join1 (dest t)))))
  34.261 +
  34.262 +  in snd (join1 (if is_conj then (false, t) else (true, t))) end
  34.263 +
  34.264 +end
  34.265 +
  34.266 +
  34.267 +(** proving equality of conjunctions or disjunctions **)
  34.268 +
  34.269 +fun iff_intro thm1 thm2 = thm2 COMP (thm1 COMP @{thm iffI})
  34.270 +
  34.271 +local
  34.272 +  val cp1 = @{lemma "(~P) = (~Q) ==> P = Q" by simp}
  34.273 +  val cp2 = @{lemma "(~P) = Q ==> P = (~Q)" by fastforce}
  34.274 +  val cp3 = @{lemma "P = (~Q) ==> (~P) = Q" by simp}
  34.275 +in
  34.276 +fun contrapos1 prove (ct, cu) = prove (negate ct, negate cu) COMP cp1
  34.277 +fun contrapos2 prove (ct, cu) = prove (negate ct, Thm.dest_arg cu) COMP cp2
  34.278 +fun contrapos3 prove (ct, cu) = prove (Thm.dest_arg ct, negate cu) COMP cp3
  34.279 +end
  34.280 +
  34.281 +local
  34.282 +  val contra_rule = @{lemma "P ==> ~P ==> False" by (rule notE)}
  34.283 +  fun contra_left conj thm =
  34.284 +    let
  34.285 +      val rules = explode_term conj (SMT_Util.prop_of thm)
  34.286 +      fun contra_lits (t, rs) =
  34.287 +        (case t of
  34.288 +          @{const Not} $ u => Termtab.lookup rules u |> Option.map (pair rs)
  34.289 +        | _ => NONE)
  34.290 +    in
  34.291 +      (case Termtab.lookup rules @{const False} of
  34.292 +        SOME rs => extract_lit thm rs
  34.293 +      | NONE =>
  34.294 +          the (Termtab.get_first contra_lits rules)
  34.295 +          |> pairself (extract_lit thm)
  34.296 +          |> (fn (nlit, plit) => nlit COMP (plit COMP contra_rule)))
  34.297 +    end
  34.298 +
  34.299 +  val falseE_v = Thm.dest_arg (Thm.dest_arg (Thm.cprop_of @{thm FalseE}))
  34.300 +  fun contra_right ct = Thm.instantiate ([], [(falseE_v, ct)]) @{thm FalseE}
  34.301 +in
  34.302 +
  34.303 +fun contradict conj ct =
  34.304 +  iff_intro (Z3_Replay_Util.under_assumption (contra_left conj) ct) (contra_right ct)
  34.305 +
  34.306 +end
  34.307 +
  34.308 +local
  34.309 +  fun prove_eq l r (cl, cr) =
  34.310 +    let
  34.311 +      fun explode' is_conj = explode is_conj true (l <> r) []
  34.312 +      fun make_tab is_conj thm = make_littab (true_thm :: explode' is_conj thm)
  34.313 +      fun prove is_conj ct tab = join is_conj tab (Thm.term_of ct)
  34.314 +
  34.315 +      val thm1 = Z3_Replay_Util.under_assumption (prove r cr o make_tab l) cl
  34.316 +      val thm2 = Z3_Replay_Util.under_assumption (prove l cl o make_tab r) cr
  34.317 +    in iff_intro thm1 thm2 end
  34.318 +
  34.319 +  datatype conj_disj = CONJ | DISJ | NCON | NDIS
  34.320 +  fun kind_of t =
  34.321 +    if is_conj t then SOME CONJ
  34.322 +    else if is_disj t then SOME DISJ
  34.323 +    else if is_neg' is_conj t then SOME NCON
  34.324 +    else if is_neg' is_disj t then SOME NDIS
  34.325 +    else NONE
  34.326 +in
  34.327 +
  34.328 +fun prove_conj_disj_eq ct =
  34.329 +  let val cp as (cl, cr) = Thm.dest_binop (Thm.dest_arg ct)
  34.330 +  in
  34.331 +    (case (kind_of (Thm.term_of cl), Thm.term_of cr) of
  34.332 +      (SOME CONJ, @{const False}) => contradict true cl
  34.333 +    | (SOME DISJ, @{const Not} $ @{const False}) =>
  34.334 +        contrapos2 (contradict false o fst) cp
  34.335 +    | (kl, _) =>
  34.336 +        (case (kl, kind_of (Thm.term_of cr)) of
  34.337 +          (SOME CONJ, SOME CONJ) => prove_eq true true cp
  34.338 +        | (SOME CONJ, SOME NDIS) => prove_eq true false cp
  34.339 +        | (SOME CONJ, _) => prove_eq true true cp
  34.340 +        | (SOME DISJ, SOME DISJ) => contrapos1 (prove_eq false false) cp
  34.341 +        | (SOME DISJ, SOME NCON) => contrapos2 (prove_eq false true) cp
  34.342 +        | (SOME DISJ, _) => contrapos1 (prove_eq false false) cp
  34.343 +        | (SOME NCON, SOME NCON) => contrapos1 (prove_eq true true) cp
  34.344 +        | (SOME NCON, SOME DISJ) => contrapos3 (prove_eq true false) cp
  34.345 +        | (SOME NCON, NONE) => contrapos3 (prove_eq true false) cp
  34.346 +        | (SOME NDIS, SOME NDIS) => prove_eq false false cp
  34.347 +        | (SOME NDIS, SOME CONJ) => prove_eq false true cp
  34.348 +        | (SOME NDIS, NONE) => prove_eq false true cp
  34.349 +        | _ => raise CTERM ("prove_conj_disj_eq", [ct])))
  34.350 +  end
  34.351 +
  34.352 +end
  34.353 +
  34.354 +end;
    35.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.2 +++ b/src/HOL/Tools/SMT/z3_replay_methods.ML	Thu Aug 28 00:40:38 2014 +0200
    35.3 @@ -0,0 +1,666 @@
    35.4 +(*  Title:      HOL/Tools/SMT/z3_replay_methods.ML
    35.5 +    Author:     Sascha Boehme, TU Muenchen
    35.6 +    Author:     Jasmin Blanchette, TU Muenchen
    35.7 +
    35.8 +Proof methods for replaying Z3 proofs.
    35.9 +*)
   35.10 +
   35.11 +signature Z3_REPLAY_METHODS =
   35.12 +sig
   35.13 +  (*abstraction*)
   35.14 +  type abs_context = int * term Termtab.table
   35.15 +  type 'a abstracter = term -> abs_context -> 'a * abs_context
   35.16 +  val add_arith_abstracter: (term abstracter -> term option abstracter) ->
   35.17 +    Context.generic -> Context.generic
   35.18 +
   35.19 +  (*theory lemma methods*)
   35.20 +  type th_lemma_method = Proof.context -> thm list -> term -> thm
   35.21 +  val add_th_lemma_method: string * th_lemma_method -> Context.generic ->
   35.22 +    Context.generic
   35.23 +
   35.24 +  (*methods for Z3 proof rules*)
   35.25 +  type z3_method = Proof.context -> thm list -> term -> thm
   35.26 +  val true_axiom: z3_method
   35.27 +  val mp: z3_method
   35.28 +  val refl: z3_method
   35.29 +  val symm: z3_method
   35.30 +  val trans: z3_method
   35.31 +  val cong: z3_method
   35.32 +  val quant_intro: z3_method
   35.33 +  val distrib: z3_method
   35.34 +  val and_elim: z3_method
   35.35 +  val not_or_elim: z3_method
   35.36 +  val rewrite: z3_method
   35.37 +  val rewrite_star: z3_method
   35.38 +  val pull_quant: z3_method
   35.39 +  val push_quant: z3_method
   35.40 +  val elim_unused: z3_method
   35.41 +  val dest_eq_res: z3_method
   35.42 +  val quant_inst: z3_method
   35.43 +  val lemma: z3_method
   35.44 +  val unit_res: z3_method
   35.45 +  val iff_true: z3_method
   35.46 +  val iff_false: z3_method
   35.47 +  val comm: z3_method
   35.48 +  val def_axiom: z3_method
   35.49 +  val apply_def: z3_method
   35.50 +  val iff_oeq: z3_method
   35.51 +  val nnf_pos: z3_method
   35.52 +  val nnf_neg: z3_method
   35.53 +  val mp_oeq: z3_method
   35.54 +  val th_lemma: string -> z3_method
   35.55 +  val method_for: Z3_Proof.z3_rule -> z3_method
   35.56 +end;
   35.57 +
   35.58 +structure Z3_Replay_Methods: Z3_REPLAY_METHODS =
   35.59 +struct
   35.60 +
   35.61 +type z3_method = Proof.context -> thm list -> term -> thm
   35.62 +
   35.63 +
   35.64 +(* utility functions *)
   35.65 +
   35.66 +fun trace ctxt f = SMT_Config.trace_msg ctxt f ()
   35.67 +
   35.68 +fun pretty_thm ctxt thm = Syntax.pretty_term ctxt (Thm.concl_of thm)
   35.69 +
   35.70 +fun pretty_goal ctxt msg rule thms t =
   35.71 +  let
   35.72 +    val full_msg = msg ^ ": " ^ quote (Z3_Proof.string_of_rule rule)
   35.73 +    val assms =
   35.74 +      if null thms then []
   35.75 +      else [Pretty.big_list "assumptions:" (map (pretty_thm ctxt) thms)]
   35.76 +    val concl = Pretty.big_list "proposition:" [Syntax.pretty_term ctxt t]
   35.77 +  in Pretty.big_list full_msg (assms @ [concl]) end
   35.78 +
   35.79 +fun replay_error ctxt msg rule thms t = error (Pretty.string_of (pretty_goal ctxt msg rule thms t))
   35.80 +
   35.81 +fun replay_rule_error ctxt = replay_error ctxt "Failed to replay Z3 proof step"
   35.82 +
   35.83 +fun trace_goal ctxt rule thms t =
   35.84 +  trace ctxt (fn () => Pretty.string_of (pretty_goal ctxt "Goal" rule thms t))
   35.85 +
   35.86 +fun as_prop (t as Const (@{const_name Trueprop}, _) $ _) = t
   35.87 +  | as_prop t = HOLogic.mk_Trueprop t
   35.88 +
   35.89 +fun dest_prop (Const (@{const_name Trueprop}, _) $ t) = t
   35.90 +  | dest_prop t = t
   35.91 +
   35.92 +fun dest_thm thm = dest_prop (Thm.concl_of thm)
   35.93 +
   35.94 +fun certify_prop ctxt t = SMT_Util.certify ctxt (as_prop t)
   35.95 +
   35.96 +fun try_provers ctxt rule [] thms t = replay_rule_error ctxt rule thms t
   35.97 +  | try_provers ctxt rule ((name, prover) :: named_provers) thms t =
   35.98 +      (case (trace ctxt (K ("Trying prover " ^ quote name)); try prover t) of
   35.99 +        SOME thm => thm
  35.100 +      | NONE => try_provers ctxt rule named_provers thms t)
  35.101 +
  35.102 +fun match ctxt pat t =
  35.103 +  (Vartab.empty, Vartab.empty)
  35.104 +  |> Pattern.first_order_match (Proof_Context.theory_of ctxt) (pat, t)
  35.105 +
  35.106 +fun gen_certify_inst sel mk cert ctxt thm t =
  35.107 +  let
  35.108 +    val inst = match ctxt (dest_thm thm) (dest_prop t)
  35.109 +    fun cert_inst (ix, (a, b)) = (cert (mk (ix, a)), cert b)
  35.110 +  in Vartab.fold (cons o cert_inst) (sel inst) [] end
  35.111 +
  35.112 +fun match_instantiateT ctxt t thm =
  35.113 +  if Term.exists_type (Term.exists_subtype Term.is_TVar) (dest_thm thm) then
  35.114 +    let val certT = Thm.ctyp_of (Proof_Context.theory_of ctxt)
  35.115 +    in Thm.instantiate (gen_certify_inst fst TVar certT ctxt thm t, []) thm end
  35.116 +  else thm
  35.117 +
  35.118 +fun match_instantiate ctxt t thm =
  35.119 +  let
  35.120 +    val cert = SMT_Util.certify ctxt
  35.121 +    val thm' = match_instantiateT ctxt t thm
  35.122 +  in Thm.instantiate ([], gen_certify_inst snd Var cert ctxt thm' t) thm' end
  35.123 +
  35.124 +fun apply_rule ctxt t =
  35.125 +  (case Z3_Replay_Rules.apply ctxt (certify_prop ctxt t) of
  35.126 +    SOME thm => thm
  35.127 +  | NONE => raise Fail "apply_rule")
  35.128 +
  35.129 +fun discharge _ [] thm = thm
  35.130 +  | discharge i (rule :: rules) thm = discharge (i + Thm.nprems_of rule) rules (rule RSN (i, thm))
  35.131 +
  35.132 +fun by_tac ctxt thms ns ts t tac =
  35.133 +  Goal.prove ctxt [] (map as_prop ts) (as_prop t)
  35.134 +    (fn {context, prems} => HEADGOAL (tac context prems))
  35.135 +  |> Drule.generalize ([], ns)
  35.136 +  |> discharge 1 thms
  35.137 +
  35.138 +fun prove ctxt t tac = by_tac ctxt [] [] [] t (K o tac)
  35.139 +
  35.140 +fun prop_tac ctxt prems =
  35.141 +  Method.insert_tac prems
  35.142 +  THEN' SUBGOAL (fn (prop, i) =>
  35.143 +    if Term.size_of_term prop > 100 then SAT.satx_tac ctxt i
  35.144 +    else (Classical.fast_tac ctxt ORELSE' Clasimp.force_tac ctxt) i)
  35.145 +
  35.146 +fun quant_tac ctxt = Blast.blast_tac ctxt
  35.147 +
  35.148 +
  35.149 +(* plug-ins *)
  35.150 +
  35.151 +type abs_context = int * term Termtab.table
  35.152 +
  35.153 +type 'a abstracter = term -> abs_context -> 'a * abs_context
  35.154 +
  35.155 +type th_lemma_method = Proof.context -> thm list -> term -> thm
  35.156 +
  35.157 +fun id_ord ((id1, _), (id2, _)) = int_ord (id1, id2)
  35.158 +
  35.159 +structure Plugins = Generic_Data
  35.160 +(
  35.161 +  type T =
  35.162 +    (int * (term abstracter -> term option abstracter)) list *
  35.163 +    th_lemma_method Symtab.table
  35.164 +  val empty = ([], Symtab.empty)
  35.165 +  val extend = I
  35.166 +  fun merge ((abss1, ths1), (abss2, ths2)) = (
  35.167 +    Ord_List.merge id_ord (abss1, abss2),
  35.168 +    Symtab.merge (K true) (ths1, ths2))
  35.169 +)
  35.170 +
  35.171 +fun add_arith_abstracter abs = Plugins.map (apfst (Ord_List.insert id_ord (serial (), abs)))
  35.172 +fun get_arith_abstracters ctxt = map snd (fst (Plugins.get (Context.Proof ctxt)))
  35.173 +
  35.174 +fun add_th_lemma_method method = Plugins.map (apsnd (Symtab.update_new method))
  35.175 +fun get_th_lemma_method ctxt = snd (Plugins.get (Context.Proof ctxt))
  35.176 +
  35.177 +
  35.178 +(* abstraction *)
  35.179 +
  35.180 +fun prove_abstract ctxt thms t tac f =
  35.181 +  let
  35.182 +    val ((prems, concl), (_, ts)) = f (1, Termtab.empty)
  35.183 +    val ns = Termtab.fold (fn (_, v) => cons (fst (Term.dest_Free v))) ts []
  35.184 +  in
  35.185 +    by_tac ctxt [] ns prems concl tac
  35.186 +    |> match_instantiate ctxt t
  35.187 +    |> discharge 1 thms
  35.188 +  end
  35.189 +
  35.190 +fun prove_abstract' ctxt t tac f =
  35.191 +  prove_abstract ctxt [] t tac (f #>> pair [])
  35.192 +
  35.193 +fun lookup_term (_, terms) t = Termtab.lookup terms t
  35.194 +
  35.195 +fun abstract_sub t f cx =
  35.196 +  (case lookup_term cx t of
  35.197 +    SOME v => (v, cx)
  35.198 +  | NONE => f cx)
  35.199 +
  35.200 +fun mk_fresh_free t (i, terms) =
  35.201 +  let val v = Free ("t" ^ string_of_int i, fastype_of t)
  35.202 +  in (v, (i + 1, Termtab.update (t, v) terms)) end
  35.203 +
  35.204 +fun apply_abstracters _ [] _ cx = (NONE, cx)
  35.205 +  | apply_abstracters abs (abstracter :: abstracters) t cx =
  35.206 +      (case abstracter abs t cx of
  35.207 +        (NONE, _) => apply_abstracters abs abstracters t cx
  35.208 +      | x as (SOME _, _) => x)
  35.209 +
  35.210 +fun abstract_term (t as _ $ _) = abstract_sub t (mk_fresh_free t)
  35.211 +  | abstract_term (t as Abs _) = abstract_sub t (mk_fresh_free t)
  35.212 +  | abstract_term t = pair t
  35.213 +
  35.214 +fun abstract_bin abs f t t1 t2 = abstract_sub t (abs t1 ##>> abs t2 #>> f)
  35.215 +
  35.216 +fun abstract_ter abs f t t1 t2 t3 =
  35.217 +  abstract_sub t (abs t1 ##>> abs t2 ##>> abs t3 #>> (Parse.triple1 #> f))
  35.218 +
  35.219 +fun abstract_lit (@{const HOL.Not} $ t) = abstract_term t #>> HOLogic.mk_not
  35.220 +  | abstract_lit t = abstract_term t
  35.221 +
  35.222 +fun abstract_not abs (t as @{const HOL.Not} $ t1) =
  35.223 +      abstract_sub t (abs t1 #>> HOLogic.mk_not)
  35.224 +  | abstract_not _ t = abstract_lit t
  35.225 +
  35.226 +fun abstract_conj (t as @{const HOL.conj} $ t1 $ t2) =
  35.227 +      abstract_bin abstract_conj HOLogic.mk_conj t t1 t2
  35.228 +  | abstract_conj t = abstract_lit t
  35.229 +
  35.230 +fun abstract_disj (t as @{const HOL.disj} $ t1 $ t2) =
  35.231 +      abstract_bin abstract_disj HOLogic.mk_disj t t1 t2
  35.232 +  | abstract_disj t = abstract_lit t
  35.233 +
  35.234 +fun abstract_prop (t as (c as @{const If (bool)}) $ t1 $ t2 $ t3) =
  35.235 +      abstract_ter abstract_prop (fn (t1, t2, t3) => c $ t1 $ t2 $ t3) t t1 t2 t3
  35.236 +  | abstract_prop (t as @{const HOL.disj} $ t1 $ t2) =
  35.237 +      abstract_bin abstract_prop HOLogic.mk_disj t t1 t2
  35.238 +  | abstract_prop (t as @{const HOL.conj} $ t1 $ t2) =
  35.239 +      abstract_bin abstract_prop HOLogic.mk_conj t t1 t2
  35.240 +  | abstract_prop (t as @{const HOL.implies} $ t1 $ t2) =
  35.241 +      abstract_bin abstract_prop HOLogic.mk_imp t t1 t2
  35.242 +  | abstract_prop (t as @{term "HOL.eq :: bool => _"} $ t1 $ t2) =
  35.243 +      abstract_bin abstract_prop HOLogic.mk_eq t t1 t2
  35.244 +  | abstract_prop t = abstract_not abstract_prop t
  35.245 +
  35.246 +fun abstract_arith ctxt u =
  35.247 +  let
  35.248 +    fun abs (t as (c as Const _) $ Abs (s, T, t')) =
  35.249 +          abstract_sub t (abs t' #>> (fn u' => c $ Abs (s, T, u')))
  35.250 +      | abs (t as (c as Const (@{const_name If}, _)) $ t1 $ t2 $ t3) =
  35.251 +          abstract_ter abs (fn (t1, t2, t3) => c $ t1 $ t2 $ t3) t t1 t2 t3
  35.252 +      | abs (t as @{const HOL.Not} $ t1) = abstract_sub t (abs t1 #>> HOLogic.mk_not)
  35.253 +      | abs (t as @{const HOL.disj} $ t1 $ t2) =
  35.254 +          abstract_sub t (abs t1 ##>> abs t2 #>> HOLogic.mk_disj)
  35.255 +      | abs (t as (c as Const (@{const_name uminus_class.uminus}, _)) $ t1) =
  35.256 +          abstract_sub t (abs t1 #>> (fn u => c $ u))
  35.257 +      | abs (t as (c as Const (@{const_name plus_class.plus}, _)) $ t1 $ t2) =
  35.258 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.259 +      | abs (t as (c as Const (@{const_name minus_class.minus}, _)) $ t1 $ t2) =
  35.260 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.261 +      | abs (t as (c as Const (@{const_name times_class.times}, _)) $ t1 $ t2) =
  35.262 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.263 +      | abs (t as (c as Const (@{const_name z3div}, _)) $ t1 $ t2) =
  35.264 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.265 +      | abs (t as (c as Const (@{const_name z3mod}, _)) $ t1 $ t2) =
  35.266 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.267 +      | abs (t as (c as Const (@{const_name HOL.eq}, _)) $ t1 $ t2) =
  35.268 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.269 +      | abs (t as (c as Const (@{const_name ord_class.less}, _)) $ t1 $ t2) =
  35.270 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.271 +      | abs (t as (c as Const (@{const_name ord_class.less_eq}, _)) $ t1 $ t2) =
  35.272 +          abstract_sub t (abs t1 ##>> abs t2 #>> (fn (u1, u2) => c $ u1 $ u2))
  35.273 +      | abs t = abstract_sub t (fn cx =>
  35.274 +          if can HOLogic.dest_number t then (t, cx)
  35.275 +          else
  35.276 +            (case apply_abstracters abs (get_arith_abstracters ctxt) t cx of
  35.277 +              (SOME u, cx') => (u, cx')
  35.278 +            | (NONE, _) => abstract_term t cx))
  35.279 +  in abs u end
  35.280 +
  35.281 +
  35.282 +(* truth axiom *)
  35.283 +
  35.284 +fun true_axiom _ _ _ = @{thm TrueI}
  35.285 +
  35.286 +
  35.287 +(* modus ponens *)
  35.288 +
  35.289 +fun mp _ [p, p_eq_q] _ = discharge 1 [p_eq_q, p] iffD1
  35.290 +  | mp ctxt thms t = replay_rule_error ctxt Z3_Proof.Modus_Ponens thms t
  35.291 +
  35.292 +val mp_oeq = mp
  35.293 +
  35.294 +
  35.295 +(* reflexivity *)
  35.296 +
  35.297 +fun refl ctxt _ t = match_instantiate ctxt t @{thm refl}
  35.298 +
  35.299 +
  35.300 +(* symmetry *)
  35.301 +
  35.302 +fun symm _ [thm] _ = thm RS @{thm sym}
  35.303 +  | symm ctxt thms t = replay_rule_error ctxt Z3_Proof.Reflexivity thms t
  35.304 +
  35.305 +
  35.306 +(* transitivity *)
  35.307 +
  35.308 +fun trans _ [thm1, thm2] _ = thm1 RSN (1, thm2 RSN (2, @{thm trans}))
  35.309 +  | trans ctxt thms t = replay_rule_error ctxt Z3_Proof.Transitivity thms t
  35.310 +
  35.311 +
  35.312 +(* congruence *)
  35.313 +
  35.314 +fun ctac prems i st = st |> (
  35.315 +  resolve_tac (@{thm refl} :: prems) i
  35.316 +  ORELSE (cong_tac i THEN ctac prems (i + 1) THEN ctac prems i))
  35.317 +
  35.318 +fun cong_basic ctxt thms t =
  35.319 +  let val st = Thm.trivial (certify_prop ctxt t)
  35.320 +  in
  35.321 +    (case Seq.pull (ctac thms 1 st) of
  35.322 +      SOME (thm, _) => thm
  35.323 +    | NONE => raise THM ("cong", 0, thms @ [st]))
  35.324 +  end
  35.325 +
  35.326 +val cong_dest_rules = @{lemma
  35.327 +  "(~ P | Q) & (P | ~ Q) ==> P = Q"
  35.328 +  "(P | ~ Q) & (~ P | Q) ==> P = Q"
  35.329 +  by fast+}
  35.330 +
  35.331 +fun cong_full ctxt thms t = prove ctxt t (fn ctxt' =>
  35.332 +  Method.insert_tac thms
  35.333 +  THEN' (Classical.fast_tac ctxt'
  35.334 +    ORELSE' dresolve_tac cong_dest_rules
  35.335 +    THEN' Classical.fast_tac ctxt'))
  35.336 +
  35.337 +fun cong ctxt thms = try_provers ctxt Z3_Proof.Monotonicity [
  35.338 +  ("basic", cong_basic ctxt thms),
  35.339 +  ("full", cong_full ctxt thms)] thms
  35.340 +
  35.341 +
  35.342 +(* quantifier introduction *)
  35.343 +
  35.344 +val quant_intro_rules = @{lemma
  35.345 +  "(!!x. P x = Q x) ==> (ALL x. P x) = (ALL x. Q x)"
  35.346 +  "(!!x. P x = Q x) ==> (EX x. P x) = (EX x. Q x)"
  35.347 +  "(!!x. (~ P x) = Q x) ==> (~ (EX x. P x)) = (ALL x. Q x)"
  35.348 +  "(!!x. (~ P x) = Q x) ==> (~ (ALL x. P x)) = (EX x. Q x)"
  35.349 +  by fast+}
  35.350 +
  35.351 +fun quant_intro ctxt [thm] t =
  35.352 +    prove ctxt t (K (REPEAT_ALL_NEW (resolve_tac (thm :: quant_intro_rules))))
  35.353 +  | quant_intro ctxt thms t = replay_rule_error ctxt Z3_Proof.Quant_Intro thms t
  35.354 +
  35.355 +
  35.356 +(* distributivity of conjunctions and disjunctions *)
  35.357 +
  35.358 +(* TODO: there are no tests with this proof rule *)
  35.359 +fun distrib ctxt _ t =
  35.360 +  prove_abstract' ctxt t prop_tac (abstract_prop (dest_prop t))
  35.361 +
  35.362 +
  35.363 +(* elimination of conjunctions *)
  35.364 +
  35.365 +fun and_elim ctxt [thm] t =
  35.366 +      prove_abstract ctxt [thm] t prop_tac (
  35.367 +        abstract_lit (dest_prop t) ##>>
  35.368 +        abstract_conj (dest_thm thm) #>>
  35.369 +        apfst single o swap)
  35.370 +  | and_elim ctxt thms t = replay_rule_error ctxt Z3_Proof.And_Elim thms t
  35.371 +
  35.372 +
  35.373 +(* elimination of negated disjunctions *)
  35.374 +
  35.375 +fun not_or_elim ctxt [thm] t =
  35.376 +      prove_abstract ctxt [thm] t prop_tac (
  35.377 +        abstract_lit (dest_prop t) ##>>
  35.378 +        abstract_not abstract_disj (dest_thm thm) #>>
  35.379 +        apfst single o swap)
  35.380 +  | not_or_elim ctxt thms t =
  35.381 +      replay_rule_error ctxt Z3_Proof.Not_Or_Elim thms t
  35.382 +
  35.383 +
  35.384 +(* rewriting *)
  35.385 +
  35.386 +local
  35.387 +
  35.388 +fun dest_all (Const (@{const_name HOL.All}, _) $ Abs (_, T, t)) nctxt =
  35.389 +      let
  35.390 +        val (n, nctxt') = Name.variant "" nctxt
  35.391 +        val f = Free (n, T)
  35.392 +        val t' = Term.subst_bound (f, t)
  35.393 +      in dest_all t' nctxt' |>> cons f end
  35.394 +  | dest_all t _ = ([], t)
  35.395 +
  35.396 +fun dest_alls t =
  35.397 +  let
  35.398 +    val nctxt = Name.make_context (Term.add_free_names t [])
  35.399 +    val (lhs, rhs) = HOLogic.dest_eq (dest_prop t)
  35.400 +    val (ls, lhs') = dest_all lhs nctxt
  35.401 +    val (rs, rhs') = dest_all rhs nctxt
  35.402 +  in
  35.403 +    if eq_list (op aconv) (ls, rs) then SOME (ls, (HOLogic.mk_eq (lhs', rhs')))
  35.404 +    else NONE
  35.405 +  end
  35.406 +
  35.407 +fun forall_intr ctxt t thm =
  35.408 +  let val ct = Thm.cterm_of (Proof_Context.theory_of ctxt) t
  35.409 +  in Thm.forall_intr ct thm COMP_INCR @{thm iff_allI} end
  35.410 +
  35.411 +in
  35.412 +
  35.413 +fun focus_eq f ctxt t =
  35.414 +  (case dest_alls t of
  35.415 +    NONE => f ctxt t
  35.416 +  | SOME (vs, t') => fold (forall_intr ctxt) vs (f ctxt t'))
  35.417 +
  35.418 +end
  35.419 +
  35.420 +fun abstract_eq f (Const (@{const_name HOL.eq}, _) $ t1 $ t2) =
  35.421 +      f t1 ##>> f t2 #>> HOLogic.mk_eq
  35.422 +  | abstract_eq _ t = abstract_term t
  35.423 +
  35.424 +fun prove_prop_rewrite ctxt t =
  35.425 +  prove_abstract' ctxt t prop_tac (
  35.426 +    abstract_eq abstract_prop (dest_prop t))
  35.427 +
  35.428 +fun arith_rewrite_tac ctxt _ =
  35.429 +  TRY o Simplifier.simp_tac ctxt
  35.430 +  THEN_ALL_NEW (Arith_Data.arith_tac ctxt ORELSE' Clasimp.force_tac ctxt)
  35.431 +
  35.432 +fun prove_arith_rewrite ctxt t =
  35.433 +  prove_abstract' ctxt t arith_rewrite_tac (
  35.434 +    abstract_eq (abstract_arith ctxt) (dest_prop t))
  35.435 +
  35.436 +fun rewrite ctxt _ = try_provers ctxt Z3_Proof.Rewrite [
  35.437 +  ("rules", apply_rule ctxt),
  35.438 +  ("prop_rewrite", prove_prop_rewrite ctxt),
  35.439 +  ("arith_rewrite", focus_eq prove_arith_rewrite ctxt)] []
  35.440 +
  35.441 +fun rewrite_star ctxt = rewrite ctxt
  35.442 +
  35.443 +
  35.444 +(* pulling quantifiers *)
  35.445 +
  35.446 +fun pull_quant ctxt _ t = prove ctxt t quant_tac
  35.447 +
  35.448 +
  35.449 +(* pushing quantifiers *)
  35.450 +
  35.451 +fun push_quant _ _ _ = raise Fail "unsupported" (* FIXME *)
  35.452 +
  35.453 +
  35.454 +(* elimination of unused bound variables *)
  35.455 +
  35.456 +val elim_all = @{lemma "P = Q ==> (ALL x. P) = Q" by fast}
  35.457 +val elim_ex = @{lemma "P = Q ==> (EX x. P) = Q" by fast}
  35.458 +
  35.459 +fun elim_unused_tac i st = (
  35.460 +  match_tac [@{thm refl}]
  35.461 +  ORELSE' (match_tac [elim_all, elim_ex] THEN' elim_unused_tac)
  35.462 +  ORELSE' (
  35.463 +    match_tac [@{thm iff_allI}, @{thm iff_exI}]
  35.464 +    THEN' elim_unused_tac)) i st
  35.465 +
  35.466 +fun elim_unused ctxt _ t = prove ctxt t (fn _ => elim_unused_tac)
  35.467 +
  35.468 +
  35.469 +(* destructive equality resolution *)
  35.470 +
  35.471 +fun dest_eq_res _ _ _ = raise Fail "dest_eq_res" (* FIXME *)
  35.472 +
  35.473 +
  35.474 +(* quantifier instantiation *)
  35.475 +
  35.476 +val quant_inst_rule = @{lemma "~P x | Q ==> ~(ALL x. P x) | Q" by fast}
  35.477 +
  35.478 +fun quant_inst ctxt _ t = prove ctxt t (fn _ =>
  35.479 +  REPEAT_ALL_NEW (rtac quant_inst_rule)
  35.480 +  THEN' rtac @{thm excluded_middle})
  35.481 +
  35.482 +
  35.483 +(* propositional lemma *)
  35.484 +
  35.485 +exception LEMMA of unit
  35.486 +
  35.487 +val intro_hyp_rule1 = @{lemma "(~P ==> Q) ==> P | Q" by fast}
  35.488 +val intro_hyp_rule2 = @{lemma "(P ==> Q) ==> ~P | Q" by fast}
  35.489 +
  35.490 +fun norm_lemma thm =
  35.491 +  (thm COMP_INCR intro_hyp_rule1)
  35.492 +  handle THM _ => thm COMP_INCR intro_hyp_rule2
  35.493 +
  35.494 +fun negated_prop (@{const HOL.Not} $ t) = HOLogic.mk_Trueprop t
  35.495 +  | negated_prop t = HOLogic.mk_Trueprop (HOLogic.mk_not t)
  35.496 +
  35.497 +fun intro_hyps tab (t as @{const HOL.disj} $ t1 $ t2) cx =
  35.498 +      lookup_intro_hyps tab t (fold (intro_hyps tab) [t1, t2]) cx
  35.499 +  | intro_hyps tab t cx =
  35.500 +      lookup_intro_hyps tab t (fn _ => raise LEMMA ()) cx
  35.501 +
  35.502 +and lookup_intro_hyps tab t f (cx as (thm, terms)) =
  35.503 +  (case Termtab.lookup tab (negated_prop t) of
  35.504 +    NONE => f cx
  35.505 +  | SOME hyp => (norm_lemma (Thm.implies_intr hyp thm), t :: terms))
  35.506 +
  35.507 +fun lemma ctxt (thms as [thm]) t =
  35.508 +    (let
  35.509 +       val tab = Termtab.make (map (`Thm.term_of) (#hyps (Thm.crep_thm thm)))
  35.510 +       val (thm', terms) = intro_hyps tab (dest_prop t) (thm, [])
  35.511 +     in
  35.512 +       prove_abstract ctxt [thm'] t prop_tac (
  35.513 +         fold (snd oo abstract_lit) terms #>
  35.514 +         abstract_disj (dest_thm thm') #>> single ##>>
  35.515 +         abstract_disj (dest_prop t))
  35.516 +     end
  35.517 +     handle LEMMA () => replay_error ctxt "Bad proof state" Z3_Proof.Lemma thms t)
  35.518 +  | lemma ctxt thms t = replay_rule_error ctxt Z3_Proof.Lemma thms t
  35.519 +
  35.520 +
  35.521 +(* unit resolution *)
  35.522 +
  35.523 +fun abstract_unit (t as (@{const HOL.Not} $ (@{const HOL.disj} $ t1 $ t2))) =
  35.524 +      abstract_sub t (abstract_unit t1 ##>> abstract_unit t2 #>>
  35.525 +        HOLogic.mk_not o HOLogic.mk_disj)
  35.526 +  | abstract_unit (t as (@{const HOL.disj} $ t1 $ t2)) =
  35.527 +      abstract_sub t (abstract_unit t1 ##>> abstract_unit t2 #>>
  35.528 +        HOLogic.mk_disj)
  35.529 +  | abstract_unit t = abstract_lit t
  35.530 +
  35.531 +fun unit_res ctxt thms t =
  35.532 +  prove_abstract ctxt thms t prop_tac (
  35.533 +    fold_map (abstract_unit o dest_thm) thms ##>>
  35.534 +    abstract_unit (dest_prop t) #>>
  35.535 +    (fn (prems, concl) => (prems, concl)))
  35.536 +
  35.537 +
  35.538 +(* iff-true *)
  35.539 +
  35.540 +val iff_true_rule = @{lemma "P ==> P = True" by fast}
  35.541 +
  35.542 +fun iff_true _ [thm] _ = thm RS iff_true_rule
  35.543 +  | iff_true ctxt thms t = replay_rule_error ctxt Z3_Proof.Iff_True thms t
  35.544 +
  35.545 +
  35.546 +(* iff-false *)
  35.547 +
  35.548 +val iff_false_rule = @{lemma "~P ==> P = False" by fast}
  35.549 +
  35.550 +fun iff_false _ [thm] _ = thm RS iff_false_rule
  35.551 +  | iff_false ctxt thms t = replay_rule_error ctxt Z3_Proof.Iff_False thms t
  35.552 +
  35.553 +
  35.554 +(* commutativity *)
  35.555 +
  35.556 +fun comm ctxt _ t = match_instantiate ctxt t @{thm eq_commute}
  35.557 +
  35.558 +
  35.559 +(* definitional axioms *)
  35.560 +
  35.561 +fun def_axiom_disj ctxt t =
  35.562 +  (case dest_prop t of
  35.563 +    @{const HOL.disj} $ u1 $ u2 =>
  35.564 +      prove_abstract' ctxt t prop_tac (
  35.565 +        abstract_prop u2 ##>> abstract_prop u1 #>> HOLogic.mk_disj o swap)
  35.566 +  | u => prove_abstract' ctxt t prop_tac (abstract_prop u))
  35.567 +
  35.568 +fun def_axiom ctxt _ = try_provers ctxt Z3_Proof.Def_Axiom [
  35.569 +  ("rules", apply_rule ctxt),
  35.570 +  ("disj", def_axiom_disj ctxt)] []
  35.571 +
  35.572 +
  35.573 +(* application of definitions *)
  35.574 +
  35.575 +fun apply_def _ [thm] _ = thm (* TODO: cover also the missing cases *)
  35.576 +  | apply_def ctxt thms t = replay_rule_error ctxt Z3_Proof.Apply_Def thms t
  35.577 +
  35.578 +
  35.579 +(* iff-oeq *)
  35.580 +
  35.581 +fun iff_oeq _ _ _ = raise Fail "iff_oeq" (* FIXME *)
  35.582 +
  35.583 +
  35.584 +(* negation normal form *)
  35.585 +
  35.586 +fun nnf_prop ctxt thms t =
  35.587 +  prove_abstract ctxt thms t prop_tac (
  35.588 +    fold_map (abstract_prop o dest_thm) thms ##>>
  35.589 +    abstract_prop (dest_prop t))
  35.590 +
  35.591 +fun nnf ctxt rule thms = try_provers ctxt rule [
  35.592 +  ("prop", nnf_prop ctxt thms),
  35.593 +  ("quant", quant_intro ctxt [hd thms])] thms
  35.594 +
  35.595 +fun nnf_pos ctxt = nnf ctxt Z3_Proof.Nnf_Pos
  35.596 +fun nnf_neg ctxt = nnf ctxt Z3_Proof.Nnf_Neg
  35.597 +
  35.598 +
  35.599 +(* theory lemmas *)
  35.600 +
  35.601 +fun arith_th_lemma_tac ctxt prems =
  35.602 +  Method.insert_tac prems
  35.603 +  THEN' SELECT_GOAL (Local_Defs.unfold_tac ctxt @{thms z3div_def z3mod_def})
  35.604 +  THEN' Arith_Data.arith_tac ctxt
  35.605 +
  35.606 +fun arith_th_lemma ctxt thms t =
  35.607 +  prove_abstract ctxt thms t arith_th_lemma_tac (
  35.608 +    fold_map (abstract_arith ctxt o dest_thm) thms ##>>
  35.609 +    abstract_arith ctxt (dest_prop t))
  35.610 +
  35.611 +val _ = Theory.setup (Context.theory_map (add_th_lemma_method ("arith", arith_th_lemma)))
  35.612 +
  35.613 +fun th_lemma name ctxt thms =
  35.614 +  (case Symtab.lookup (get_th_lemma_method ctxt) name of
  35.615 +    SOME method => method ctxt thms
  35.616 +  | NONE => replay_error ctxt "Bad theory" (Z3_Proof.Th_Lemma name) thms)
  35.617 +
  35.618 +
  35.619 +(* mapping of rules to methods *)
  35.620 +
  35.621 +fun unsupported rule ctxt = replay_error ctxt "Unsupported" rule
  35.622 +fun assumed rule ctxt = replay_error ctxt "Assumed" rule
  35.623 +
  35.624 +fun choose Z3_Proof.True_Axiom = true_axiom
  35.625 +  | choose (r as Z3_Proof.Asserted) = assumed r
  35.626 +  | choose (r as Z3_Proof.Goal) = assumed r
  35.627 +  | choose Z3_Proof.Modus_Ponens = mp
  35.628 +  | choose Z3_Proof.Reflexivity = refl
  35.629 +  | choose Z3_Proof.Symmetry = symm
  35.630 +  | choose Z3_Proof.Transitivity = trans
  35.631 +  | choose (r as Z3_Proof.Transitivity_Star) = unsupported r
  35.632 +  | choose Z3_Proof.Monotonicity = cong
  35.633 +  | choose Z3_Proof.Quant_Intro = quant_intro
  35.634 +  | choose Z3_Proof.Distributivity = distrib
  35.635 +  | choose Z3_Proof.And_Elim = and_elim
  35.636 +  | choose Z3_Proof.Not_Or_Elim = not_or_elim
  35.637 +  | choose Z3_Proof.Rewrite = rewrite
  35.638 +  | choose Z3_Proof.Rewrite_Star = rewrite_star
  35.639 +  | choose Z3_Proof.Pull_Quant = pull_quant
  35.640 +  | choose (r as Z3_Proof.Pull_Quant_Star) = unsupported r
  35.641 +  | choose Z3_Proof.Push_Quant = push_quant
  35.642 +  | choose Z3_Proof.Elim_Unused_Vars = elim_unused
  35.643 +  | choose Z3_Proof.Dest_Eq_Res = dest_eq_res
  35.644 +  | choose Z3_Proof.Quant_Inst = quant_inst
  35.645 +  | choose (r as Z3_Proof.Hypothesis) = assumed r
  35.646 +  | choose Z3_Proof.Lemma = lemma
  35.647 +  | choose Z3_Proof.Unit_Resolution = unit_res
  35.648 +  | choose Z3_Proof.Iff_True = iff_true
  35.649 +  | choose Z3_Proof.Iff_False = iff_false
  35.650 +  | choose Z3_Proof.Commutativity = comm
  35.651 +  | choose Z3_Proof.Def_Axiom = def_axiom
  35.652 +  | choose (r as Z3_Proof.Intro_Def) = assumed r
  35.653 +  | choose Z3_Proof.Apply_Def = apply_def
  35.654 +  | choose Z3_Proof.Iff_Oeq = iff_oeq
  35.655 +  | choose Z3_Proof.Nnf_Pos = nnf_pos
  35.656 +  | choose Z3_Proof.Nnf_Neg = nnf_neg
  35.657 +  | choose (r as Z3_Proof.Nnf_Star) = unsupported r
  35.658 +  | choose (r as Z3_Proof.Cnf_Star) = unsupported r
  35.659 +  | choose (r as Z3_Proof.Skolemize) = assumed r
  35.660 +  | choose Z3_Proof.Modus_Ponens_Oeq = mp_oeq
  35.661 +  | choose (Z3_Proof.Th_Lemma name) = th_lemma name
  35.662 +
  35.663 +fun with_tracing rule method ctxt thms t =
  35.664 +  let val _ = trace_goal ctxt rule thms t
  35.665 +  in method ctxt thms t end
  35.666 +
  35.667 +fun method_for rule = with_tracing rule (choose rule)
  35.668 +
  35.669 +end;
    36.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    36.2 +++ b/src/HOL/Tools/SMT/z3_replay_rules.ML	Thu Aug 28 00:40:38 2014 +0200
    36.3 @@ -0,0 +1,54 @@
    36.4 +(*  Title:      HOL/Tools/SMT/z3_replay_rules.ML
    36.5 +    Author:     Sascha Boehme, TU Muenchen
    36.6 +
    36.7 +Custom rules for Z3 proof replay.
    36.8 +*)
    36.9 +
   36.10 +signature Z3_REPLAY_RULES =
   36.11 +sig
   36.12 +  val apply: Proof.context -> cterm -> thm option
   36.13 +end;
   36.14 +
   36.15 +structure Z3_Replay_Rules: Z3_REPLAY_RULES =
   36.16 +struct
   36.17 +
   36.18 +structure Data = Generic_Data
   36.19 +(
   36.20 +  type T = thm Net.net
   36.21 +  val empty = Net.empty
   36.22 +  val extend = I
   36.23 +  val merge = Net.merge Thm.eq_thm
   36.24 +)
   36.25 +
   36.26 +fun maybe_instantiate ct thm =
   36.27 +  try Thm.first_order_match (Thm.cprop_of thm, ct)
   36.28 +  |> Option.map (fn inst => Thm.instantiate inst thm)
   36.29 +
   36.30 +fun apply ctxt ct =
   36.31 +  let
   36.32 +    val net = Data.get (Context.Proof ctxt)
   36.33 +    val xthms = Net.match_term net (Thm.term_of ct)
   36.34 +
   36.35 +    fun select ct = map_filter (maybe_instantiate ct) xthms
   36.36 +    fun select' ct =
   36.37 +      let val thm = Thm.trivial ct
   36.38 +      in map_filter (try (fn rule => rule COMP thm)) xthms end
   36.39 +
   36.40 +  in try hd (case select ct of [] => select' ct | xthms' => xthms') end
   36.41 +
   36.42 +val prep = `Thm.prop_of
   36.43 +
   36.44 +fun ins thm net = Net.insert_term Thm.eq_thm (prep thm) net handle Net.INSERT => net
   36.45 +fun del thm net = Net.delete_term Thm.eq_thm (prep thm) net handle Net.DELETE => net
   36.46 +
   36.47 +val add = Thm.declaration_attribute (Data.map o ins)
   36.48 +val del = Thm.declaration_attribute (Data.map o del)
   36.49 +
   36.50 +val name = Binding.name "z3_rule"
   36.51 +
   36.52 +val description = "declaration of Z3 proof rules"
   36.53 +
   36.54 +val _ = Theory.setup (Attrib.setup name (Attrib.add_del add del) description #>
   36.55 +  Global_Theory.add_thms_dynamic (name, Net.content o Data.get))
   36.56 +
   36.57 +end;
    37.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.2 +++ b/src/HOL/Tools/SMT/z3_replay_util.ML	Thu Aug 28 00:40:38 2014 +0200
    37.3 @@ -0,0 +1,150 @@
    37.4 +(*  Title:      HOL/Tools/SMT/z3_replay_util.ML
    37.5 +    Author:     Sascha Boehme, TU Muenchen
    37.6 +
    37.7 +Helper functions required for Z3 proof replay.
    37.8 +*)
    37.9 +
   37.10 +signature Z3_REPLAY_UTIL =
   37.11 +sig
   37.12 +  (*theorem nets*)
   37.13 +  val thm_net_of: ('a -> thm) -> 'a list -> 'a Net.net
   37.14 +  val net_instances: (int * thm) Net.net -> cterm -> (int * thm) list
   37.15 +
   37.16 +  (*proof combinators*)
   37.17 +  val under_assumption: (thm -> thm) -> cterm -> thm
   37.18 +  val discharge: thm -> thm -> thm
   37.19 +
   37.20 +  (*a faster COMP*)
   37.21 +  type compose_data
   37.22 +  val precompose: (cterm -> cterm list) -> thm -> compose_data
   37.23 +  val precompose2: (cterm -> cterm * cterm) -> thm -> compose_data
   37.24 +  val compose: compose_data -> thm -> thm
   37.25 +
   37.26 +  (*simpset*)
   37.27 +  val add_simproc: Simplifier.simproc -> Context.generic -> Context.generic
   37.28 +  val make_simpset: Proof.context -> thm list -> simpset
   37.29 +end;
   37.30 +
   37.31 +structure Z3_Replay_Util: Z3_REPLAY_UTIL =
   37.32 +struct
   37.33 +
   37.34 +(* theorem nets *)
   37.35 +
   37.36 +fun thm_net_of f xthms =
   37.37 +  let fun insert xthm = Net.insert_term (K false) (Thm.prop_of (f xthm), xthm)
   37.38 +  in fold insert xthms Net.empty end
   37.39 +
   37.40 +fun maybe_instantiate ct thm =
   37.41 +  try Thm.first_order_match (Thm.cprop_of thm, ct)
   37.42 +  |> Option.map (fn inst => Thm.instantiate inst thm)
   37.43 +
   37.44 +local
   37.45 +  fun instances_from_net match f net ct =
   37.46 +    let
   37.47 +      val lookup = if match then Net.match_term else Net.unify_term
   37.48 +      val xthms = lookup net (Thm.term_of ct)
   37.49 +      fun select ct = map_filter (f (maybe_instantiate ct)) xthms
   37.50 +      fun select' ct =
   37.51 +        let val thm = Thm.trivial ct
   37.52 +        in map_filter (f (try (fn rule => rule COMP thm))) xthms end
   37.53 +    in (case select ct of [] => select' ct | xthms' => xthms') end
   37.54 +in
   37.55 +
   37.56 +fun net_instances net =
   37.57 +  instances_from_net false (fn f => fn (i, thm) => Option.map (pair i) (f thm))
   37.58 +    net
   37.59 +
   37.60 +end
   37.61 +
   37.62 +
   37.63 +(* proof combinators *)
   37.64 +
   37.65 +fun under_assumption f ct =
   37.66 +  let val ct' = SMT_Util.mk_cprop ct in Thm.implies_intr ct' (f (Thm.assume ct')) end
   37.67 +
   37.68 +fun discharge p pq = Thm.implies_elim pq p
   37.69 +
   37.70 +
   37.71 +(* a faster COMP *)
   37.72 +
   37.73 +type compose_data = cterm list * (cterm -> cterm list) * thm
   37.74 +
   37.75 +fun list2 (x, y) = [x, y]
   37.76 +
   37.77 +fun precompose f rule = (f (Thm.cprem_of rule 1), f, rule)
   37.78 +fun precompose2 f rule = precompose (list2 o f) rule
   37.79 +
   37.80 +fun compose (cvs, f, rule) thm =
   37.81 +  discharge thm (Thm.instantiate ([], cvs ~~ f (Thm.cprop_of thm)) rule)
   37.82 +
   37.83 +
   37.84 +(* simpset *)
   37.85 +
   37.86 +local
   37.87 +  val antisym_le1 = mk_meta_eq @{thm order_class.antisym_conv}
   37.88 +  val antisym_le2 = mk_meta_eq @{thm linorder_class.antisym_conv2}
   37.89 +  val antisym_less1 = mk_meta_eq @{thm linorder_class.antisym_conv1}
   37.90 +  val antisym_less2 = mk_meta_eq @{thm linorder_class.antisym_conv3}
   37.91 +
   37.92 +  fun eq_prop t thm = HOLogic.mk_Trueprop t aconv Thm.prop_of thm
   37.93 +  fun dest_binop ((c as Const _) $ t $ u) = (c, t, u)
   37.94 +    | dest_binop t = raise TERM ("dest_binop", [t])
   37.95 +
   37.96 +  fun prove_antisym_le ctxt t =
   37.97 +    let
   37.98 +      val (le, r, s) = dest_binop t
   37.99 +      val less = Const (@{const_name less}, Term.fastype_of le)
  37.100 +      val prems = Simplifier.prems_of ctxt
  37.101 +    in
  37.102 +      (case find_first (eq_prop (le $ s $ r)) prems of
  37.103 +        NONE =>
  37.104 +          find_first (eq_prop (HOLogic.mk_not (less $ r $ s))) prems
  37.105 +          |> Option.map (fn thm => thm RS antisym_less1)
  37.106 +      | SOME thm => SOME (thm RS antisym_le1))
  37.107 +    end
  37.108 +    handle THM _ => NONE
  37.109 +
  37.110 +  fun prove_antisym_less ctxt t =
  37.111 +    let
  37.112 +      val (less, r, s) = dest_binop (HOLogic.dest_not t)
  37.113 +      val le = Const (@{const_name less_eq}, Term.fastype_of less)
  37.114 +      val prems = Simplifier.prems_of ctxt
  37.115 +    in
  37.116 +      (case find_first (eq_prop (le $ r $ s)) prems of
  37.117 +        NONE =>
  37.118 +          find_first (eq_prop (HOLogic.mk_not (less $ s $ r))) prems
  37.119 +          |> Option.map (fn thm => thm RS antisym_less2)
  37.120 +      | SOME thm => SOME (thm RS antisym_le2))
  37.121 +  end
  37.122 +  handle THM _ => NONE
  37.123 +
  37.124 +  val basic_simpset =
  37.125 +    simpset_of (put_simpset HOL_ss @{context}
  37.126 +      addsimps @{thms field_simps times_divide_eq_right times_divide_eq_left arith_special
  37.127 +        arith_simps rel_simps array_rules z3div_def z3mod_def}
  37.128 +      addsimprocs [@{simproc binary_int_div}, @{simproc binary_int_mod},
  37.129 +        Simplifier.simproc_global @{theory} "fast_int_arith" [
  37.130 +          "(m::int) < n", "(m::int) <= n", "(m::int) = n"] Lin_Arith.simproc,
  37.131 +        Simplifier.simproc_global @{theory} "antisym_le" ["(x::'a::order) <= y"] prove_antisym_le,
  37.132 +        Simplifier.simproc_global @{theory} "antisym_less" ["~ (x::'a::linorder) < y"]
  37.133 +          prove_antisym_less])
  37.134 +
  37.135 +  structure Simpset = Generic_Data
  37.136 +  (
  37.137 +    type T = simpset
  37.138 +    val empty = basic_simpset
  37.139 +    val extend = I
  37.140 +    val merge = Simplifier.merge_ss
  37.141 +  )
  37.142 +in
  37.143 +
  37.144 +fun add_simproc simproc context =
  37.145 +  Simpset.map (simpset_map (Context.proof_of context)
  37.146 +    (fn ctxt => ctxt addsimprocs [simproc])) context
  37.147 +
  37.148 +fun make_simpset ctxt rules =
  37.149 +  simpset_of (put_simpset (Simpset.get (Context.Proof ctxt)) ctxt addsimps rules)
  37.150 +
  37.151 +end
  37.152 +
  37.153 +end;
    38.1 --- a/src/HOL/Tools/SMT2/smt2_builtin.ML	Thu Aug 28 00:40:38 2014 +0200
    38.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000