add 'old_' prefix to SMT file names; add 'Old_' to ML module names;
authorblanchet
Thu Aug 28 00:40:38 2014 +0200 (2014-08-28)
changeset 580581a0b18176548
parent 58057 883f3c4c928e
child 58059 4e477dcd050a
add 'old_' prefix to SMT file names; add 'Old_' to ML module names;
src/HOL/Library/Old_SMT.thy
src/HOL/Library/Old_SMT/old_smt_builtin.ML
src/HOL/Library/Old_SMT/old_smt_config.ML
src/HOL/Library/Old_SMT/old_smt_datatypes.ML
src/HOL/Library/Old_SMT/old_smt_failure.ML
src/HOL/Library/Old_SMT/old_smt_normalize.ML
src/HOL/Library/Old_SMT/old_smt_real.ML
src/HOL/Library/Old_SMT/old_smt_setup_solvers.ML
src/HOL/Library/Old_SMT/old_smt_solver.ML
src/HOL/Library/Old_SMT/old_smt_translate.ML
src/HOL/Library/Old_SMT/old_smt_utils.ML
src/HOL/Library/Old_SMT/old_smt_word.ML
src/HOL/Library/Old_SMT/old_smtlib_interface.ML
src/HOL/Library/Old_SMT/old_z3_interface.ML
src/HOL/Library/Old_SMT/old_z3_model.ML
src/HOL/Library/Old_SMT/old_z3_proof_literals.ML
src/HOL/Library/Old_SMT/old_z3_proof_methods.ML
src/HOL/Library/Old_SMT/old_z3_proof_parser.ML
src/HOL/Library/Old_SMT/old_z3_proof_reconstruction.ML
src/HOL/Library/Old_SMT/old_z3_proof_tools.ML
src/HOL/Library/Old_SMT/smt_builtin.ML
src/HOL/Library/Old_SMT/smt_config.ML
src/HOL/Library/Old_SMT/smt_datatypes.ML
src/HOL/Library/Old_SMT/smt_failure.ML
src/HOL/Library/Old_SMT/smt_normalize.ML
src/HOL/Library/Old_SMT/smt_real.ML
src/HOL/Library/Old_SMT/smt_setup_solvers.ML
src/HOL/Library/Old_SMT/smt_solver.ML
src/HOL/Library/Old_SMT/smt_translate.ML
src/HOL/Library/Old_SMT/smt_utils.ML
src/HOL/Library/Old_SMT/smt_word.ML
src/HOL/Library/Old_SMT/smtlib_interface.ML
src/HOL/Library/Old_SMT/z3_interface.ML
src/HOL/Library/Old_SMT/z3_model.ML
src/HOL/Library/Old_SMT/z3_proof_literals.ML
src/HOL/Library/Old_SMT/z3_proof_methods.ML
src/HOL/Library/Old_SMT/z3_proof_parser.ML
src/HOL/Library/Old_SMT/z3_proof_reconstruction.ML
src/HOL/Library/Old_SMT/z3_proof_tools.ML
     1.1 --- a/src/HOL/Library/Old_SMT.thy	Thu Aug 28 00:40:38 2014 +0200
     1.2 +++ b/src/HOL/Library/Old_SMT.thy	Thu Aug 28 00:40:38 2014 +0200
     1.3 @@ -9,9 +9,9 @@
     1.4  keywords "smt_status" :: diag
     1.5  begin
     1.6  
     1.7 -ML_file "Old_SMT/smt_utils.ML"
     1.8 -ML_file "Old_SMT/smt_failure.ML"
     1.9 -ML_file "Old_SMT/smt_config.ML"
    1.10 +ML_file "Old_SMT/old_smt_utils.ML"
    1.11 +ML_file "Old_SMT/old_smt_failure.ML"
    1.12 +ML_file "Old_SMT/old_smt_config.ML"
    1.13  
    1.14  
    1.15  subsection {* Triggers for quantifier instantiation *}
    1.16 @@ -115,34 +115,34 @@
    1.17  
    1.18  subsection {* Setup *}
    1.19  
    1.20 -ML_file "Old_SMT/smt_builtin.ML"
    1.21 -ML_file "Old_SMT/smt_datatypes.ML"
    1.22 -ML_file "Old_SMT/smt_normalize.ML"
    1.23 -ML_file "Old_SMT/smt_translate.ML"
    1.24 -ML_file "Old_SMT/smt_solver.ML"
    1.25 -ML_file "Old_SMT/smtlib_interface.ML"
    1.26 -ML_file "Old_SMT/z3_interface.ML"
    1.27 -ML_file "Old_SMT/z3_proof_parser.ML"
    1.28 -ML_file "Old_SMT/z3_proof_tools.ML"
    1.29 -ML_file "Old_SMT/z3_proof_literals.ML"
    1.30 -ML_file "Old_SMT/z3_proof_methods.ML"
    1.31 +ML_file "Old_SMT/old_smt_builtin.ML"
    1.32 +ML_file "Old_SMT/old_smt_datatypes.ML"
    1.33 +ML_file "Old_SMT/old_smt_normalize.ML"
    1.34 +ML_file "Old_SMT/old_smt_translate.ML"
    1.35 +ML_file "Old_SMT/old_smt_solver.ML"
    1.36 +ML_file "Old_SMT/old_smtlib_interface.ML"
    1.37 +ML_file "Old_SMT/old_z3_interface.ML"
    1.38 +ML_file "Old_SMT/old_z3_proof_parser.ML"
    1.39 +ML_file "Old_SMT/old_z3_proof_tools.ML"
    1.40 +ML_file "Old_SMT/old_z3_proof_literals.ML"
    1.41 +ML_file "Old_SMT/old_z3_proof_methods.ML"
    1.42  named_theorems z3_simp "simplification rules for Z3 proof reconstruction"
    1.43 -ML_file "Old_SMT/z3_proof_reconstruction.ML"
    1.44 -ML_file "Old_SMT/z3_model.ML"
    1.45 -ML_file "Old_SMT/smt_setup_solvers.ML"
    1.46 +ML_file "Old_SMT/old_z3_proof_reconstruction.ML"
    1.47 +ML_file "Old_SMT/old_z3_model.ML"
    1.48 +ML_file "Old_SMT/old_smt_setup_solvers.ML"
    1.49  
    1.50  setup {*
    1.51 -  SMT_Config.setup #>
    1.52 -  SMT_Normalize.setup #>
    1.53 -  SMTLIB_Interface.setup #>
    1.54 -  Z3_Interface.setup #>
    1.55 -  SMT_Setup_Solvers.setup
    1.56 +  Old_SMT_Config.setup #>
    1.57 +  Old_SMT_Normalize.setup #>
    1.58 +  Old_SMTLIB_Interface.setup #>
    1.59 +  Old_Z3_Interface.setup #>
    1.60 +  Old_SMT_Setup_Solvers.setup
    1.61  *}
    1.62  
    1.63  method_setup smt = {*
    1.64    Scan.optional Attrib.thms [] >>
    1.65      (fn thms => fn ctxt =>
    1.66 -      METHOD (fn facts => HEADGOAL (SMT_Solver.smt_tac ctxt (thms @ facts))))
    1.67 +      METHOD (fn facts => HEADGOAL (Old_SMT_Solver.smt_tac ctxt (thms @ facts))))
    1.68  *} "apply an SMT solver to the current goal"
    1.69  
    1.70  
    1.71 @@ -419,11 +419,11 @@
    1.72    "(if P then Q else \<not>R) \<or> P \<or> R"
    1.73    by auto
    1.74  
    1.75 -ML_file "Old_SMT/smt_real.ML"
    1.76 -setup SMT_Real.setup
    1.77 +ML_file "Old_SMT/old_smt_real.ML"
    1.78 +setup Old_SMT_Real.setup
    1.79  
    1.80 -ML_file "Old_SMT/smt_word.ML"
    1.81 -setup SMT_Word.setup
    1.82 +ML_file "Old_SMT/old_smt_word.ML"
    1.83 +setup Old_SMT_Word.setup
    1.84  
    1.85  hide_type (open) pattern
    1.86  hide_const fun_app term_true term_false z3div z3mod
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Library/Old_SMT/old_smt_builtin.ML	Thu Aug 28 00:40:38 2014 +0200
     2.3 @@ -0,0 +1,231 @@
     2.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_builtin.ML
     2.5 +    Author:     Sascha Boehme, TU Muenchen
     2.6 +
     2.7 +Tables of types and terms directly supported by SMT solvers.
     2.8 +*)
     2.9 +
    2.10 +signature OLD_SMT_BUILTIN =
    2.11 +sig
    2.12 +  (*for experiments*)
    2.13 +  val filter_builtins: (typ -> bool) -> Proof.context -> Proof.context
    2.14 +
    2.15 +  (*built-in types*)
    2.16 +  val add_builtin_typ: Old_SMT_Utils.class ->
    2.17 +    typ * (typ -> string option) * (typ -> int -> string option) ->
    2.18 +    Context.generic -> Context.generic
    2.19 +  val add_builtin_typ_ext: typ * (typ -> bool) -> Context.generic ->
    2.20 +    Context.generic
    2.21 +  val dest_builtin_typ: Proof.context -> typ -> string option
    2.22 +  val is_builtin_typ_ext: Proof.context -> typ -> bool
    2.23 +
    2.24 +  (*built-in numbers*)
    2.25 +  val dest_builtin_num: Proof.context -> term -> (string * typ) option
    2.26 +  val is_builtin_num: Proof.context -> term -> bool
    2.27 +  val is_builtin_num_ext: Proof.context -> term -> bool
    2.28 +
    2.29 +  (*built-in functions*)
    2.30 +  type 'a bfun = Proof.context -> typ -> term list -> 'a
    2.31 +  type bfunr = string * int * term list * (term list -> term)
    2.32 +  val add_builtin_fun: Old_SMT_Utils.class ->
    2.33 +    (string * typ) * bfunr option bfun -> Context.generic -> Context.generic
    2.34 +  val add_builtin_fun': Old_SMT_Utils.class -> term * string -> Context.generic ->
    2.35 +    Context.generic
    2.36 +  val add_builtin_fun_ext: (string * typ) * term list bfun ->
    2.37 +    Context.generic -> Context.generic
    2.38 +  val add_builtin_fun_ext': string * typ -> Context.generic -> Context.generic
    2.39 +  val add_builtin_fun_ext'': string -> Context.generic -> Context.generic
    2.40 +  val dest_builtin_fun: Proof.context -> string * typ -> term list ->
    2.41 +    bfunr option
    2.42 +  val dest_builtin_eq: Proof.context -> term -> term -> bfunr option
    2.43 +  val dest_builtin_pred: Proof.context -> string * typ -> term list ->
    2.44 +    bfunr option
    2.45 +  val dest_builtin_conn: Proof.context -> string * typ -> term list ->
    2.46 +    bfunr option
    2.47 +  val dest_builtin: Proof.context -> string * typ -> term list -> bfunr option
    2.48 +  val dest_builtin_ext: Proof.context -> string * typ -> term list ->
    2.49 +    term list option
    2.50 +  val is_builtin_fun: Proof.context -> string * typ -> term list -> bool
    2.51 +  val is_builtin_fun_ext: Proof.context -> string * typ -> term list -> bool
    2.52 +end
    2.53 +
    2.54 +structure Old_SMT_Builtin: OLD_SMT_BUILTIN =
    2.55 +struct
    2.56 +
    2.57 +
    2.58 +(* built-in tables *)
    2.59 +
    2.60 +datatype ('a, 'b) kind = Ext of 'a | Int of 'b
    2.61 +
    2.62 +type ('a, 'b) ttab = ((typ * ('a, 'b) kind) Ord_List.T) Old_SMT_Utils.dict 
    2.63 +
    2.64 +fun typ_ord ((T, _), (U, _)) =
    2.65 +  let
    2.66 +    fun tord (TVar _, Type _) = GREATER
    2.67 +      | tord (Type _, TVar _) = LESS
    2.68 +      | tord (Type (n, Ts), Type (m, Us)) =
    2.69 +          if n = m then list_ord tord (Ts, Us)
    2.70 +          else Term_Ord.typ_ord (T, U)
    2.71 +      | tord TU = Term_Ord.typ_ord TU
    2.72 +  in tord (T, U) end
    2.73 +
    2.74 +fun insert_ttab cs T f =
    2.75 +  Old_SMT_Utils.dict_map_default (cs, [])
    2.76 +    (Ord_List.insert typ_ord (perhaps (try Logic.varifyT_global) T, f))
    2.77 +
    2.78 +fun merge_ttab ttabp =
    2.79 +  Old_SMT_Utils.dict_merge (Ord_List.merge typ_ord) ttabp
    2.80 +
    2.81 +fun lookup_ttab ctxt ttab T =
    2.82 +  let fun match (U, _) = Sign.typ_instance (Proof_Context.theory_of ctxt) (T, U)
    2.83 +  in
    2.84 +    get_first (find_first match)
    2.85 +      (Old_SMT_Utils.dict_lookup ttab (Old_SMT_Config.solver_class_of ctxt))
    2.86 +  end
    2.87 +
    2.88 +type ('a, 'b) btab = ('a, 'b) ttab Symtab.table
    2.89 +
    2.90 +fun insert_btab cs n T f =
    2.91 +  Symtab.map_default (n, []) (insert_ttab cs T f)
    2.92 +
    2.93 +fun merge_btab btabp = Symtab.join (K merge_ttab) btabp
    2.94 +
    2.95 +fun lookup_btab ctxt btab (n, T) =
    2.96 +  (case Symtab.lookup btab n of
    2.97 +    NONE => NONE
    2.98 +  | SOME ttab => lookup_ttab ctxt ttab T)
    2.99 +
   2.100 +type 'a bfun = Proof.context -> typ -> term list -> 'a
   2.101 +
   2.102 +type bfunr = string * int * term list * (term list -> term)
   2.103 +
   2.104 +structure Builtins = Generic_Data
   2.105 +(
   2.106 +  type T =
   2.107 +    (typ -> bool, (typ -> string option) * (typ -> int -> string option)) ttab *
   2.108 +    (term list bfun, bfunr option bfun) btab
   2.109 +  val empty = ([], Symtab.empty)
   2.110 +  val extend = I
   2.111 +  fun merge ((t1, b1), (t2, b2)) = (merge_ttab (t1, t2), merge_btab (b1, b2))
   2.112 +)
   2.113 +
   2.114 +fun filter_ttab keep_T = map (apsnd (filter (keep_T o fst)))
   2.115 +
   2.116 +fun filter_builtins keep_T =
   2.117 +  Context.proof_map (Builtins.map (fn (ttab, btab) =>
   2.118 +    (filter_ttab keep_T ttab, Symtab.map (K (filter_ttab keep_T)) btab)))
   2.119 +
   2.120 +
   2.121 +(* built-in types *)
   2.122 +
   2.123 +fun add_builtin_typ cs (T, f, g) =
   2.124 +  Builtins.map (apfst (insert_ttab cs T (Int (f, g))))
   2.125 +
   2.126 +fun add_builtin_typ_ext (T, f) =
   2.127 +  Builtins.map (apfst (insert_ttab Old_SMT_Utils.basicC T (Ext f)))
   2.128 +
   2.129 +fun lookup_builtin_typ ctxt =
   2.130 +  lookup_ttab ctxt (fst (Builtins.get (Context.Proof ctxt)))
   2.131 +
   2.132 +fun dest_builtin_typ ctxt T =
   2.133 +  (case lookup_builtin_typ ctxt T of
   2.134 +    SOME (_, Int (f, _)) => f T
   2.135 +  | _ => NONE) 
   2.136 +
   2.137 +fun is_builtin_typ_ext ctxt T =
   2.138 +  (case lookup_builtin_typ ctxt T of
   2.139 +    SOME (_, Int (f, _)) => is_some (f T)
   2.140 +  | SOME (_, Ext f) => f T
   2.141 +  | NONE => false)
   2.142 +
   2.143 +
   2.144 +(* built-in numbers *)
   2.145 +
   2.146 +fun dest_builtin_num ctxt t =
   2.147 +  (case try HOLogic.dest_number t of
   2.148 +    NONE => NONE
   2.149 +  | SOME (T, i) =>
   2.150 +      if i < 0 then NONE else
   2.151 +        (case lookup_builtin_typ ctxt T of
   2.152 +          SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
   2.153 +        | _ => NONE))
   2.154 +
   2.155 +val is_builtin_num = is_some oo dest_builtin_num
   2.156 +
   2.157 +fun is_builtin_num_ext ctxt t =
   2.158 +  (case try HOLogic.dest_number t of
   2.159 +    NONE => false
   2.160 +  | SOME (T, _) => is_builtin_typ_ext ctxt T)
   2.161 +
   2.162 +
   2.163 +(* built-in functions *)
   2.164 +
   2.165 +fun add_builtin_fun cs ((n, T), f) =
   2.166 +  Builtins.map (apsnd (insert_btab cs n T (Int f)))
   2.167 +
   2.168 +fun add_builtin_fun' cs (t, n) =
   2.169 +  let
   2.170 +    val c as (m, T) = Term.dest_Const t
   2.171 +    fun app U ts = Term.list_comb (Const (m, U), ts)
   2.172 +    fun bfun _ U ts = SOME (n, length (Term.binder_types T), ts, app U)
   2.173 +  in add_builtin_fun cs (c, bfun) end
   2.174 +
   2.175 +fun add_builtin_fun_ext ((n, T), f) =
   2.176 +  Builtins.map (apsnd (insert_btab Old_SMT_Utils.basicC n T (Ext f)))
   2.177 +
   2.178 +fun add_builtin_fun_ext' c = add_builtin_fun_ext (c, fn _ => fn _ => I)
   2.179 +
   2.180 +fun add_builtin_fun_ext'' n context =
   2.181 +  let val thy = Context.theory_of context
   2.182 +  in add_builtin_fun_ext' (n, Sign.the_const_type thy n) context end
   2.183 +
   2.184 +fun lookup_builtin_fun ctxt =
   2.185 +  lookup_btab ctxt (snd (Builtins.get (Context.Proof ctxt)))
   2.186 +
   2.187 +fun dest_builtin_fun ctxt (c as (_, T)) ts =
   2.188 +  (case lookup_builtin_fun ctxt c of
   2.189 +    SOME (_, Int f) => f ctxt T ts
   2.190 +  | _ => NONE)
   2.191 +
   2.192 +fun dest_builtin_eq ctxt t u =
   2.193 +  let
   2.194 +    val aT = TFree (Name.aT, @{sort type})
   2.195 +    val c = (@{const_name HOL.eq}, aT --> aT --> @{typ bool})
   2.196 +    fun mk ts = Term.list_comb (HOLogic.eq_const (Term.fastype_of (hd ts)), ts)
   2.197 +  in
   2.198 +    dest_builtin_fun ctxt c []
   2.199 +    |> Option.map (fn (n, i, _, _) => (n, i, [t, u], mk))
   2.200 +  end
   2.201 +
   2.202 +fun special_builtin_fun pred ctxt (c as (_, T)) ts =
   2.203 +  if pred (Term.body_type T, Term.binder_types T) then
   2.204 +    dest_builtin_fun ctxt c ts
   2.205 +  else NONE
   2.206 +
   2.207 +fun dest_builtin_pred ctxt = special_builtin_fun (equal @{typ bool} o fst) ctxt
   2.208 +
   2.209 +fun dest_builtin_conn ctxt =
   2.210 +  special_builtin_fun (forall (equal @{typ bool}) o (op ::)) ctxt
   2.211 +
   2.212 +fun dest_builtin ctxt c ts =
   2.213 +  let val t = Term.list_comb (Const c, ts)
   2.214 +  in
   2.215 +    (case dest_builtin_num ctxt t of
   2.216 +      SOME (n, _) => SOME (n, 0, [], K t)
   2.217 +    | NONE => dest_builtin_fun ctxt c ts)
   2.218 +  end
   2.219 +
   2.220 +fun dest_builtin_fun_ext ctxt (c as (_, T)) ts =    
   2.221 +  (case lookup_builtin_fun ctxt c of
   2.222 +    SOME (_, Int f) => f ctxt T ts |> Option.map (fn (_, _, us, _) => us)
   2.223 +  | SOME (_, Ext f) => SOME (f ctxt T ts)
   2.224 +  | NONE => NONE)
   2.225 +
   2.226 +fun dest_builtin_ext ctxt c ts =
   2.227 +  if is_builtin_num_ext ctxt (Term.list_comb (Const c, ts)) then SOME []
   2.228 +  else dest_builtin_fun_ext ctxt c ts
   2.229 +
   2.230 +fun is_builtin_fun ctxt c ts = is_some (dest_builtin_fun ctxt c ts)
   2.231 +
   2.232 +fun is_builtin_fun_ext ctxt c ts = is_some (dest_builtin_fun_ext ctxt c ts)
   2.233 +
   2.234 +end
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Library/Old_SMT/old_smt_config.ML	Thu Aug 28 00:40:38 2014 +0200
     3.3 @@ -0,0 +1,254 @@
     3.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_config.ML
     3.5 +    Author:     Sascha Boehme, TU Muenchen
     3.6 +
     3.7 +Configuration options and diagnostic tools for SMT.
     3.8 +*)
     3.9 +
    3.10 +signature OLD_SMT_CONFIG =
    3.11 +sig
    3.12 +  (*solver*)
    3.13 +  type solver_info = {
    3.14 +    name: string,
    3.15 +    class: Proof.context -> Old_SMT_Utils.class,
    3.16 +    avail: unit -> bool,
    3.17 +    options: Proof.context -> string list }
    3.18 +  val add_solver: solver_info -> Context.generic -> Context.generic
    3.19 +  val set_solver_options: string * string -> Context.generic -> Context.generic
    3.20 +  val is_available: Proof.context -> string -> bool
    3.21 +  val available_solvers_of: Proof.context -> string list
    3.22 +  val select_solver: string -> Context.generic -> Context.generic
    3.23 +  val solver_of: Proof.context -> string
    3.24 +  val solver_class_of: Proof.context -> Old_SMT_Utils.class
    3.25 +  val solver_options_of: Proof.context -> string list
    3.26 +
    3.27 +  (*options*)
    3.28 +  val oracle: bool Config.T
    3.29 +  val datatypes: bool Config.T
    3.30 +  val timeout: real Config.T
    3.31 +  val random_seed: int Config.T
    3.32 +  val read_only_certificates: bool Config.T
    3.33 +  val verbose: bool Config.T
    3.34 +  val trace: bool Config.T
    3.35 +  val trace_used_facts: bool Config.T
    3.36 +  val monomorph_limit: int Config.T
    3.37 +  val monomorph_instances: int Config.T
    3.38 +  val infer_triggers: bool Config.T
    3.39 +  val filter_only_facts: bool Config.T
    3.40 +  val debug_files: string Config.T
    3.41 +
    3.42 +  (*tools*)
    3.43 +  val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
    3.44 +
    3.45 +  (*diagnostics*)
    3.46 +  val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
    3.47 +  val verbose_msg: Proof.context -> ('a -> string) -> 'a -> unit
    3.48 +
    3.49 +  (*certificates*)
    3.50 +  val select_certificates: string -> Context.generic -> Context.generic
    3.51 +  val certificates_of: Proof.context -> Cache_IO.cache option
    3.52 +
    3.53 +  (*setup*)
    3.54 +  val setup: theory -> theory
    3.55 +  val print_setup: Proof.context -> unit
    3.56 +end
    3.57 +
    3.58 +structure Old_SMT_Config: OLD_SMT_CONFIG =
    3.59 +struct
    3.60 +
    3.61 +(* solver *)
    3.62 +
    3.63 +type solver_info = {
    3.64 +  name: string,
    3.65 +  class: Proof.context -> Old_SMT_Utils.class,
    3.66 +  avail: unit -> bool,
    3.67 +  options: Proof.context -> string list }
    3.68 +
    3.69 +(* FIXME just one data slot (record) per program unit *)
    3.70 +structure Solvers = Generic_Data
    3.71 +(
    3.72 +  type T = (solver_info * string list) Symtab.table * string option
    3.73 +  val empty = (Symtab.empty, NONE)
    3.74 +  val extend = I
    3.75 +  fun merge ((ss1, s1), (ss2, s2)) =
    3.76 +    (Symtab.merge (K true) (ss1, ss2), merge_options (s1, s2))
    3.77 +)
    3.78 +
    3.79 +fun set_solver_options (name, options) =
    3.80 +  let val opts = String.tokens (Symbol.is_ascii_blank o str) options
    3.81 +  in Solvers.map (apfst (Symtab.map_entry name (apsnd (K opts)))) end
    3.82 +
    3.83 +fun add_solver (info as {name, ...} : solver_info) context =
    3.84 +  if Symtab.defined (fst (Solvers.get context)) name then
    3.85 +    error ("Solver already registered: " ^ quote name)
    3.86 +  else
    3.87 +    context
    3.88 +    |> Solvers.map (apfst (Symtab.update (name, (info, []))))
    3.89 +    |> Context.map_theory (Attrib.setup (Binding.name (name ^ "_options"))
    3.90 +        (Scan.lift (@{keyword "="} |-- Args.name) >>
    3.91 +          (Thm.declaration_attribute o K o set_solver_options o pair name))
    3.92 +        ("Additional command line options for SMT solver " ^ quote name))
    3.93 +
    3.94 +fun all_solvers_of ctxt = Symtab.keys (fst (Solvers.get (Context.Proof ctxt)))
    3.95 +
    3.96 +fun solver_name_of ctxt = snd (Solvers.get (Context.Proof ctxt))
    3.97 +
    3.98 +fun is_available ctxt name =
    3.99 +  (case Symtab.lookup (fst (Solvers.get (Context.Proof ctxt))) name of
   3.100 +    SOME ({avail, ...}, _) => avail ()
   3.101 +  | NONE => false)
   3.102 +
   3.103 +fun available_solvers_of ctxt =
   3.104 +  filter (is_available ctxt) (all_solvers_of ctxt)
   3.105 +
   3.106 +fun warn_solver (Context.Proof ctxt) name =
   3.107 +      if Context_Position.is_visible ctxt then
   3.108 +        warning ("The SMT solver " ^ quote name ^ " is not installed.")
   3.109 +      else ()
   3.110 +  | warn_solver _ _ = ();
   3.111 +
   3.112 +fun select_solver name context =
   3.113 +  let
   3.114 +    val ctxt = Context.proof_of context
   3.115 +    val upd = Solvers.map (apsnd (K (SOME name)))
   3.116 +  in
   3.117 +    if not (member (op =) (all_solvers_of ctxt) name) then
   3.118 +      error ("Trying to select unknown solver: " ^ quote name)
   3.119 +    else if not (is_available ctxt name) then
   3.120 +      (warn_solver context name; upd context)
   3.121 +    else upd context
   3.122 +  end
   3.123 +
   3.124 +fun no_solver_err () = error "No SMT solver selected"
   3.125 +
   3.126 +fun solver_of ctxt =
   3.127 +  (case solver_name_of ctxt of
   3.128 +    SOME name => name
   3.129 +  | NONE => no_solver_err ())
   3.130 +
   3.131 +fun solver_info_of default select ctxt =
   3.132 +  (case Solvers.get (Context.Proof ctxt) of
   3.133 +    (solvers, SOME name) => select (Symtab.lookup solvers name)
   3.134 +  | (_, NONE) => default ())
   3.135 +
   3.136 +fun solver_class_of ctxt =
   3.137 +  let fun class_of ({class, ...}: solver_info, _) = class ctxt
   3.138 +  in solver_info_of no_solver_err (class_of o the) ctxt end
   3.139 +
   3.140 +fun solver_options_of ctxt =
   3.141 +  let
   3.142 +    fun all_options NONE = []
   3.143 +      | all_options (SOME ({options, ...} : solver_info, opts)) =
   3.144 +          opts @ options ctxt
   3.145 +  in solver_info_of (K []) all_options ctxt end
   3.146 +
   3.147 +val setup_solver =
   3.148 +  Attrib.setup @{binding smt_solver}
   3.149 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
   3.150 +      (Thm.declaration_attribute o K o select_solver))
   3.151 +    "SMT solver configuration"
   3.152 +
   3.153 +
   3.154 +(* options *)
   3.155 +
   3.156 +val oracle = Attrib.setup_config_bool @{binding smt_oracle} (K true)
   3.157 +val datatypes = Attrib.setup_config_bool @{binding smt_datatypes} (K false)
   3.158 +val timeout = Attrib.setup_config_real @{binding smt_timeout} (K 30.0)
   3.159 +val random_seed = Attrib.setup_config_int @{binding smt_random_seed} (K 1)
   3.160 +val read_only_certificates = Attrib.setup_config_bool @{binding smt_read_only_certificates} (K false)
   3.161 +val verbose = Attrib.setup_config_bool @{binding smt_verbose} (K true)
   3.162 +val trace = Attrib.setup_config_bool @{binding smt_trace} (K false)
   3.163 +val trace_used_facts = Attrib.setup_config_bool @{binding smt_trace_used_facts} (K false)
   3.164 +val monomorph_limit = Attrib.setup_config_int @{binding smt_monomorph_limit} (K 10)
   3.165 +val monomorph_instances = Attrib.setup_config_int @{binding smt_monomorph_instances} (K 500)
   3.166 +val infer_triggers = Attrib.setup_config_bool @{binding smt_infer_triggers} (K false)
   3.167 +val filter_only_facts = Attrib.setup_config_bool @{binding smt_filter_only_facts} (K false)
   3.168 +val debug_files = Attrib.setup_config_string @{binding smt_debug_files} (K "")
   3.169 +
   3.170 +
   3.171 +(* diagnostics *)
   3.172 +
   3.173 +fun cond_trace flag f x = if flag then tracing ("SMT: " ^ f x) else ()
   3.174 +
   3.175 +fun verbose_msg ctxt = cond_trace (Config.get ctxt verbose)
   3.176 +
   3.177 +fun trace_msg ctxt = cond_trace (Config.get ctxt trace)
   3.178 +
   3.179 +
   3.180 +(* tools *)
   3.181 +
   3.182 +fun with_timeout ctxt f x =
   3.183 +  TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) f x
   3.184 +  handle TimeLimit.TimeOut => raise Old_SMT_Failure.SMT Old_SMT_Failure.Time_Out
   3.185 +
   3.186 +
   3.187 +(* certificates *)
   3.188 +
   3.189 +(* FIXME just one data slot (record) per program unit *)
   3.190 +structure Certificates = Generic_Data
   3.191 +(
   3.192 +  type T = Cache_IO.cache option
   3.193 +  val empty = NONE
   3.194 +  val extend = I
   3.195 +  fun merge (s, _) = s  (* FIXME merge options!? *)
   3.196 +)
   3.197 +
   3.198 +val get_certificates_path =
   3.199 +  Option.map (Cache_IO.cache_path_of) o Certificates.get o Context.Proof
   3.200 +
   3.201 +fun select_certificates name context = context |> Certificates.put (
   3.202 +  if name = "" then NONE
   3.203 +  else
   3.204 +    Path.explode name
   3.205 +    |> Path.append (Resources.master_directory (Context.theory_of context))
   3.206 +    |> SOME o Cache_IO.unsynchronized_init)
   3.207 +
   3.208 +val certificates_of = Certificates.get o Context.Proof
   3.209 +
   3.210 +val setup_certificates =
   3.211 +  Attrib.setup @{binding smt_certificates}
   3.212 +    (Scan.lift (@{keyword "="} |-- Args.name) >>
   3.213 +      (Thm.declaration_attribute o K o select_certificates))
   3.214 +    "SMT certificates configuration"
   3.215 +
   3.216 +
   3.217 +(* setup *)
   3.218 +
   3.219 +val setup =
   3.220 +  setup_solver #>
   3.221 +  setup_certificates
   3.222 +
   3.223 +fun print_setup ctxt =
   3.224 +  let
   3.225 +    fun string_of_bool b = if b then "true" else "false"
   3.226 +
   3.227 +    val names = available_solvers_of ctxt
   3.228 +    val ns = if null names then ["(none)"] else sort_strings names
   3.229 +    val n = the_default "(none)" (solver_name_of ctxt)
   3.230 +    val opts = solver_options_of ctxt
   3.231 +    
   3.232 +    val t = string_of_real (Config.get ctxt timeout)
   3.233 +
   3.234 +    val certs_filename =
   3.235 +      (case get_certificates_path ctxt of
   3.236 +        SOME path => Path.print path
   3.237 +      | NONE => "(disabled)")
   3.238 +  in
   3.239 +    Pretty.writeln (Pretty.big_list "SMT setup:" [
   3.240 +      Pretty.str ("Current SMT solver: " ^ n),
   3.241 +      Pretty.str ("Current SMT solver options: " ^ space_implode " " opts),
   3.242 +      Pretty.str_list "Available SMT solvers: "  "" ns,
   3.243 +      Pretty.str ("Current timeout: " ^ t ^ " seconds"),
   3.244 +      Pretty.str ("With proofs: " ^
   3.245 +        string_of_bool (not (Config.get ctxt oracle))),
   3.246 +      Pretty.str ("Certificates cache: " ^ certs_filename),
   3.247 +      Pretty.str ("Fixed certificates: " ^
   3.248 +        string_of_bool (Config.get ctxt read_only_certificates))])
   3.249 +  end
   3.250 +
   3.251 +val _ =
   3.252 +  Outer_Syntax.improper_command @{command_spec "smt_status"}
   3.253 +    "show the available SMT solvers, the currently selected SMT solver, \
   3.254 +    \and the values of SMT configuration options"
   3.255 +    (Scan.succeed (Toplevel.keep (print_setup o Toplevel.context_of)))
   3.256 +
   3.257 +end
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Library/Old_SMT/old_smt_datatypes.ML	Thu Aug 28 00:40:38 2014 +0200
     4.3 @@ -0,0 +1,94 @@
     4.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_datatypes.ML
     4.5 +    Author:     Sascha Boehme, TU Muenchen
     4.6 +
     4.7 +Collector functions for common type declarations and their representation
     4.8 +as algebraic datatypes.
     4.9 +*)
    4.10 +
    4.11 +signature OLD_SMT_DATATYPES =
    4.12 +sig
    4.13 +  val add_decls: typ ->
    4.14 +    (typ * (term * term list) list) list list * Proof.context ->
    4.15 +    (typ * (term * term list) list) list list * Proof.context
    4.16 +end
    4.17 +
    4.18 +structure Old_SMT_Datatypes: OLD_SMT_DATATYPES =
    4.19 +struct
    4.20 +
    4.21 +fun mk_selectors T Ts =
    4.22 +  Variable.variant_fixes (replicate (length Ts) "select")
    4.23 +  #>> map2 (fn U => fn n => Free (n, T --> U)) Ts
    4.24 +
    4.25 +
    4.26 +(* free constructor type declarations *)
    4.27 +
    4.28 +fun get_ctr_sugar_decl ({ctrs, ...} : Ctr_Sugar.ctr_sugar) T Ts ctxt =
    4.29 +  let
    4.30 +    fun mk_constr ctr0 =
    4.31 +      let val ctr = Ctr_Sugar.mk_ctr Ts ctr0 in
    4.32 +        mk_selectors T (binder_types (fastype_of ctr)) #>> pair ctr
    4.33 +      end
    4.34 +  in
    4.35 +    fold_map mk_constr ctrs ctxt
    4.36 +    |>> (pair T #> single)
    4.37 +  end
    4.38 +
    4.39 +
    4.40 +(* typedef declarations *)
    4.41 +
    4.42 +fun get_typedef_decl (({Abs_name, Rep_name, abs_type, rep_type, ...}, {Abs_inverse, ...})
    4.43 +    : Typedef.info) T Ts =
    4.44 +  if can (curry (op RS) @{thm UNIV_I}) Abs_inverse then
    4.45 +    let
    4.46 +      val env = snd (Term.dest_Type abs_type) ~~ Ts
    4.47 +      val instT = Term.map_atyps (perhaps (AList.lookup (op =) env))
    4.48 +
    4.49 +      val constr = Const (Abs_name, instT (rep_type --> abs_type))
    4.50 +      val select = Const (Rep_name, instT (abs_type --> rep_type))
    4.51 +    in [(T, [(constr, [select])])] end
    4.52 +  else
    4.53 +    []
    4.54 +
    4.55 +
    4.56 +(* collection of declarations *)
    4.57 +
    4.58 +fun declared declss T = exists (exists (equal T o fst)) declss
    4.59 +fun declared' dss T = exists (exists (equal T o fst) o snd) dss
    4.60 +
    4.61 +fun get_decls T n Ts ctxt =
    4.62 +  (case Ctr_Sugar.ctr_sugar_of ctxt n of
    4.63 +    SOME ctr_sugar => get_ctr_sugar_decl ctr_sugar T Ts ctxt
    4.64 +  | NONE =>
    4.65 +      (case Typedef.get_info ctxt n of
    4.66 +        [] => ([], ctxt)
    4.67 +      | info :: _ => (get_typedef_decl info T Ts, ctxt)))
    4.68 +
    4.69 +fun add_decls T (declss, ctxt) =
    4.70 +  let
    4.71 +    fun depends Ts ds = exists (member (op =) (map fst ds)) Ts
    4.72 +
    4.73 +    fun add (TFree _) = I
    4.74 +      | add (TVar _) = I
    4.75 +      | add (T as Type (@{type_name fun}, _)) =
    4.76 +          fold add (Term.body_type T :: Term.binder_types T)
    4.77 +      | add @{typ bool} = I
    4.78 +      | add (T as Type (n, Ts)) = (fn (dss, ctxt1) =>
    4.79 +          if declared declss T orelse declared' dss T then (dss, ctxt1)
    4.80 +          else if Old_SMT_Builtin.is_builtin_typ_ext ctxt1 T then (dss, ctxt1)
    4.81 +          else
    4.82 +            (case get_decls T n Ts ctxt1 of
    4.83 +              ([], _) => (dss, ctxt1)
    4.84 +            | (ds, ctxt2) =>
    4.85 +                let
    4.86 +                  val constrTs =
    4.87 +                    maps (map (snd o Term.dest_Const o fst) o snd) ds
    4.88 +                  val Us = fold (union (op =) o Term.binder_types) constrTs []
    4.89 +
    4.90 +                  fun ins [] = [(Us, ds)]
    4.91 +                    | ins ((Uds as (Us', _)) :: Udss) =
    4.92 +                        if depends Us' ds then (Us, ds) :: Uds :: Udss
    4.93 +                        else Uds :: ins Udss
    4.94 +            in fold add Us (ins dss, ctxt2) end))
    4.95 +  in add T ([], ctxt) |>> append declss o map snd end
    4.96 +
    4.97 +end
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Library/Old_SMT/old_smt_failure.ML	Thu Aug 28 00:40:38 2014 +0200
     5.3 @@ -0,0 +1,61 @@
     5.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_failure.ML
     5.5 +    Author:     Sascha Boehme, TU Muenchen
     5.6 +
     5.7 +Failures and exception of SMT.
     5.8 +*)
     5.9 +
    5.10 +signature OLD_SMT_FAILURE =
    5.11 +sig
    5.12 +  type counterexample = {
    5.13 +    is_real_cex: bool,
    5.14 +    free_constraints: term list,
    5.15 +    const_defs: term list}
    5.16 +  datatype failure =
    5.17 +    Counterexample of counterexample |
    5.18 +    Time_Out |
    5.19 +    Out_Of_Memory |
    5.20 +    Abnormal_Termination of int |
    5.21 +    Other_Failure of string
    5.22 +  val pretty_counterexample: Proof.context -> counterexample -> Pretty.T
    5.23 +  val string_of_failure: Proof.context -> failure -> string
    5.24 +  exception SMT of failure
    5.25 +end
    5.26 +
    5.27 +structure Old_SMT_Failure: OLD_SMT_FAILURE =
    5.28 +struct
    5.29 +
    5.30 +type counterexample = {
    5.31 +  is_real_cex: bool,
    5.32 +  free_constraints: term list,
    5.33 +  const_defs: term list}
    5.34 +
    5.35 +datatype failure =
    5.36 +  Counterexample of counterexample |
    5.37 +  Time_Out |
    5.38 +  Out_Of_Memory |
    5.39 +  Abnormal_Termination of int |
    5.40 +  Other_Failure of string
    5.41 +
    5.42 +fun pretty_counterexample ctxt {is_real_cex, free_constraints, const_defs} =
    5.43 +  let
    5.44 +    val msg =
    5.45 +      if is_real_cex then "Counterexample found (possibly spurious)"
    5.46 +      else "Potential counterexample found"
    5.47 +  in
    5.48 +    if null free_constraints andalso null const_defs then Pretty.str msg
    5.49 +    else
    5.50 +      Pretty.big_list (msg ^ ":")
    5.51 +        (map (Syntax.pretty_term ctxt) (free_constraints @ const_defs))
    5.52 +  end
    5.53 +
    5.54 +fun string_of_failure ctxt (Counterexample cex) =
    5.55 +      Pretty.string_of (pretty_counterexample ctxt cex)
    5.56 +  | string_of_failure _ Time_Out = "Timed out"
    5.57 +  | string_of_failure _ Out_Of_Memory = "Ran out of memory"
    5.58 +  | string_of_failure _ (Abnormal_Termination err) =
    5.59 +      "Solver terminated abnormally with error code " ^ string_of_int err
    5.60 +  | string_of_failure _ (Other_Failure msg) = msg
    5.61 +
    5.62 +exception SMT of failure
    5.63 +
    5.64 +end
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Library/Old_SMT/old_smt_normalize.ML	Thu Aug 28 00:40:38 2014 +0200
     6.3 @@ -0,0 +1,652 @@
     6.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_normalize.ML
     6.5 +    Author:     Sascha Boehme, TU Muenchen
     6.6 +
     6.7 +Normalization steps on theorems required by SMT solvers.
     6.8 +*)
     6.9 +
    6.10 +signature OLD_SMT_NORMALIZE =
    6.11 +sig
    6.12 +  val drop_fact_warning: Proof.context -> thm -> unit
    6.13 +  val atomize_conv: Proof.context -> conv
    6.14 +  type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
    6.15 +  val add_extra_norm: Old_SMT_Utils.class * extra_norm -> Context.generic ->
    6.16 +    Context.generic
    6.17 +  val normalize: (int * (int option * thm)) list -> Proof.context ->
    6.18 +    (int * thm) list * Proof.context
    6.19 +  val setup: theory -> theory
    6.20 +end
    6.21 +
    6.22 +structure Old_SMT_Normalize: OLD_SMT_NORMALIZE =
    6.23 +struct
    6.24 +
    6.25 +fun drop_fact_warning ctxt =
    6.26 +  Old_SMT_Config.verbose_msg ctxt (prefix "Warning: dropping assumption: " o
    6.27 +    Display.string_of_thm ctxt)
    6.28 +
    6.29 +
    6.30 +(* general theorem normalizations *)
    6.31 +
    6.32 +(** instantiate elimination rules **)
    6.33 + 
    6.34 +local
    6.35 +  val (cpfalse, cfalse) =
    6.36 +    `Old_SMT_Utils.mk_cprop (Thm.cterm_of @{theory} @{const False})
    6.37 +
    6.38 +  fun inst f ct thm =
    6.39 +    let val cv = f (Drule.strip_imp_concl (Thm.cprop_of thm))
    6.40 +    in Thm.instantiate ([], [(cv, ct)]) thm end
    6.41 +in
    6.42 +
    6.43 +fun instantiate_elim thm =
    6.44 +  (case Thm.concl_of thm of
    6.45 +    @{const Trueprop} $ Var (_, @{typ bool}) => inst Thm.dest_arg cfalse thm
    6.46 +  | Var _ => inst I cpfalse thm
    6.47 +  | _ => thm)
    6.48 +
    6.49 +end
    6.50 +
    6.51 +
    6.52 +(** normalize definitions **)
    6.53 +
    6.54 +fun norm_def thm =
    6.55 +  (case Thm.prop_of thm of
    6.56 +    @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _ $ Abs _) =>
    6.57 +      norm_def (thm RS @{thm fun_cong})
    6.58 +  | Const (@{const_name Pure.eq}, _) $ _ $ Abs _ =>
    6.59 +      norm_def (thm RS @{thm meta_eq_to_obj_eq})
    6.60 +  | _ => thm)
    6.61 +
    6.62 +
    6.63 +(** atomization **)
    6.64 +
    6.65 +fun atomize_conv ctxt ct =
    6.66 +  (case Thm.term_of ct of
    6.67 +    @{const Pure.imp} $ _ $ _ =>
    6.68 +      Conv.binop_conv (atomize_conv ctxt) then_conv
    6.69 +      Conv.rewr_conv @{thm atomize_imp}
    6.70 +  | Const (@{const_name Pure.eq}, _) $ _ $ _ =>
    6.71 +      Conv.binop_conv (atomize_conv ctxt) then_conv
    6.72 +      Conv.rewr_conv @{thm atomize_eq}
    6.73 +  | Const (@{const_name Pure.all}, _) $ Abs _ =>
    6.74 +      Conv.binder_conv (atomize_conv o snd) ctxt then_conv
    6.75 +      Conv.rewr_conv @{thm atomize_all}
    6.76 +  | _ => Conv.all_conv) ct
    6.77 +
    6.78 +val setup_atomize =
    6.79 +  fold Old_SMT_Builtin.add_builtin_fun_ext'' [@{const_name Pure.imp},
    6.80 +    @{const_name Pure.eq}, @{const_name Pure.all}, @{const_name Trueprop}]
    6.81 +
    6.82 +
    6.83 +(** unfold special quantifiers **)
    6.84 +
    6.85 +local
    6.86 +  val ex1_def = mk_meta_eq @{lemma
    6.87 +    "Ex1 = (%P. EX x. P x & (ALL y. P y --> y = x))"
    6.88 +    by (rule ext) (simp only: Ex1_def)}
    6.89 +
    6.90 +  val ball_def = mk_meta_eq @{lemma "Ball = (%A P. ALL x. x : A --> P x)"
    6.91 +    by (rule ext)+ (rule Ball_def)}
    6.92 +
    6.93 +  val bex_def = mk_meta_eq @{lemma "Bex = (%A P. EX x. x : A & P x)"
    6.94 +    by (rule ext)+ (rule Bex_def)}
    6.95 +
    6.96 +  val special_quants = [(@{const_name Ex1}, ex1_def),
    6.97 +    (@{const_name Ball}, ball_def), (@{const_name Bex}, bex_def)]
    6.98 +  
    6.99 +  fun special_quant (Const (n, _)) = AList.lookup (op =) special_quants n
   6.100 +    | special_quant _ = NONE
   6.101 +
   6.102 +  fun special_quant_conv _ ct =
   6.103 +    (case special_quant (Thm.term_of ct) of
   6.104 +      SOME thm => Conv.rewr_conv thm
   6.105 +    | NONE => Conv.all_conv) ct
   6.106 +in
   6.107 +
   6.108 +fun unfold_special_quants_conv ctxt =
   6.109 +  Old_SMT_Utils.if_exists_conv (is_some o special_quant)
   6.110 +    (Conv.top_conv special_quant_conv ctxt)
   6.111 +
   6.112 +val setup_unfolded_quants =
   6.113 +  fold (Old_SMT_Builtin.add_builtin_fun_ext'' o fst) special_quants
   6.114 +
   6.115 +end
   6.116 +
   6.117 +
   6.118 +(** trigger inference **)
   6.119 +
   6.120 +local
   6.121 +  (*** check trigger syntax ***)
   6.122 +
   6.123 +  fun dest_trigger (Const (@{const_name pat}, _) $ _) = SOME true
   6.124 +    | dest_trigger (Const (@{const_name nopat}, _) $ _) = SOME false
   6.125 +    | dest_trigger _ = NONE
   6.126 +
   6.127 +  fun eq_list [] = false
   6.128 +    | eq_list (b :: bs) = forall (equal b) bs
   6.129 +
   6.130 +  fun proper_trigger t =
   6.131 +    t
   6.132 +    |> these o try HOLogic.dest_list
   6.133 +    |> map (map_filter dest_trigger o these o try HOLogic.dest_list)
   6.134 +    |> (fn [] => false | bss => forall eq_list bss)
   6.135 +
   6.136 +  fun proper_quant inside f t =
   6.137 +    (case t of
   6.138 +      Const (@{const_name All}, _) $ Abs (_, _, u) => proper_quant true f u
   6.139 +    | Const (@{const_name Ex}, _) $ Abs (_, _, u) => proper_quant true f u
   6.140 +    | @{const trigger} $ p $ u =>
   6.141 +        (if inside then f p else false) andalso proper_quant false f u
   6.142 +    | Abs (_, _, u) => proper_quant false f u
   6.143 +    | u1 $ u2 => proper_quant false f u1 andalso proper_quant false f u2
   6.144 +    | _ => true)
   6.145 +
   6.146 +  fun check_trigger_error ctxt t =
   6.147 +    error ("SMT triggers must only occur under quantifier and multipatterns " ^
   6.148 +      "must have the same kind: " ^ Syntax.string_of_term ctxt t)
   6.149 +
   6.150 +  fun check_trigger_conv ctxt ct =
   6.151 +    if proper_quant false proper_trigger (Old_SMT_Utils.term_of ct) then
   6.152 +      Conv.all_conv ct
   6.153 +    else check_trigger_error ctxt (Thm.term_of ct)
   6.154 +
   6.155 +
   6.156 +  (*** infer simple triggers ***)
   6.157 +
   6.158 +  fun dest_cond_eq ct =
   6.159 +    (case Thm.term_of ct of
   6.160 +      Const (@{const_name HOL.eq}, _) $ _ $ _ => Thm.dest_binop ct
   6.161 +    | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct)
   6.162 +    | _ => raise CTERM ("no equation", [ct]))
   6.163 +
   6.164 +  fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n)
   6.165 +    | get_constrs _ _ = []
   6.166 +
   6.167 +  fun is_constr thy (n, T) =
   6.168 +    let fun match (m, U) = m = n andalso Sign.typ_instance thy (T, U)
   6.169 +    in can (the o find_first match o get_constrs thy o Term.body_type) T end
   6.170 +
   6.171 +  fun is_constr_pat thy t =
   6.172 +    (case Term.strip_comb t of
   6.173 +      (Free _, []) => true
   6.174 +    | (Const c, ts) => is_constr thy c andalso forall (is_constr_pat thy) ts
   6.175 +    | _ => false)
   6.176 +
   6.177 +  fun is_simp_lhs ctxt t =
   6.178 +    (case Term.strip_comb t of
   6.179 +      (Const c, ts as _ :: _) =>
   6.180 +        not (Old_SMT_Builtin.is_builtin_fun_ext ctxt c ts) andalso
   6.181 +        forall (is_constr_pat (Proof_Context.theory_of ctxt)) ts
   6.182 +    | _ => false)
   6.183 +
   6.184 +  fun has_all_vars vs t =
   6.185 +    subset (op aconv) (vs, map Free (Term.add_frees t []))
   6.186 +
   6.187 +  fun minimal_pats vs ct =
   6.188 +    if has_all_vars vs (Thm.term_of ct) then
   6.189 +      (case Thm.term_of ct of
   6.190 +        _ $ _ =>
   6.191 +          (case pairself (minimal_pats vs) (Thm.dest_comb ct) of
   6.192 +            ([], []) => [[ct]]
   6.193 +          | (ctss, ctss') => union (eq_set (op aconvc)) ctss ctss')
   6.194 +      | _ => [])
   6.195 +    else []
   6.196 +
   6.197 +  fun proper_mpat _ _ _ [] = false
   6.198 +    | proper_mpat thy gen u cts =
   6.199 +        let
   6.200 +          val tps = (op ~~) (`gen (map Thm.term_of cts))
   6.201 +          fun some_match u = tps |> exists (fn (t', t) =>
   6.202 +            Pattern.matches thy (t', u) andalso not (t aconv u))
   6.203 +        in not (Term.exists_subterm some_match u) end
   6.204 +
   6.205 +  val pat =
   6.206 +    Old_SMT_Utils.mk_const_pat @{theory} @{const_name pat} Old_SMT_Utils.destT1
   6.207 +  fun mk_pat ct = Thm.apply (Old_SMT_Utils.instT' ct pat) ct
   6.208 +
   6.209 +  fun mk_clist T = pairself (Thm.cterm_of @{theory})
   6.210 +    (HOLogic.cons_const T, HOLogic.nil_const T)
   6.211 +  fun mk_list (ccons, cnil) f cts = fold_rev (Thm.mk_binop ccons o f) cts cnil
   6.212 +  val mk_pat_list = mk_list (mk_clist @{typ pattern})
   6.213 +  val mk_mpat_list = mk_list (mk_clist @{typ "pattern list"})  
   6.214 +  fun mk_trigger ctss = mk_mpat_list (mk_pat_list mk_pat) ctss
   6.215 +
   6.216 +  val trigger_eq =
   6.217 +    mk_meta_eq @{lemma "p = trigger t p" by (simp add: trigger_def)}
   6.218 +
   6.219 +  fun insert_trigger_conv [] ct = Conv.all_conv ct
   6.220 +    | insert_trigger_conv ctss ct =
   6.221 +        let val (ctr, cp) = Thm.dest_binop (Thm.rhs_of trigger_eq) ||> rpair ct
   6.222 +        in Thm.instantiate ([], [cp, (ctr, mk_trigger ctss)]) trigger_eq end
   6.223 +
   6.224 +  fun infer_trigger_eq_conv outer_ctxt (ctxt, cvs) ct =
   6.225 +    let
   6.226 +      val (lhs, rhs) = dest_cond_eq ct
   6.227 +
   6.228 +      val vs = map Thm.term_of cvs
   6.229 +      val thy = Proof_Context.theory_of ctxt
   6.230 +
   6.231 +      fun get_mpats ct =
   6.232 +        if is_simp_lhs ctxt (Thm.term_of ct) then minimal_pats vs ct
   6.233 +        else []
   6.234 +      val gen = Variable.export_terms ctxt outer_ctxt
   6.235 +      val filter_mpats = filter (proper_mpat thy gen (Thm.term_of rhs))
   6.236 +
   6.237 +    in insert_trigger_conv (filter_mpats (get_mpats lhs)) ct end
   6.238 +
   6.239 +  fun has_trigger (@{const trigger} $ _ $ _) = true
   6.240 +    | has_trigger _ = false
   6.241 +
   6.242 +  fun try_trigger_conv cv ct =
   6.243 +    if Old_SMT_Utils.under_quant has_trigger (Old_SMT_Utils.term_of ct) then
   6.244 +      Conv.all_conv ct
   6.245 +    else Conv.try_conv cv ct
   6.246 +
   6.247 +  fun infer_trigger_conv ctxt =
   6.248 +    if Config.get ctxt Old_SMT_Config.infer_triggers then
   6.249 +      try_trigger_conv
   6.250 +        (Old_SMT_Utils.under_quant_conv (infer_trigger_eq_conv ctxt) ctxt)
   6.251 +    else Conv.all_conv
   6.252 +in
   6.253 +
   6.254 +fun trigger_conv ctxt =
   6.255 +  Old_SMT_Utils.prop_conv
   6.256 +    (check_trigger_conv ctxt then_conv infer_trigger_conv ctxt)
   6.257 +
   6.258 +val setup_trigger =
   6.259 +  fold Old_SMT_Builtin.add_builtin_fun_ext''
   6.260 +    [@{const_name pat}, @{const_name nopat}, @{const_name trigger}]
   6.261 +
   6.262 +end
   6.263 +
   6.264 +
   6.265 +(** adding quantifier weights **)
   6.266 +
   6.267 +local
   6.268 +  (*** check weight syntax ***)
   6.269 +
   6.270 +  val has_no_weight =
   6.271 +    not o Term.exists_subterm (fn @{const weight} => true | _ => false)
   6.272 +
   6.273 +  fun is_weight (@{const weight} $ w $ t) =
   6.274 +        (case try HOLogic.dest_number w of
   6.275 +          SOME (_, i) => i >= 0 andalso has_no_weight t
   6.276 +        | _ => false)
   6.277 +    | is_weight t = has_no_weight t
   6.278 +
   6.279 +  fun proper_trigger (@{const trigger} $ _ $ t) = is_weight t
   6.280 +    | proper_trigger t = is_weight t 
   6.281 +
   6.282 +  fun check_weight_error ctxt t =
   6.283 +    error ("SMT weight must be a non-negative number and must only occur " ^
   6.284 +      "under the top-most quantifier and an optional trigger: " ^
   6.285 +      Syntax.string_of_term ctxt t)
   6.286 +
   6.287 +  fun check_weight_conv ctxt ct =
   6.288 +    if Old_SMT_Utils.under_quant proper_trigger (Old_SMT_Utils.term_of ct) then
   6.289 +      Conv.all_conv ct
   6.290 +    else check_weight_error ctxt (Thm.term_of ct)
   6.291 +
   6.292 +
   6.293 +  (*** insertion of weights ***)
   6.294 +
   6.295 +  fun under_trigger_conv cv ct =
   6.296 +    (case Thm.term_of ct of
   6.297 +      @{const trigger} $ _ $ _ => Conv.arg_conv cv
   6.298 +    | _ => cv) ct
   6.299 +
   6.300 +  val weight_eq =
   6.301 +    mk_meta_eq @{lemma "p = weight i p" by (simp add: weight_def)}
   6.302 +  fun mk_weight_eq w =
   6.303 +    let val cv = Thm.dest_arg1 (Thm.rhs_of weight_eq)
   6.304 +    in
   6.305 +      Thm.instantiate ([], [(cv, Numeral.mk_cnumber @{ctyp int} w)]) weight_eq
   6.306 +    end
   6.307 +
   6.308 +  fun add_weight_conv NONE _ = Conv.all_conv
   6.309 +    | add_weight_conv (SOME weight) ctxt =
   6.310 +        let val cv = Conv.rewr_conv (mk_weight_eq weight)
   6.311 +        in Old_SMT_Utils.under_quant_conv (K (under_trigger_conv cv)) ctxt end
   6.312 +in
   6.313 +
   6.314 +fun weight_conv weight ctxt = 
   6.315 +  Old_SMT_Utils.prop_conv
   6.316 +    (check_weight_conv ctxt then_conv add_weight_conv weight ctxt)
   6.317 +
   6.318 +val setup_weight = Old_SMT_Builtin.add_builtin_fun_ext'' @{const_name weight}
   6.319 +
   6.320 +end
   6.321 +
   6.322 +
   6.323 +(** combined general normalizations **)
   6.324 +
   6.325 +fun gen_normalize1_conv ctxt weight =
   6.326 +  atomize_conv ctxt then_conv
   6.327 +  unfold_special_quants_conv ctxt then_conv
   6.328 +  Thm.beta_conversion true then_conv
   6.329 +  trigger_conv ctxt then_conv
   6.330 +  weight_conv weight ctxt
   6.331 +
   6.332 +fun gen_normalize1 ctxt weight thm =
   6.333 +  thm
   6.334 +  |> instantiate_elim
   6.335 +  |> norm_def
   6.336 +  |> Conv.fconv_rule (Thm.beta_conversion true then_conv Thm.eta_conversion)
   6.337 +  |> Drule.forall_intr_vars
   6.338 +  |> Conv.fconv_rule (gen_normalize1_conv ctxt weight)
   6.339 +
   6.340 +fun gen_norm1_safe ctxt (i, (weight, thm)) =
   6.341 +  (case try (gen_normalize1 ctxt weight) thm of
   6.342 +    SOME thm' => SOME (i, thm')
   6.343 +  | NONE => (drop_fact_warning ctxt thm; NONE))
   6.344 +
   6.345 +fun gen_normalize ctxt iwthms = map_filter (gen_norm1_safe ctxt) iwthms
   6.346 +
   6.347 +
   6.348 +
   6.349 +(* unfolding of definitions and theory-specific rewritings *)
   6.350 +
   6.351 +fun expand_head_conv cv ct =
   6.352 +  (case Thm.term_of ct of
   6.353 +    _ $ _ =>
   6.354 +      Conv.fun_conv (expand_head_conv cv) then_conv
   6.355 +      Conv.try_conv (Thm.beta_conversion false)
   6.356 +  | _ => cv) ct
   6.357 +
   6.358 +
   6.359 +(** rewrite bool case expressions as if expressions **)
   6.360 +
   6.361 +local
   6.362 +  fun is_case_bool (Const (@{const_name "bool.case_bool"}, _)) = true
   6.363 +    | is_case_bool _ = false
   6.364 +
   6.365 +  val thm = mk_meta_eq @{lemma
   6.366 +    "case_bool = (%x y P. if P then x else y)" by (rule ext)+ simp}
   6.367 +
   6.368 +  fun unfold_conv _ =
   6.369 +    Old_SMT_Utils.if_true_conv (is_case_bool o Term.head_of)
   6.370 +      (expand_head_conv (Conv.rewr_conv thm))
   6.371 +in
   6.372 +
   6.373 +fun rewrite_case_bool_conv ctxt =
   6.374 +  Old_SMT_Utils.if_exists_conv is_case_bool (Conv.top_conv unfold_conv ctxt)
   6.375 +
   6.376 +val setup_case_bool =
   6.377 +  Old_SMT_Builtin.add_builtin_fun_ext'' @{const_name "bool.case_bool"}
   6.378 +
   6.379 +end
   6.380 +
   6.381 +
   6.382 +(** unfold abs, min and max **)
   6.383 +
   6.384 +local
   6.385 +  val abs_def = mk_meta_eq @{lemma
   6.386 +    "abs = (%a::'a::abs_if. if a < 0 then - a else a)"
   6.387 +    by (rule ext) (rule abs_if)}
   6.388 +
   6.389 +  val min_def = mk_meta_eq @{lemma "min = (%a b. if a <= b then a else b)"
   6.390 +    by (rule ext)+ (rule min_def)}
   6.391 +
   6.392 +  val max_def = mk_meta_eq  @{lemma "max = (%a b. if a <= b then b else a)"
   6.393 +    by (rule ext)+ (rule max_def)}
   6.394 +
   6.395 +  val defs = [(@{const_name min}, min_def), (@{const_name max}, max_def),
   6.396 +    (@{const_name abs}, abs_def)]
   6.397 +
   6.398 +  fun is_builtinT ctxt T =
   6.399 +    Old_SMT_Builtin.is_builtin_typ_ext ctxt (Term.domain_type T)
   6.400 +
   6.401 +  fun abs_min_max ctxt (Const (n, T)) =
   6.402 +        (case AList.lookup (op =) defs n of
   6.403 +          NONE => NONE
   6.404 +        | SOME thm => if is_builtinT ctxt T then SOME thm else NONE)
   6.405 +    | abs_min_max _ _ = NONE
   6.406 +
   6.407 +  fun unfold_amm_conv ctxt ct =
   6.408 +    (case abs_min_max ctxt (Term.head_of (Thm.term_of ct)) of
   6.409 +      SOME thm => expand_head_conv (Conv.rewr_conv thm)
   6.410 +    | NONE => Conv.all_conv) ct
   6.411 +in
   6.412 +
   6.413 +fun unfold_abs_min_max_conv ctxt =
   6.414 +  Old_SMT_Utils.if_exists_conv (is_some o abs_min_max ctxt)
   6.415 +    (Conv.top_conv unfold_amm_conv ctxt)
   6.416 +  
   6.417 +val setup_abs_min_max = fold (Old_SMT_Builtin.add_builtin_fun_ext'' o fst) defs
   6.418 +
   6.419 +end
   6.420 +
   6.421 +
   6.422 +(** embedding of standard natural number operations into integer operations **)
   6.423 +
   6.424 +local
   6.425 +  val nat_embedding = @{lemma
   6.426 +    "ALL n. nat (int n) = n"
   6.427 +    "ALL i. i >= 0 --> int (nat i) = i"
   6.428 +    "ALL i. i < 0 --> int (nat i) = 0"
   6.429 +    by simp_all}
   6.430 +
   6.431 +  val simple_nat_ops = [
   6.432 +    @{const less (nat)}, @{const less_eq (nat)},
   6.433 +    @{const Suc}, @{const plus (nat)}, @{const minus (nat)}]
   6.434 +
   6.435 +  val mult_nat_ops =
   6.436 +    [@{const times (nat)}, @{const div (nat)}, @{const mod (nat)}]
   6.437 +
   6.438 +  val nat_ops = simple_nat_ops @ mult_nat_ops
   6.439 +
   6.440 +  val nat_consts = nat_ops @ [@{const numeral (nat)},
   6.441 +    @{const zero_class.zero (nat)}, @{const one_class.one (nat)}]
   6.442 +
   6.443 +  val nat_int_coercions = [@{const of_nat (int)}, @{const nat}]
   6.444 +
   6.445 +  val builtin_nat_ops = nat_int_coercions @ simple_nat_ops
   6.446 +
   6.447 +  val is_nat_const = member (op aconv) nat_consts
   6.448 +
   6.449 +  fun is_nat_const' @{const of_nat (int)} = true
   6.450 +    | is_nat_const' t = is_nat_const t
   6.451 +
   6.452 +  val expands = map mk_meta_eq @{lemma
   6.453 +    "0 = nat 0"
   6.454 +    "1 = nat 1"
   6.455 +    "(numeral :: num => nat) = (%i. nat (numeral i))"
   6.456 +    "op < = (%a b. int a < int b)"
   6.457 +    "op <= = (%a b. int a <= int b)"
   6.458 +    "Suc = (%a. nat (int a + 1))"
   6.459 +    "op + = (%a b. nat (int a + int b))"
   6.460 +    "op - = (%a b. nat (int a - int b))"
   6.461 +    "op * = (%a b. nat (int a * int b))"
   6.462 +    "op div = (%a b. nat (int a div int b))"
   6.463 +    "op mod = (%a b. nat (int a mod int b))"
   6.464 +    by (fastforce simp add: nat_mult_distrib nat_div_distrib nat_mod_distrib)+}
   6.465 +
   6.466 +  val ints = map mk_meta_eq @{lemma
   6.467 +    "int 0 = 0"
   6.468 +    "int 1 = 1"
   6.469 +    "int (Suc n) = int n + 1"
   6.470 +    "int (n + m) = int n + int m"
   6.471 +    "int (n - m) = int (nat (int n - int m))"
   6.472 +    "int (n * m) = int n * int m"
   6.473 +    "int (n div m) = int n div int m"
   6.474 +    "int (n mod m) = int n mod int m"
   6.475 +    by (auto simp add: int_mult zdiv_int zmod_int)}
   6.476 +
   6.477 +  val int_if = mk_meta_eq @{lemma
   6.478 +    "int (if P then n else m) = (if P then int n else int m)"
   6.479 +    by simp}
   6.480 +
   6.481 +  fun mk_number_eq ctxt i lhs =
   6.482 +    let
   6.483 +      val eq = Old_SMT_Utils.mk_cequals lhs (Numeral.mk_cnumber @{ctyp int} i)
   6.484 +      val tac =
   6.485 +        Simplifier.simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm Int.int_numeral}]) 1
   6.486 +    in Goal.norm_result ctxt (Goal.prove_internal ctxt [] eq (K tac)) end
   6.487 +
   6.488 +  fun ite_conv cv1 cv2 =
   6.489 +    Conv.combination_conv (Conv.combination_conv (Conv.arg_conv cv1) cv2) cv2
   6.490 +
   6.491 +  fun int_conv ctxt ct =
   6.492 +    (case Thm.term_of ct of
   6.493 +      @{const of_nat (int)} $ (n as (@{const numeral (nat)} $ _)) =>
   6.494 +        Conv.rewr_conv (mk_number_eq ctxt (snd (HOLogic.dest_number n)) ct)
   6.495 +    | @{const of_nat (int)} $ _ =>
   6.496 +        (Conv.rewrs_conv ints then_conv Conv.sub_conv ints_conv ctxt) else_conv
   6.497 +        (Conv.rewr_conv int_if then_conv
   6.498 +          ite_conv (nat_conv ctxt) (int_conv ctxt)) else_conv
   6.499 +        Conv.sub_conv (Conv.top_sweep_conv nat_conv) ctxt
   6.500 +    | _ => Conv.no_conv) ct
   6.501 +
   6.502 +  and ints_conv ctxt = Conv.top_sweep_conv int_conv ctxt
   6.503 +
   6.504 +  and expand_conv ctxt =
   6.505 +    Old_SMT_Utils.if_conv (is_nat_const o Term.head_of)
   6.506 +      (expand_head_conv (Conv.rewrs_conv expands) then_conv ints_conv ctxt)
   6.507 +      (int_conv ctxt)
   6.508 +
   6.509 +  and nat_conv ctxt = Old_SMT_Utils.if_exists_conv is_nat_const'
   6.510 +    (Conv.top_sweep_conv expand_conv ctxt)
   6.511 +
   6.512 +  val uses_nat_int = Term.exists_subterm (member (op aconv) nat_int_coercions)
   6.513 +in
   6.514 +
   6.515 +val nat_as_int_conv = nat_conv
   6.516 +
   6.517 +fun add_nat_embedding thms =
   6.518 +  if exists (uses_nat_int o Thm.prop_of) thms then (thms, nat_embedding)
   6.519 +  else (thms, [])
   6.520 +
   6.521 +val setup_nat_as_int =
   6.522 +  Old_SMT_Builtin.add_builtin_typ_ext (@{typ nat}, K true) #>
   6.523 +  fold (Old_SMT_Builtin.add_builtin_fun_ext' o Term.dest_Const) builtin_nat_ops
   6.524 +
   6.525 +end
   6.526 +
   6.527 +
   6.528 +(** normalize numerals **)
   6.529 +
   6.530 +local
   6.531 +  (*
   6.532 +    rewrite Numeral1 into 1
   6.533 +    rewrite - 0 into 0
   6.534 +  *)
   6.535 +
   6.536 +  fun is_irregular_number (Const (@{const_name numeral}, _) $ Const (@{const_name num.One}, _)) =
   6.537 +        true
   6.538 +    | is_irregular_number (Const (@{const_name uminus}, _) $ Const (@{const_name Groups.zero}, _)) =
   6.539 +        true
   6.540 +    | is_irregular_number _ =
   6.541 +        false;
   6.542 +
   6.543 +  fun is_strange_number ctxt t = is_irregular_number t andalso Old_SMT_Builtin.is_builtin_num ctxt t;
   6.544 +
   6.545 +  val proper_num_ss =
   6.546 +    simpset_of (put_simpset HOL_ss @{context}
   6.547 +      addsimps @{thms Num.numeral_One minus_zero})
   6.548 +
   6.549 +  fun norm_num_conv ctxt =
   6.550 +    Old_SMT_Utils.if_conv (is_strange_number ctxt)
   6.551 +      (Simplifier.rewrite (put_simpset proper_num_ss ctxt)) Conv.no_conv
   6.552 +in
   6.553 +
   6.554 +fun normalize_numerals_conv ctxt =
   6.555 +  Old_SMT_Utils.if_exists_conv (is_strange_number ctxt)
   6.556 +    (Conv.top_sweep_conv norm_num_conv ctxt)
   6.557 +
   6.558 +end
   6.559 +
   6.560 +
   6.561 +(** combined unfoldings and rewritings **)
   6.562 +
   6.563 +fun unfold_conv ctxt =
   6.564 +  rewrite_case_bool_conv ctxt then_conv
   6.565 +  unfold_abs_min_max_conv ctxt then_conv
   6.566 +  nat_as_int_conv ctxt then_conv
   6.567 +  Thm.beta_conversion true
   6.568 +
   6.569 +fun unfold1 ctxt = map (apsnd (Conv.fconv_rule (unfold_conv ctxt)))
   6.570 +
   6.571 +fun burrow_ids f ithms =
   6.572 +  let
   6.573 +    val (is, thms) = split_list ithms
   6.574 +    val (thms', extra_thms) = f thms
   6.575 +  in (is ~~ thms') @ map (pair ~1) extra_thms end
   6.576 +
   6.577 +fun unfold2 ctxt ithms =
   6.578 +  ithms
   6.579 +  |> map (apsnd (Conv.fconv_rule (normalize_numerals_conv ctxt)))
   6.580 +  |> burrow_ids add_nat_embedding
   6.581 +
   6.582 +
   6.583 +
   6.584 +(* overall normalization *)
   6.585 +
   6.586 +type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
   6.587 +
   6.588 +structure Extra_Norms = Generic_Data
   6.589 +(
   6.590 +  type T = extra_norm Old_SMT_Utils.dict
   6.591 +  val empty = []
   6.592 +  val extend = I
   6.593 +  fun merge data = Old_SMT_Utils.dict_merge fst data
   6.594 +)
   6.595 +
   6.596 +fun add_extra_norm (cs, norm) =
   6.597 +  Extra_Norms.map (Old_SMT_Utils.dict_update (cs, norm))
   6.598 +
   6.599 +fun apply_extra_norms ctxt ithms =
   6.600 +  let
   6.601 +    val cs = Old_SMT_Config.solver_class_of ctxt
   6.602 +    val es = Old_SMT_Utils.dict_lookup (Extra_Norms.get (Context.Proof ctxt)) cs
   6.603 +  in burrow_ids (fold (fn e => e ctxt) es o rpair []) ithms end
   6.604 +
   6.605 +local
   6.606 +  val ignored = member (op =) [@{const_name All}, @{const_name Ex},
   6.607 +    @{const_name Let}, @{const_name If}, @{const_name HOL.eq}]
   6.608 +
   6.609 +  val schematic_consts_of =
   6.610 +    let
   6.611 +      fun collect (@{const trigger} $ p $ t) =
   6.612 +            collect_trigger p #> collect t
   6.613 +        | collect (t $ u) = collect t #> collect u
   6.614 +        | collect (Abs (_, _, t)) = collect t
   6.615 +        | collect (t as Const (n, _)) = 
   6.616 +            if not (ignored n) then Monomorph.add_schematic_consts_of t else I
   6.617 +        | collect _ = I
   6.618 +      and collect_trigger t =
   6.619 +        let val dest = these o try HOLogic.dest_list 
   6.620 +        in fold (fold collect_pat o dest) (dest t) end
   6.621 +      and collect_pat (Const (@{const_name pat}, _) $ t) = collect t
   6.622 +        | collect_pat (Const (@{const_name nopat}, _) $ t) = collect t
   6.623 +        | collect_pat _ = I
   6.624 +    in (fn t => collect t Symtab.empty) end
   6.625 +in
   6.626 +
   6.627 +fun monomorph ctxt xthms =
   6.628 +  let val (xs, thms) = split_list xthms
   6.629 +  in
   6.630 +    map (pair 1) thms
   6.631 +    |> Monomorph.monomorph schematic_consts_of ctxt
   6.632 +    |> maps (uncurry (map o pair)) o map2 pair xs o map (map snd)
   6.633 +  end
   6.634 +
   6.635 +end
   6.636 +
   6.637 +fun normalize iwthms ctxt =
   6.638 +  iwthms
   6.639 +  |> gen_normalize ctxt
   6.640 +  |> unfold1 ctxt
   6.641 +  |> monomorph ctxt
   6.642 +  |> unfold2 ctxt
   6.643 +  |> apply_extra_norms ctxt
   6.644 +  |> rpair ctxt
   6.645 +
   6.646 +val setup = Context.theory_map (
   6.647 +  setup_atomize #>
   6.648 +  setup_unfolded_quants #>
   6.649 +  setup_trigger #>
   6.650 +  setup_weight #>
   6.651 +  setup_case_bool #>
   6.652 +  setup_abs_min_max #>
   6.653 +  setup_nat_as_int)
   6.654 +
   6.655 +end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Library/Old_SMT/old_smt_real.ML	Thu Aug 28 00:40:38 2014 +0200
     7.3 @@ -0,0 +1,136 @@
     7.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_real.ML
     7.5 +    Author:     Sascha Boehme, TU Muenchen
     7.6 +
     7.7 +SMT setup for reals.
     7.8 +*)
     7.9 +
    7.10 +signature OLD_SMT_REAL =
    7.11 +sig
    7.12 +  val setup: theory -> theory
    7.13 +end
    7.14 +
    7.15 +structure Old_SMT_Real: OLD_SMT_REAL =
    7.16 +struct
    7.17 +
    7.18 +
    7.19 +(* SMT-LIB logic *)
    7.20 +
    7.21 +fun smtlib_logic ts =
    7.22 +  if exists (Term.exists_type (Term.exists_subtype (equal @{typ real}))) ts
    7.23 +  then SOME "AUFLIRA"
    7.24 +  else NONE
    7.25 +
    7.26 +
    7.27 +(* SMT-LIB and Z3 built-ins *)
    7.28 +
    7.29 +local
    7.30 +  fun real_num _ i = SOME (string_of_int i ^ ".0")
    7.31 +
    7.32 +  fun is_linear [t] = Old_SMT_Utils.is_number t
    7.33 +    | is_linear [t, u] = Old_SMT_Utils.is_number t orelse Old_SMT_Utils.is_number u
    7.34 +    | is_linear _ = false
    7.35 +
    7.36 +  fun mk_times ts = Term.list_comb (@{const times (real)}, ts)
    7.37 +
    7.38 +  fun times _ _ ts = if is_linear ts then SOME ("*", 2, ts, mk_times) else NONE
    7.39 +in
    7.40 +
    7.41 +val setup_builtins =
    7.42 +  Old_SMT_Builtin.add_builtin_typ Old_SMTLIB_Interface.smtlibC
    7.43 +    (@{typ real}, K (SOME "Real"), real_num) #>
    7.44 +  fold (Old_SMT_Builtin.add_builtin_fun' Old_SMTLIB_Interface.smtlibC) [
    7.45 +    (@{const less (real)}, "<"),
    7.46 +    (@{const less_eq (real)}, "<="),
    7.47 +    (@{const uminus (real)}, "~"),
    7.48 +    (@{const plus (real)}, "+"),
    7.49 +    (@{const minus (real)}, "-") ] #>
    7.50 +  Old_SMT_Builtin.add_builtin_fun Old_SMTLIB_Interface.smtlibC
    7.51 +    (Term.dest_Const @{const times (real)}, times) #>
    7.52 +  Old_SMT_Builtin.add_builtin_fun' Old_Z3_Interface.smtlib_z3C
    7.53 +    (@{const times (real)}, "*") #>
    7.54 +  Old_SMT_Builtin.add_builtin_fun' Old_Z3_Interface.smtlib_z3C
    7.55 +    (@{const divide (real)}, "/")
    7.56 +
    7.57 +end
    7.58 +
    7.59 +
    7.60 +(* Z3 constructors *)
    7.61 +
    7.62 +local
    7.63 +  fun z3_mk_builtin_typ (Old_Z3_Interface.Sym ("Real", _)) = SOME @{typ real}
    7.64 +    | z3_mk_builtin_typ (Old_Z3_Interface.Sym ("real", _)) = SOME @{typ real}
    7.65 +        (*FIXME: delete*)
    7.66 +    | z3_mk_builtin_typ _ = NONE
    7.67 +
    7.68 +  fun z3_mk_builtin_num _ i T =
    7.69 +    if T = @{typ real} then SOME (Numeral.mk_cnumber @{ctyp real} i)
    7.70 +    else NONE
    7.71 +
    7.72 +  fun mk_nary _ cu [] = cu
    7.73 +    | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
    7.74 +
    7.75 +  val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (real)})
    7.76 +  val add = Thm.cterm_of @{theory} @{const plus (real)}
    7.77 +  val real0 = Numeral.mk_cnumber @{ctyp real} 0
    7.78 +  val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (real)})
    7.79 +  val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (real)})
    7.80 +  val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const divide (real)})
    7.81 +  val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (real)})
    7.82 +  val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (real)})
    7.83 +
    7.84 +  fun z3_mk_builtin_fun (Old_Z3_Interface.Sym ("-", _)) [ct] = SOME (mk_uminus ct)
    7.85 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("+", _)) cts =
    7.86 +        SOME (mk_nary add real0 cts)
    7.87 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("-", _)) [ct, cu] =
    7.88 +        SOME (mk_sub ct cu)
    7.89 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("*", _)) [ct, cu] =
    7.90 +        SOME (mk_mul ct cu)
    7.91 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("/", _)) [ct, cu] =
    7.92 +        SOME (mk_div ct cu)
    7.93 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("<", _)) [ct, cu] =
    7.94 +        SOME (mk_lt ct cu)
    7.95 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym ("<=", _)) [ct, cu] =
    7.96 +        SOME (mk_le ct cu)
    7.97 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym (">", _)) [ct, cu] =
    7.98 +        SOME (mk_lt cu ct)
    7.99 +    | z3_mk_builtin_fun (Old_Z3_Interface.Sym (">=", _)) [ct, cu] =
   7.100 +        SOME (mk_le cu ct)
   7.101 +    | z3_mk_builtin_fun _ _ = NONE
   7.102 +in
   7.103 +
   7.104 +val z3_mk_builtins = {
   7.105 +  mk_builtin_typ = z3_mk_builtin_typ,
   7.106 +  mk_builtin_num = z3_mk_builtin_num,
   7.107 +  mk_builtin_fun = (fn _ => fn sym => fn cts =>
   7.108 +    (case try (#T o Thm.rep_cterm o hd) cts of
   7.109 +      SOME @{typ real} => z3_mk_builtin_fun sym cts
   7.110 +    | _ => NONE)) }
   7.111 +
   7.112 +end
   7.113 +
   7.114 +
   7.115 +(* Z3 proof reconstruction *)
   7.116 +
   7.117 +val real_rules = @{lemma
   7.118 +  "0 + (x::real) = x"
   7.119 +  "x + 0 = x"
   7.120 +  "0 * x = 0"
   7.121 +  "1 * x = x"
   7.122 +  "x + y = y + x"
   7.123 +  by auto}
   7.124 +
   7.125 +val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [
   7.126 +  "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc
   7.127 +
   7.128 +
   7.129 +(* setup *)
   7.130 +
   7.131 +val setup =
   7.132 +  Context.theory_map (
   7.133 +    Old_SMTLIB_Interface.add_logic (10, smtlib_logic) #>
   7.134 +    setup_builtins #>
   7.135 +    Old_Z3_Interface.add_mk_builtins z3_mk_builtins #>
   7.136 +    fold Old_Z3_Proof_Reconstruction.add_z3_rule real_rules #>
   7.137 +    Old_Z3_Proof_Tools.add_simproc real_linarith_proc)
   7.138 +
   7.139 +end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Library/Old_SMT/old_smt_setup_solvers.ML	Thu Aug 28 00:40:38 2014 +0200
     8.3 @@ -0,0 +1,193 @@
     8.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_setup_solvers.ML
     8.5 +    Author:     Sascha Boehme, TU Muenchen
     8.6 +
     8.7 +Setup SMT solvers.
     8.8 +*)
     8.9 +
    8.10 +signature OLD_SMT_SETUP_SOLVERS =
    8.11 +sig
    8.12 +  datatype z3_non_commercial =
    8.13 +    Z3_Non_Commercial_Unknown |
    8.14 +    Z3_Non_Commercial_Accepted |
    8.15 +    Z3_Non_Commercial_Declined
    8.16 +  val z3_non_commercial: unit -> z3_non_commercial
    8.17 +  val z3_with_extensions: bool Config.T
    8.18 +  val setup: theory -> theory
    8.19 +end
    8.20 +
    8.21 +structure Old_SMT_Setup_Solvers: OLD_SMT_SETUP_SOLVERS =
    8.22 +struct
    8.23 +
    8.24 +(* helper functions *)
    8.25 +
    8.26 +fun make_avail name () = getenv (name ^ "_SOLVER") <> ""
    8.27 +
    8.28 +fun make_command name () = [getenv (name ^ "_SOLVER")]
    8.29 +
    8.30 +fun outcome_of unsat sat unknown solver_name line =
    8.31 +  if String.isPrefix unsat line then Old_SMT_Solver.Unsat
    8.32 +  else if String.isPrefix sat line then Old_SMT_Solver.Sat
    8.33 +  else if String.isPrefix unknown line then Old_SMT_Solver.Unknown
    8.34 +  else raise Old_SMT_Failure.SMT (Old_SMT_Failure.Other_Failure ("Solver " ^
    8.35 +    quote solver_name ^ " failed. Enable SMT tracing by setting the " ^
    8.36 +    "configuration option " ^ quote (Config.name_of Old_SMT_Config.trace) ^ " and " ^
    8.37 +    "see the trace for details."))
    8.38 +
    8.39 +fun on_first_line test_outcome solver_name lines =
    8.40 +  let
    8.41 +    val empty_line = (fn "" => true | _ => false)
    8.42 +    val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
    8.43 +    val (l, ls) = split_first (snd (take_prefix empty_line lines))
    8.44 +  in (test_outcome solver_name l, ls) end
    8.45 +
    8.46 +
    8.47 +(* CVC3 *)
    8.48 +
    8.49 +local
    8.50 +  fun cvc3_options ctxt = [
    8.51 +    "-seed", string_of_int (Config.get ctxt Old_SMT_Config.random_seed),
    8.52 +    "-lang", "smtlib", "-output-lang", "presentation",
    8.53 +    "-timeout", string_of_int (Real.ceil (Config.get ctxt Old_SMT_Config.timeout))]
    8.54 +in
    8.55 +
    8.56 +val cvc3: Old_SMT_Solver.solver_config = {
    8.57 +  name = "cvc3",
    8.58 +  class = K Old_SMTLIB_Interface.smtlibC,
    8.59 +  avail = make_avail "CVC3",
    8.60 +  command = make_command "CVC3",
    8.61 +  options = cvc3_options,
    8.62 +  default_max_relevant = 400 (* FUDGE *),
    8.63 +  supports_filter = false,
    8.64 +  outcome =
    8.65 +    on_first_line (outcome_of "Unsatisfiable." "Satisfiable." "Unknown."),
    8.66 +  cex_parser = NONE,
    8.67 +  reconstruct = NONE }
    8.68 +
    8.69 +end
    8.70 +
    8.71 +
    8.72 +(* Yices *)
    8.73 +
    8.74 +val yices: Old_SMT_Solver.solver_config = {
    8.75 +  name = "yices",
    8.76 +  class = K Old_SMTLIB_Interface.smtlibC,
    8.77 +  avail = make_avail "YICES",
    8.78 +  command = make_command "YICES",
    8.79 +  options = (fn ctxt => [
    8.80 +    "--rand-seed=" ^ string_of_int (Config.get ctxt Old_SMT_Config.random_seed),
    8.81 +    "--timeout=" ^
    8.82 +      string_of_int (Real.ceil (Config.get ctxt Old_SMT_Config.timeout)),
    8.83 +    "--smtlib"]),
    8.84 +  default_max_relevant = 350 (* FUDGE *),
    8.85 +  supports_filter = false,
    8.86 +  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
    8.87 +  cex_parser = NONE,
    8.88 +  reconstruct = NONE }
    8.89 +
    8.90 +
    8.91 +(* Z3 *)
    8.92 +
    8.93 +datatype z3_non_commercial =
    8.94 +  Z3_Non_Commercial_Unknown |
    8.95 +  Z3_Non_Commercial_Accepted |
    8.96 +  Z3_Non_Commercial_Declined
    8.97 +
    8.98 +
    8.99 +local
   8.100 +  val accepted = member (op =) ["yes", "Yes", "YES"]
   8.101 +  val declined = member (op =) ["no", "No", "NO"]
   8.102 +in
   8.103 +
   8.104 +fun z3_non_commercial () =
   8.105 +  let
   8.106 +    val flag1 = Options.default_string @{system_option z3_non_commercial}
   8.107 +    val flag2 = getenv "Z3_NON_COMMERCIAL"
   8.108 +  in
   8.109 +    if accepted flag1 then Z3_Non_Commercial_Accepted
   8.110 +    else if declined flag1 then Z3_Non_Commercial_Declined
   8.111 +    else if accepted flag2 then Z3_Non_Commercial_Accepted
   8.112 +    else if declined flag2 then Z3_Non_Commercial_Declined
   8.113 +    else Z3_Non_Commercial_Unknown
   8.114 +  end
   8.115 +
   8.116 +fun if_z3_non_commercial f =
   8.117 +  (case z3_non_commercial () of
   8.118 +    Z3_Non_Commercial_Accepted => f ()
   8.119 +  | Z3_Non_Commercial_Declined =>
   8.120 +      error (Pretty.string_of (Pretty.para
   8.121 +        "The SMT solver Z3 may only be used for non-commercial applications."))
   8.122 +  | Z3_Non_Commercial_Unknown =>
   8.123 +      error
   8.124 +        (Pretty.string_of
   8.125 +          (Pretty.para
   8.126 +            ("The SMT solver Z3 is not activated. To activate it, set the Isabelle \
   8.127 +             \system option \"z3_non_commercial\" to \"yes\" (e.g. via \
   8.128 +             \the Isabelle/jEdit menu Plugin Options / Isabelle / General).")) ^
   8.129 +        "\n\nSee also " ^ Url.print (Url.explode "http://z3.codeplex.com/license")))
   8.130 +
   8.131 +end
   8.132 +
   8.133 +
   8.134 +val z3_with_extensions =
   8.135 +  Attrib.setup_config_bool @{binding z3_with_extensions} (K false)
   8.136 +
   8.137 +local
   8.138 +  fun z3_make_command name () = if_z3_non_commercial (make_command name)
   8.139 +
   8.140 +  fun z3_options ctxt =
   8.141 +    ["-rs:" ^ string_of_int (Config.get ctxt Old_SMT_Config.random_seed),
   8.142 +      "MODEL=true",
   8.143 +      "SOFT_TIMEOUT=" ^
   8.144 +        string_of_int (Real.ceil (1000.0 * Config.get ctxt Old_SMT_Config.timeout)),
   8.145 +      "-smt"]
   8.146 +    |> not (Config.get ctxt Old_SMT_Config.oracle) ?
   8.147 +         append ["DISPLAY_PROOF=true", "PROOF_MODE=2"]
   8.148 +
   8.149 +  fun z3_on_first_or_last_line solver_name lines =
   8.150 +    let
   8.151 +      fun junk l =
   8.152 +        if String.isPrefix "WARNING: Out of allocated virtual memory" l
   8.153 +        then raise Old_SMT_Failure.SMT Old_SMT_Failure.Out_Of_Memory
   8.154 +        else
   8.155 +          String.isPrefix "WARNING" l orelse
   8.156 +          String.isPrefix "ERROR" l orelse
   8.157 +          forall Symbol.is_ascii_blank (Symbol.explode l)
   8.158 +      val lines = filter_out junk lines
   8.159 +      fun outcome split =
   8.160 +        the_default ("", []) (try split lines)
   8.161 +        |>> outcome_of "unsat" "sat" "unknown" solver_name
   8.162 +    in
   8.163 +      (* Starting with version 4.0, Z3 puts the outcome on the first line of the
   8.164 +         output rather than on the last line. *)
   8.165 +      outcome (fn lines => (hd lines, tl lines))
   8.166 +      handle Old_SMT_Failure.SMT _ => outcome (swap o split_last)
   8.167 +    end
   8.168 +
   8.169 +  fun select_class ctxt =
   8.170 +    if Config.get ctxt z3_with_extensions then Old_Z3_Interface.smtlib_z3C
   8.171 +    else Old_SMTLIB_Interface.smtlibC
   8.172 +in
   8.173 +
   8.174 +val z3: Old_SMT_Solver.solver_config = {
   8.175 +  name = "z3",
   8.176 +  class = select_class,
   8.177 +  avail = make_avail "Z3",
   8.178 +  command = z3_make_command "Z3",
   8.179 +  options = z3_options,
   8.180 +  default_max_relevant = 350 (* FUDGE *),
   8.181 +  supports_filter = true,
   8.182 +  outcome = z3_on_first_or_last_line,
   8.183 +  cex_parser = SOME Old_Z3_Model.parse_counterex,
   8.184 +  reconstruct = SOME Old_Z3_Proof_Reconstruction.reconstruct }
   8.185 +
   8.186 +end
   8.187 +
   8.188 +
   8.189 +(* overall setup *)
   8.190 +
   8.191 +val setup =
   8.192 +  Old_SMT_Solver.add_solver cvc3 #>
   8.193 +  Old_SMT_Solver.add_solver yices #>
   8.194 +  Old_SMT_Solver.add_solver z3
   8.195 +
   8.196 +end
     9.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.2 +++ b/src/HOL/Library/Old_SMT/old_smt_solver.ML	Thu Aug 28 00:40:38 2014 +0200
     9.3 @@ -0,0 +1,373 @@
     9.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_solver.ML
     9.5 +    Author:     Sascha Boehme, TU Muenchen
     9.6 +
     9.7 +SMT solvers registry and SMT tactic.
     9.8 +*)
     9.9 +
    9.10 +signature OLD_SMT_SOLVER =
    9.11 +sig
    9.12 +  (*configuration*)
    9.13 +  datatype outcome = Unsat | Sat | Unknown
    9.14 +  type solver_config = {
    9.15 +    name: string,
    9.16 +    class: Proof.context -> Old_SMT_Utils.class,
    9.17 +    avail: unit -> bool,
    9.18 +    command: unit -> string list,
    9.19 +    options: Proof.context -> string list,
    9.20 +    default_max_relevant: int,
    9.21 +    supports_filter: bool,
    9.22 +    outcome: string -> string list -> outcome * string list,
    9.23 +    cex_parser: (Proof.context -> Old_SMT_Translate.recon -> string list ->
    9.24 +      term list * term list) option,
    9.25 +    reconstruct: (Proof.context -> Old_SMT_Translate.recon -> string list ->
    9.26 +      int list * thm) option }
    9.27 +
    9.28 +  (*registry*)
    9.29 +  val add_solver: solver_config -> theory -> theory
    9.30 +  val solver_name_of: Proof.context -> string
    9.31 +  val available_solvers_of: Proof.context -> string list
    9.32 +  val apply_solver: Proof.context -> (int * (int option * thm)) list ->
    9.33 +    int list * thm
    9.34 +  val default_max_relevant: Proof.context -> string -> int
    9.35 +
    9.36 +  (*filter*)
    9.37 +  type 'a smt_filter_data =
    9.38 +    ('a * thm) list * ((int * thm) list * Proof.context)
    9.39 +  val smt_filter_preprocess: Proof.context -> thm list -> thm ->
    9.40 +    ('a * (int option * thm)) list -> int -> 'a smt_filter_data
    9.41 +  val smt_filter_apply: Time.time -> 'a smt_filter_data ->
    9.42 +    {outcome: Old_SMT_Failure.failure option, used_facts: ('a * thm) list}
    9.43 +
    9.44 +  (*tactic*)
    9.45 +  val smt_tac: Proof.context -> thm list -> int -> tactic
    9.46 +  val smt_tac': Proof.context -> thm list -> int -> tactic
    9.47 +end
    9.48 +
    9.49 +structure Old_SMT_Solver: OLD_SMT_SOLVER =
    9.50 +struct
    9.51 +
    9.52 +
    9.53 +(* interface to external solvers *)
    9.54 +
    9.55 +local
    9.56 +
    9.57 +fun make_cmd command options problem_path proof_path = space_implode " " (
    9.58 +  "(exec 2>&1;" :: map File.shell_quote (command () @ options) @
    9.59 +  [File.shell_path problem_path, ")", ">", File.shell_path proof_path])
    9.60 +
    9.61 +fun trace_and ctxt msg f x =
    9.62 +  let val _ = Old_SMT_Config.trace_msg ctxt (fn () => msg) ()
    9.63 +  in f x end
    9.64 +
    9.65 +fun run ctxt name mk_cmd input =
    9.66 +  (case Old_SMT_Config.certificates_of ctxt of
    9.67 +    NONE =>
    9.68 +      if not (Old_SMT_Config.is_available ctxt name) then
    9.69 +        error ("The SMT solver " ^ quote name ^ " is not installed.")
    9.70 +      else if Config.get ctxt Old_SMT_Config.debug_files = "" then
    9.71 +        trace_and ctxt ("Invoking SMT solver " ^ quote name ^ " ...")
    9.72 +          (Cache_IO.run mk_cmd) input
    9.73 +      else
    9.74 +        let
    9.75 +          val base_path = Path.explode (Config.get ctxt Old_SMT_Config.debug_files)
    9.76 +          val in_path = Path.ext "smt_in" base_path
    9.77 +          val out_path = Path.ext "smt_out" base_path
    9.78 +        in Cache_IO.raw_run mk_cmd input in_path out_path end
    9.79 +  | SOME certs =>
    9.80 +      (case Cache_IO.lookup certs input of
    9.81 +        (NONE, key) =>
    9.82 +          if Config.get ctxt Old_SMT_Config.read_only_certificates then
    9.83 +            error ("Bad certificate cache: missing certificate")
    9.84 +          else
    9.85 +            Cache_IO.run_and_cache certs key mk_cmd input
    9.86 +      | (SOME output, _) =>
    9.87 +          trace_and ctxt ("Using cached certificate from " ^
    9.88 +            File.shell_path (Cache_IO.cache_path_of certs) ^ " ...")
    9.89 +            I output))
    9.90 +
    9.91 +fun run_solver ctxt name mk_cmd input =
    9.92 +  let
    9.93 +    fun pretty tag ls = Pretty.string_of (Pretty.big_list tag
    9.94 +      (map Pretty.str ls))
    9.95 +
    9.96 +    val _ = Old_SMT_Config.trace_msg ctxt (pretty "Problem:" o split_lines) input
    9.97 +
    9.98 +    val {redirected_output=res, output=err, return_code} =
    9.99 +      Old_SMT_Config.with_timeout ctxt (run ctxt name mk_cmd) input
   9.100 +    val _ = Old_SMT_Config.trace_msg ctxt (pretty "Solver:") err
   9.101 +
   9.102 +    val ls = fst (take_suffix (equal "") res)
   9.103 +    val _ = Old_SMT_Config.trace_msg ctxt (pretty "Result:") ls
   9.104 +
   9.105 +    val _ = return_code <> 0 andalso
   9.106 +      raise Old_SMT_Failure.SMT (Old_SMT_Failure.Abnormal_Termination return_code)
   9.107 +  in ls end
   9.108 +
   9.109 +fun trace_assms ctxt =
   9.110 +  Old_SMT_Config.trace_msg ctxt (Pretty.string_of o
   9.111 +    Pretty.big_list "Assertions:" o map (Display.pretty_thm ctxt o snd))
   9.112 +
   9.113 +fun trace_recon_data ({context=ctxt, typs, terms, ...} : Old_SMT_Translate.recon) =
   9.114 +  let
   9.115 +    fun pretty_eq n p = Pretty.block [Pretty.str n, Pretty.str " = ", p]
   9.116 +    fun p_typ (n, T) = pretty_eq n (Syntax.pretty_typ ctxt T)
   9.117 +    fun p_term (n, t) = pretty_eq n (Syntax.pretty_term ctxt t)
   9.118 +  in
   9.119 +    Old_SMT_Config.trace_msg ctxt (fn () =>
   9.120 +      Pretty.string_of (Pretty.big_list "Names:" [
   9.121 +        Pretty.big_list "sorts:" (map p_typ (Symtab.dest typs)),
   9.122 +        Pretty.big_list "functions:" (map p_term (Symtab.dest terms))])) ()
   9.123 +  end
   9.124 +
   9.125 +in
   9.126 +
   9.127 +fun invoke name command ithms ctxt =
   9.128 +  let
   9.129 +    val options = Old_SMT_Config.solver_options_of ctxt
   9.130 +    val comments = ("solver: " ^ name) ::
   9.131 +      ("timeout: " ^ string_of_real (Config.get ctxt Old_SMT_Config.timeout)) ::
   9.132 +      ("random seed: " ^
   9.133 +        string_of_int (Config.get ctxt Old_SMT_Config.random_seed)) ::
   9.134 +      "arguments:" :: options
   9.135 +
   9.136 +    val (str, recon as {context=ctxt', ...}) =
   9.137 +      ithms
   9.138 +      |> tap (trace_assms ctxt)
   9.139 +      |> Old_SMT_Translate.translate ctxt comments
   9.140 +      ||> tap trace_recon_data
   9.141 +  in (run_solver ctxt' name (make_cmd command options) str, recon) end
   9.142 +
   9.143 +end
   9.144 +
   9.145 +
   9.146 +(* configuration *)
   9.147 +
   9.148 +datatype outcome = Unsat | Sat | Unknown
   9.149 +
   9.150 +type solver_config = {
   9.151 +  name: string,
   9.152 +  class: Proof.context -> Old_SMT_Utils.class,
   9.153 +  avail: unit -> bool,
   9.154 +  command: unit -> string list,
   9.155 +  options: Proof.context -> string list,
   9.156 +  default_max_relevant: int,
   9.157 +  supports_filter: bool,
   9.158 +  outcome: string -> string list -> outcome * string list,
   9.159 +  cex_parser: (Proof.context -> Old_SMT_Translate.recon -> string list ->
   9.160 +    term list * term list) option,
   9.161 +  reconstruct: (Proof.context -> Old_SMT_Translate.recon -> string list ->
   9.162 +    int list * thm) option }
   9.163 +
   9.164 +
   9.165 +(* registry *)
   9.166 +
   9.167 +type solver_info = {
   9.168 +  command: unit -> string list,
   9.169 +  default_max_relevant: int,
   9.170 +  supports_filter: bool,
   9.171 +  reconstruct: Proof.context -> string list * Old_SMT_Translate.recon ->
   9.172 +    int list * thm }
   9.173 +
   9.174 +structure Solvers = Generic_Data
   9.175 +(
   9.176 +  type T = solver_info Symtab.table
   9.177 +  val empty = Symtab.empty
   9.178 +  val extend = I
   9.179 +  fun merge data = Symtab.merge (K true) data
   9.180 +)
   9.181 +
   9.182 +local
   9.183 +  fun finish outcome cex_parser reconstruct ocl outer_ctxt
   9.184 +      (output, (recon as {context=ctxt, ...} : Old_SMT_Translate.recon)) =
   9.185 +    (case outcome output of
   9.186 +      (Unsat, ls) =>
   9.187 +        if not (Config.get ctxt Old_SMT_Config.oracle) andalso is_some reconstruct
   9.188 +        then the reconstruct outer_ctxt recon ls
   9.189 +        else ([], ocl ())
   9.190 +    | (result, ls) =>
   9.191 +        let
   9.192 +          val (ts, us) =
   9.193 +            (case cex_parser of SOME f => f ctxt recon ls | _ => ([], []))
   9.194 +         in
   9.195 +          raise Old_SMT_Failure.SMT (Old_SMT_Failure.Counterexample {
   9.196 +            is_real_cex = (result = Sat),
   9.197 +            free_constraints = ts,
   9.198 +            const_defs = us})
   9.199 +        end)
   9.200 +
   9.201 +  val cfalse = Thm.cterm_of @{theory} (@{const Trueprop} $ @{const False})
   9.202 +in
   9.203 +
   9.204 +fun add_solver cfg =
   9.205 +  let
   9.206 +    val {name, class, avail, command, options, default_max_relevant,
   9.207 +      supports_filter, outcome, cex_parser, reconstruct} = cfg
   9.208 +
   9.209 +    fun core_oracle () = cfalse
   9.210 +
   9.211 +    fun solver ocl = {
   9.212 +      command = command,
   9.213 +      default_max_relevant = default_max_relevant,
   9.214 +      supports_filter = supports_filter,
   9.215 +      reconstruct = finish (outcome name) cex_parser reconstruct ocl }
   9.216 +
   9.217 +    val info = {name=name, class=class, avail=avail, options=options}
   9.218 +  in
   9.219 +    Thm.add_oracle (Binding.name name, core_oracle) #-> (fn (_, ocl) =>
   9.220 +    Context.theory_map (Solvers.map (Symtab.update_new (name, solver ocl)))) #>
   9.221 +    Context.theory_map (Old_SMT_Config.add_solver info)
   9.222 +  end
   9.223 +
   9.224 +end
   9.225 +
   9.226 +fun get_info ctxt name =
   9.227 +  the (Symtab.lookup (Solvers.get (Context.Proof ctxt)) name)
   9.228 +
   9.229 +val solver_name_of = Old_SMT_Config.solver_of
   9.230 +
   9.231 +val available_solvers_of = Old_SMT_Config.available_solvers_of
   9.232 +
   9.233 +fun name_and_info_of ctxt =
   9.234 +  let val name = solver_name_of ctxt
   9.235 +  in (name, get_info ctxt name) end
   9.236 +
   9.237 +fun gen_preprocess ctxt iwthms = Old_SMT_Normalize.normalize iwthms ctxt
   9.238 +
   9.239 +fun gen_apply (ithms, ctxt) =
   9.240 +  let val (name, {command, reconstruct, ...}) = name_and_info_of ctxt
   9.241 +  in
   9.242 +    (ithms, ctxt)
   9.243 +    |-> invoke name command
   9.244 +    |> reconstruct ctxt
   9.245 +    |>> distinct (op =)
   9.246 +  end
   9.247 +
   9.248 +fun apply_solver ctxt = gen_apply o gen_preprocess ctxt
   9.249 +
   9.250 +val default_max_relevant = #default_max_relevant oo get_info
   9.251 +
   9.252 +val supports_filter = #supports_filter o snd o name_and_info_of 
   9.253 +
   9.254 +
   9.255 +(* check well-sortedness *)
   9.256 +
   9.257 +val has_topsort = Term.exists_type (Term.exists_subtype (fn
   9.258 +    TFree (_, []) => true
   9.259 +  | TVar (_, []) => true
   9.260 +  | _ => false))
   9.261 +
   9.262 +(* without this test, we would run into problems when atomizing the rules: *)
   9.263 +fun check_topsort ctxt thm =
   9.264 +  if has_topsort (Thm.prop_of thm) then
   9.265 +    (Old_SMT_Normalize.drop_fact_warning ctxt thm; TrueI)
   9.266 +  else
   9.267 +    thm
   9.268 +
   9.269 +fun check_topsorts ctxt iwthms = map (apsnd (apsnd (check_topsort ctxt))) iwthms
   9.270 +
   9.271 +
   9.272 +(* filter *)
   9.273 +
   9.274 +val cnot = Thm.cterm_of @{theory} @{const Not}
   9.275 +
   9.276 +fun mk_result outcome xrules = { outcome = outcome, used_facts = xrules }
   9.277 +
   9.278 +type 'a smt_filter_data = ('a * thm) list * ((int * thm) list * Proof.context)
   9.279 +
   9.280 +fun smt_filter_preprocess ctxt facts goal xwthms i =
   9.281 +  let
   9.282 +    val ctxt =
   9.283 +      ctxt
   9.284 +      |> Config.put Old_SMT_Config.oracle false
   9.285 +      |> Config.put Old_SMT_Config.filter_only_facts true
   9.286 +
   9.287 +    val ({context=ctxt', prems, concl, ...}, _) = Subgoal.focus ctxt i goal
   9.288 +    fun negate ct = Thm.dest_comb ct ||> Thm.apply cnot |-> Thm.apply
   9.289 +    val cprop =
   9.290 +      (case try negate (Thm.rhs_of (Old_SMT_Normalize.atomize_conv ctxt' concl)) of
   9.291 +        SOME ct => ct
   9.292 +      | NONE => raise Old_SMT_Failure.SMT (Old_SMT_Failure.Other_Failure (
   9.293 +          "goal is not a HOL term")))
   9.294 +  in
   9.295 +    map snd xwthms
   9.296 +    |> map_index I
   9.297 +    |> append (map (pair ~1 o pair NONE) (Thm.assume cprop :: prems @ facts))
   9.298 +    |> check_topsorts ctxt'
   9.299 +    |> gen_preprocess ctxt'
   9.300 +    |> pair (map (apsnd snd) xwthms)
   9.301 +  end
   9.302 +
   9.303 +fun smt_filter_apply time_limit (xthms, (ithms, ctxt)) =
   9.304 +  let
   9.305 +    val ctxt' =
   9.306 +      ctxt
   9.307 +      |> Config.put Old_SMT_Config.timeout (Time.toReal time_limit)
   9.308 +
   9.309 +    fun filter_thms false = K xthms
   9.310 +      | filter_thms true = map_filter (try (nth xthms)) o fst
   9.311 +  in
   9.312 +    (ithms, ctxt')
   9.313 +    |> gen_apply
   9.314 +    |> filter_thms (supports_filter ctxt')
   9.315 +    |> mk_result NONE
   9.316 +  end
   9.317 +  handle Old_SMT_Failure.SMT fail => mk_result (SOME fail) []
   9.318 +
   9.319 +
   9.320 +(* SMT tactic *)
   9.321 +
   9.322 +local
   9.323 +  fun trace_assumptions ctxt iwthms idxs =
   9.324 +    let
   9.325 +      val wthms =
   9.326 +        idxs
   9.327 +        |> filter (fn i => i >= 0)
   9.328 +        |> map_filter (AList.lookup (op =) iwthms)
   9.329 +    in
   9.330 +      if Config.get ctxt Old_SMT_Config.trace_used_facts andalso length wthms > 0
   9.331 +      then
   9.332 +        tracing (Pretty.string_of (Pretty.big_list "SMT used facts:"
   9.333 +          (map (Display.pretty_thm ctxt o snd) wthms)))
   9.334 +      else ()
   9.335 +    end
   9.336 +
   9.337 +  fun solve ctxt iwthms =
   9.338 +    iwthms
   9.339 +    |> check_topsorts ctxt
   9.340 +    |> apply_solver ctxt
   9.341 +    |>> trace_assumptions ctxt iwthms
   9.342 +    |> snd
   9.343 +
   9.344 +  fun str_of ctxt fail =
   9.345 +    Old_SMT_Failure.string_of_failure ctxt fail
   9.346 +    |> prefix ("Solver " ^ Old_SMT_Config.solver_of ctxt ^ ": ")
   9.347 +
   9.348 +  fun safe_solve ctxt iwthms = SOME (solve ctxt iwthms)
   9.349 +    handle
   9.350 +      Old_SMT_Failure.SMT (fail as Old_SMT_Failure.Counterexample _) =>
   9.351 +        (Old_SMT_Config.verbose_msg ctxt (str_of ctxt) fail; NONE)
   9.352 +    | Old_SMT_Failure.SMT (fail as Old_SMT_Failure.Time_Out) =>
   9.353 +        error ("SMT: Solver " ^ quote (Old_SMT_Config.solver_of ctxt) ^ ": " ^
   9.354 +          Old_SMT_Failure.string_of_failure ctxt fail ^ " (setting the " ^
   9.355 +          "configuration option " ^ quote (Config.name_of Old_SMT_Config.timeout) ^ " might help)")
   9.356 +    | Old_SMT_Failure.SMT fail => error (str_of ctxt fail)
   9.357 +
   9.358 +  fun tag_rules thms = map_index (apsnd (pair NONE)) thms
   9.359 +  fun tag_prems thms = map (pair ~1 o pair NONE) thms
   9.360 +
   9.361 +  fun resolve (SOME thm) = rtac thm 1
   9.362 +    | resolve NONE = no_tac
   9.363 +
   9.364 +  fun tac prove ctxt rules =
   9.365 +    CONVERSION (Old_SMT_Normalize.atomize_conv ctxt)
   9.366 +    THEN' rtac @{thm ccontr}
   9.367 +    THEN' SUBPROOF (fn {context, prems, ...} =>
   9.368 +      resolve (prove context (tag_rules rules @ tag_prems prems))) ctxt
   9.369 +in
   9.370 +
   9.371 +val smt_tac = tac safe_solve
   9.372 +val smt_tac' = tac (SOME oo solve)
   9.373 +
   9.374 +end
   9.375 +
   9.376 +end
    10.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.2 +++ b/src/HOL/Library/Old_SMT/old_smt_translate.ML	Thu Aug 28 00:40:38 2014 +0200
    10.3 @@ -0,0 +1,589 @@
    10.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_translate.ML
    10.5 +    Author:     Sascha Boehme, TU Muenchen
    10.6 +
    10.7 +Translate theorems into an SMT intermediate format and serialize them.
    10.8 +*)
    10.9 +
   10.10 +signature OLD_SMT_TRANSLATE =
   10.11 +sig
   10.12 +  (*intermediate term structure*)
   10.13 +  datatype squant = SForall | SExists
   10.14 +  datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   10.15 +  datatype sterm =
   10.16 +    SVar of int |
   10.17 +    SApp of string * sterm list |
   10.18 +    SLet of string * sterm * sterm |
   10.19 +    SQua of squant * string list * sterm spattern list * int option * sterm
   10.20 +
   10.21 +  (*translation configuration*)
   10.22 +  type prefixes = {sort_prefix: string, func_prefix: string}
   10.23 +  type sign = {
   10.24 +    header: string list,
   10.25 +    sorts: string list,
   10.26 +    dtyps: (string * (string * (string * string) list) list) list list,
   10.27 +    funcs: (string * (string list * string)) list }
   10.28 +  type config = {
   10.29 +    prefixes: prefixes,
   10.30 +    header: term list -> string list,
   10.31 +    is_fol: bool,
   10.32 +    has_datatypes: bool,
   10.33 +    serialize: string list -> sign -> sterm list -> string }
   10.34 +  type recon = {
   10.35 +    context: Proof.context,
   10.36 +    typs: typ Symtab.table,
   10.37 +    terms: term Symtab.table,
   10.38 +    rewrite_rules: thm list,
   10.39 +    assms: (int * thm) list }
   10.40 +
   10.41 +  (*translation*)
   10.42 +  val add_config: Old_SMT_Utils.class * (Proof.context -> config) ->
   10.43 +    Context.generic -> Context.generic 
   10.44 +  val translate: Proof.context -> string list -> (int * thm) list ->
   10.45 +    string * recon
   10.46 +end
   10.47 +
   10.48 +structure Old_SMT_Translate: OLD_SMT_TRANSLATE =
   10.49 +struct
   10.50 +
   10.51 +
   10.52 +(* intermediate term structure *)
   10.53 +
   10.54 +datatype squant = SForall | SExists
   10.55 +
   10.56 +datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
   10.57 +
   10.58 +datatype sterm =
   10.59 +  SVar of int |
   10.60 +  SApp of string * sterm list |
   10.61 +  SLet of string * sterm * sterm |
   10.62 +  SQua of squant * string list * sterm spattern list * int option * sterm
   10.63 +
   10.64 +
   10.65 +
   10.66 +(* translation configuration *)
   10.67 +
   10.68 +type prefixes = {sort_prefix: string, func_prefix: string}
   10.69 +
   10.70 +type sign = {
   10.71 +  header: string list,
   10.72 +  sorts: string list,
   10.73 +  dtyps: (string * (string * (string * string) list) list) list list,
   10.74 +  funcs: (string * (string list * string)) list }
   10.75 +
   10.76 +type config = {
   10.77 +  prefixes: prefixes,
   10.78 +  header: term list -> string list,
   10.79 +  is_fol: bool,
   10.80 +  has_datatypes: bool,
   10.81 +  serialize: string list -> sign -> sterm list -> string }
   10.82 +
   10.83 +type recon = {
   10.84 +  context: Proof.context,
   10.85 +  typs: typ Symtab.table,
   10.86 +  terms: term Symtab.table,
   10.87 +  rewrite_rules: thm list,
   10.88 +  assms: (int * thm) list }
   10.89 +
   10.90 +
   10.91 +
   10.92 +(* translation context *)
   10.93 +
   10.94 +fun make_tr_context {sort_prefix, func_prefix} =
   10.95 +  (sort_prefix, 1, Typtab.empty, func_prefix, 1, Termtab.empty)
   10.96 +
   10.97 +fun string_of_index pre i = pre ^ string_of_int i
   10.98 +
   10.99 +fun add_typ T proper (cx as (sp, Tidx, typs, fp, idx, terms)) =
  10.100 +  (case Typtab.lookup typs T of
  10.101 +    SOME (n, _) => (n, cx)
  10.102 +  | NONE =>
  10.103 +      let
  10.104 +        val n = string_of_index sp Tidx
  10.105 +        val typs' = Typtab.update (T, (n, proper)) typs
  10.106 +      in (n, (sp, Tidx+1, typs', fp, idx, terms)) end)
  10.107 +
  10.108 +fun add_fun t sort (cx as (sp, Tidx, typs, fp, idx, terms)) =
  10.109 +  (case Termtab.lookup terms t of
  10.110 +    SOME (n, _) => (n, cx)
  10.111 +  | NONE => 
  10.112 +      let
  10.113 +        val n = string_of_index fp idx
  10.114 +        val terms' = Termtab.update (t, (n, sort)) terms
  10.115 +      in (n, (sp, Tidx, typs, fp, idx+1, terms')) end)
  10.116 +
  10.117 +fun sign_of header dtyps (_, _, typs, _, _, terms) = {
  10.118 +  header = header,
  10.119 +  sorts = Typtab.fold (fn (_, (n, true)) => cons n | _ => I) typs [],
  10.120 +  dtyps = dtyps,
  10.121 +  funcs = Termtab.fold (fn (_, (n, SOME ss)) => cons (n,ss) | _ => I) terms []}
  10.122 +
  10.123 +fun recon_of ctxt rules thms ithms (_, _, typs, _, _, terms) =
  10.124 +  let
  10.125 +    fun add_typ (T, (n, _)) = Symtab.update (n, T)
  10.126 +    val typs' = Typtab.fold add_typ typs Symtab.empty
  10.127 +
  10.128 +    fun add_fun (t, (n, _)) = Symtab.update (n, t)
  10.129 +    val terms' = Termtab.fold add_fun terms Symtab.empty
  10.130 +
  10.131 +    val assms = map (pair ~1) thms @ ithms
  10.132 +  in
  10.133 +    {context=ctxt, typs=typs', terms=terms', rewrite_rules=rules, assms=assms}
  10.134 +  end
  10.135 +
  10.136 +
  10.137 +
  10.138 +(* preprocessing *)
  10.139 +
  10.140 +(** datatype declarations **)
  10.141 +
  10.142 +fun collect_datatypes_and_records (tr_context, ctxt) ts =
  10.143 +  let
  10.144 +    val (declss, ctxt') =
  10.145 +      fold (Term.fold_types Old_SMT_Datatypes.add_decls) ts ([], ctxt)
  10.146 +
  10.147 +    fun is_decl_typ T = exists (exists (equal T o fst)) declss
  10.148 +
  10.149 +    fun add_typ' T proper =
  10.150 +      (case Old_SMT_Builtin.dest_builtin_typ ctxt' T of
  10.151 +        SOME n => pair n
  10.152 +      | NONE => add_typ T proper)
  10.153 +
  10.154 +    fun tr_select sel =
  10.155 +      let val T = Term.range_type (Term.fastype_of sel)
  10.156 +      in add_fun sel NONE ##>> add_typ' T (not (is_decl_typ T)) end
  10.157 +    fun tr_constr (constr, selects) =
  10.158 +      add_fun constr NONE ##>> fold_map tr_select selects
  10.159 +    fun tr_typ (T, cases) = add_typ' T false ##>> fold_map tr_constr cases
  10.160 +    val (declss', tr_context') = fold_map (fold_map tr_typ) declss tr_context
  10.161 +
  10.162 +    fun add (constr, selects) =
  10.163 +      Termtab.update (constr, length selects) #>
  10.164 +      fold (Termtab.update o rpair 1) selects
  10.165 +    val funcs = fold (fold (fold add o snd)) declss Termtab.empty
  10.166 +  in ((funcs, declss', tr_context', ctxt'), ts) end
  10.167 +    (* FIXME: also return necessary datatype and record theorems *)
  10.168 +
  10.169 +
  10.170 +(** eta-expand quantifiers, let expressions and built-ins *)
  10.171 +
  10.172 +local
  10.173 +  fun eta f T t = Abs (Name.uu, T, f (Term.incr_boundvars 1 t $ Bound 0))
  10.174 +
  10.175 +  fun exp f T = eta f (Term.domain_type (Term.domain_type T))
  10.176 +
  10.177 +  fun exp2 T q =
  10.178 +    let val U = Term.domain_type T
  10.179 +    in Abs (Name.uu, U, q $ eta I (Term.domain_type U) (Bound 0)) end
  10.180 +
  10.181 +  fun exp2' T l =
  10.182 +    let val (U1, U2) = Term.dest_funT T ||> Term.domain_type
  10.183 +    in Abs (Name.uu, U1, eta I U2 (l $ Bound 0)) end
  10.184 +
  10.185 +  fun expf k i T t =
  10.186 +    let val Ts = drop i (fst (Old_SMT_Utils.dest_funT k T))
  10.187 +    in
  10.188 +      Term.incr_boundvars (length Ts) t
  10.189 +      |> fold_rev (fn i => fn u => u $ Bound i) (0 upto length Ts - 1)
  10.190 +      |> fold_rev (fn T => fn u => Abs (Name.uu, T, u)) Ts
  10.191 +    end
  10.192 +in
  10.193 +
  10.194 +fun eta_expand ctxt is_fol funcs =
  10.195 +  let
  10.196 +    fun exp_func t T ts =
  10.197 +      (case Termtab.lookup funcs t of
  10.198 +        SOME k =>
  10.199 +          Term.list_comb (t, ts)
  10.200 +          |> k <> length ts ? expf k (length ts) T
  10.201 +      | NONE => Term.list_comb (t, ts))
  10.202 +
  10.203 +    fun expand ((q as Const (@{const_name All}, _)) $ Abs a) = q $ abs_expand a
  10.204 +      | expand ((q as Const (@{const_name All}, T)) $ t) = q $ exp expand T t
  10.205 +      | expand (q as Const (@{const_name All}, T)) = exp2 T q
  10.206 +      | expand ((q as Const (@{const_name Ex}, _)) $ Abs a) = q $ abs_expand a
  10.207 +      | expand ((q as Const (@{const_name Ex}, T)) $ t) = q $ exp expand T t
  10.208 +      | expand (q as Const (@{const_name Ex}, T)) = exp2 T q
  10.209 +      | expand ((l as Const (@{const_name Let}, _)) $ t $ Abs a) =
  10.210 +          if is_fol then expand (Term.betapply (Abs a, t))
  10.211 +          else l $ expand t $ abs_expand a
  10.212 +      | expand ((l as Const (@{const_name Let}, T)) $ t $ u) =
  10.213 +          if is_fol then expand (u $ t)
  10.214 +          else l $ expand t $ exp expand (Term.range_type T) u
  10.215 +      | expand ((l as Const (@{const_name Let}, T)) $ t) =
  10.216 +          if is_fol then
  10.217 +            let val U = Term.domain_type (Term.range_type T)
  10.218 +            in Abs (Name.uu, U, Bound 0 $ Term.incr_boundvars 1 t) end
  10.219 +          else exp2 T (l $ expand t)
  10.220 +      | expand (l as Const (@{const_name Let}, T)) =
  10.221 +          if is_fol then 
  10.222 +            let val U = Term.domain_type (Term.range_type T)
  10.223 +            in
  10.224 +              Abs (Name.uu, Term.domain_type T, Abs (Name.uu, U,
  10.225 +                Bound 0 $ Bound 1))
  10.226 +            end
  10.227 +          else exp2' T l
  10.228 +      | expand t =
  10.229 +          (case Term.strip_comb t of
  10.230 +            (u as Const (c as (_, T)), ts) =>
  10.231 +              (case Old_SMT_Builtin.dest_builtin ctxt c ts of
  10.232 +                SOME (_, k, us, mk) =>
  10.233 +                  if k = length us then mk (map expand us)
  10.234 +                  else if k < length us then
  10.235 +                    chop k (map expand us) |>> mk |> Term.list_comb
  10.236 +                  else expf k (length ts) T (mk (map expand us))
  10.237 +              | NONE => exp_func u T (map expand ts))
  10.238 +          | (u as Free (_, T), ts) => exp_func u T (map expand ts)
  10.239 +          | (Abs a, ts) => Term.list_comb (abs_expand a, map expand ts)
  10.240 +          | (u, ts) => Term.list_comb (u, map expand ts))
  10.241 +
  10.242 +    and abs_expand (n, T, t) = Abs (n, T, expand t)
  10.243 +  
  10.244 +  in map expand end
  10.245 +
  10.246 +end
  10.247 +
  10.248 +
  10.249 +(** introduce explicit applications **)
  10.250 +
  10.251 +local
  10.252 +  (*
  10.253 +    Make application explicit for functions with varying number of arguments.
  10.254 +  *)
  10.255 +
  10.256 +  fun add t i = apfst (Termtab.map_default (t, i) (Integer.min i))
  10.257 +  fun add_type T = apsnd (Typtab.update (T, ()))
  10.258 +
  10.259 +  fun min_arities t =
  10.260 +    (case Term.strip_comb t of
  10.261 +      (u as Const _, ts) => add u (length ts) #> fold min_arities ts
  10.262 +    | (u as Free _, ts) => add u (length ts) #> fold min_arities ts
  10.263 +    | (Abs (_, T, u), ts) => add_type T #> min_arities u #> fold min_arities ts
  10.264 +    | (_, ts) => fold min_arities ts)
  10.265 +
  10.266 +  fun minimize types t i =
  10.267 +    let
  10.268 +      fun find_min j [] _ = j
  10.269 +        | find_min j (U :: Us) T =
  10.270 +            if Typtab.defined types T then j
  10.271 +            else find_min (j + 1) Us (U --> T)
  10.272 +
  10.273 +      val (Ts, T) = Term.strip_type (Term.type_of t)
  10.274 +    in find_min 0 (take i (rev Ts)) T end
  10.275 +
  10.276 +  fun app u (t, T) =
  10.277 +    (Const (@{const_name fun_app}, T --> T) $ t $ u, Term.range_type T)
  10.278 +
  10.279 +  fun apply i t T ts =
  10.280 +    let
  10.281 +      val (ts1, ts2) = chop i ts
  10.282 +      val (_, U) = Old_SMT_Utils.dest_funT i T
  10.283 +    in fst (fold app ts2 (Term.list_comb (t, ts1), U)) end
  10.284 +in
  10.285 +
  10.286 +fun intro_explicit_application ctxt funcs ts =
  10.287 +  let
  10.288 +    val (arities, types) = fold min_arities ts (Termtab.empty, Typtab.empty)
  10.289 +    val arities' = Termtab.map (minimize types) arities
  10.290 +
  10.291 +    fun app_func t T ts =
  10.292 +      if is_some (Termtab.lookup funcs t) then Term.list_comb (t, ts)
  10.293 +      else apply (the (Termtab.lookup arities' t)) t T ts
  10.294 +
  10.295 +    fun in_list T f t = HOLogic.mk_list T (map f (HOLogic.dest_list t))
  10.296 +
  10.297 +    fun traverse Ts t =
  10.298 +      (case Term.strip_comb t of
  10.299 +        (q as Const (@{const_name All}, _), [Abs (x, T, u)]) =>
  10.300 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  10.301 +      | (q as Const (@{const_name Ex}, _), [Abs (x, T, u)]) =>
  10.302 +          q $ Abs (x, T, in_trigger (T :: Ts) u)
  10.303 +      | (q as Const (@{const_name Let}, _), [u1, u2 as Abs _]) =>
  10.304 +          q $ traverse Ts u1 $ traverse Ts u2
  10.305 +      | (u as Const (c as (_, T)), ts) =>
  10.306 +          (case Old_SMT_Builtin.dest_builtin ctxt c ts of
  10.307 +            SOME (_, k, us, mk) =>
  10.308 +              let
  10.309 +                val (ts1, ts2) = chop k (map (traverse Ts) us)
  10.310 +                val U = Term.strip_type T |>> snd o chop k |> (op --->)
  10.311 +              in apply 0 (mk ts1) U ts2 end
  10.312 +          | NONE => app_func u T (map (traverse Ts) ts))
  10.313 +      | (u as Free (_, T), ts) => app_func u T (map (traverse Ts) ts)
  10.314 +      | (u as Bound i, ts) => apply 0 u (nth Ts i) (map (traverse Ts) ts)
  10.315 +      | (Abs (n, T, u), ts) => traverses Ts (Abs (n, T, traverse (T::Ts) u)) ts
  10.316 +      | (u, ts) => traverses Ts u ts)
  10.317 +    and in_trigger Ts ((c as @{const trigger}) $ p $ t) =
  10.318 +          c $ in_pats Ts p $ in_weight Ts t
  10.319 +      | in_trigger Ts t = in_weight Ts t
  10.320 +    and in_pats Ts ps =
  10.321 +      in_list @{typ "pattern list"}
  10.322 +        (in_list @{typ pattern} (in_pat Ts)) ps
  10.323 +    and in_pat Ts ((p as Const (@{const_name pat}, _)) $ t) =
  10.324 +          p $ traverse Ts t
  10.325 +      | in_pat Ts ((p as Const (@{const_name nopat}, _)) $ t) =
  10.326 +          p $ traverse Ts t
  10.327 +      | in_pat _ t = raise TERM ("bad pattern", [t])
  10.328 +    and in_weight Ts ((c as @{const weight}) $ w $ t) =
  10.329 +          c $ w $ traverse Ts t
  10.330 +      | in_weight Ts t = traverse Ts t 
  10.331 +    and traverses Ts t ts = Term.list_comb (t, map (traverse Ts) ts)
  10.332 +  in map (traverse []) ts end
  10.333 +
  10.334 +val fun_app_eq = mk_meta_eq @{thm fun_app_def}
  10.335 +
  10.336 +end
  10.337 +
  10.338 +
  10.339 +(** map HOL formulas to FOL formulas (i.e., separate formulas froms terms) **)
  10.340 +
  10.341 +local
  10.342 +  val term_bool = @{lemma "term_true ~= term_false"
  10.343 +    by (simp add: term_true_def term_false_def)}
  10.344 +
  10.345 +  val is_quant = member (op =) [@{const_name All}, @{const_name Ex}]
  10.346 +
  10.347 +  val fol_rules = [
  10.348 +    Let_def,
  10.349 +    mk_meta_eq @{thm term_true_def},
  10.350 +    mk_meta_eq @{thm term_false_def},
  10.351 +    @{lemma "P = True == P" by (rule eq_reflection) simp},
  10.352 +    @{lemma "if P then True else False == P" by (rule eq_reflection) simp}]
  10.353 +
  10.354 +  fun as_term t = @{const HOL.eq (bool)} $ t $ @{const term_true}
  10.355 +
  10.356 +  exception BAD_PATTERN of unit
  10.357 +
  10.358 +  fun wrap_in_if pat t =
  10.359 +    if pat then
  10.360 +      raise BAD_PATTERN ()
  10.361 +    else
  10.362 +      @{const If (bool)} $ t $ @{const term_true} $ @{const term_false}
  10.363 +
  10.364 +  fun is_builtin_conn_or_pred ctxt c ts =
  10.365 +    is_some (Old_SMT_Builtin.dest_builtin_conn ctxt c ts) orelse
  10.366 +    is_some (Old_SMT_Builtin.dest_builtin_pred ctxt c ts)
  10.367 +
  10.368 +  fun builtin b ctxt c ts =
  10.369 +    (case (Const c, ts) of
  10.370 +      (@{const HOL.eq (bool)}, [t, u]) =>
  10.371 +        if t = @{const term_true} orelse u = @{const term_true} then
  10.372 +          Old_SMT_Builtin.dest_builtin_eq ctxt t u
  10.373 +        else b ctxt c ts
  10.374 +    | _ => b ctxt c ts)
  10.375 +in
  10.376 +
  10.377 +fun folify ctxt =
  10.378 +  let
  10.379 +    fun in_list T f t = HOLogic.mk_list T (map_filter f (HOLogic.dest_list t))
  10.380 +
  10.381 +    fun in_term pat t =
  10.382 +      (case Term.strip_comb t of
  10.383 +        (@{const True}, []) => @{const term_true}
  10.384 +      | (@{const False}, []) => @{const term_false}
  10.385 +      | (u as Const (@{const_name If}, _), [t1, t2, t3]) =>
  10.386 +          if pat then raise BAD_PATTERN ()
  10.387 +          else u $ in_form t1 $ in_term pat t2 $ in_term pat t3
  10.388 +      | (Const (c as (n, _)), ts) =>
  10.389 +          if is_builtin_conn_or_pred ctxt c ts then wrap_in_if pat (in_form t)
  10.390 +          else if is_quant n then wrap_in_if pat (in_form t)
  10.391 +          else Term.list_comb (Const c, map (in_term pat) ts)
  10.392 +      | (Free c, ts) => Term.list_comb (Free c, map (in_term pat) ts)
  10.393 +      | _ => t)
  10.394 +
  10.395 +    and in_weight ((c as @{const weight}) $ w $ t) = c $ w $ in_form t
  10.396 +      | in_weight t = in_form t 
  10.397 +
  10.398 +    and in_pat ((p as Const (@{const_name pat}, _)) $ t) =
  10.399 +          p $ in_term true t
  10.400 +      | in_pat ((p as Const (@{const_name nopat}, _)) $ t) =
  10.401 +          p $ in_term true t
  10.402 +      | in_pat t = raise TERM ("bad pattern", [t])
  10.403 +
  10.404 +    and in_pats ps =
  10.405 +      in_list @{typ "pattern list"}
  10.406 +        (SOME o in_list @{typ pattern} (try in_pat)) ps
  10.407 +
  10.408 +    and in_trigger ((c as @{const trigger}) $ p $ t) =
  10.409 +          c $ in_pats p $ in_weight t
  10.410 +      | in_trigger t = in_weight t
  10.411 +
  10.412 +    and in_form t =
  10.413 +      (case Term.strip_comb t of
  10.414 +        (q as Const (qn, _), [Abs (n, T, u)]) =>
  10.415 +          if is_quant qn then q $ Abs (n, T, in_trigger u)
  10.416 +          else as_term (in_term false t)
  10.417 +      | (Const c, ts) =>
  10.418 +          (case Old_SMT_Builtin.dest_builtin_conn ctxt c ts of
  10.419 +            SOME (_, _, us, mk) => mk (map in_form us)
  10.420 +          | NONE =>
  10.421 +              (case Old_SMT_Builtin.dest_builtin_pred ctxt c ts of
  10.422 +                SOME (_, _, us, mk) => mk (map (in_term false) us)
  10.423 +              | NONE => as_term (in_term false t)))
  10.424 +      | _ => as_term (in_term false t))
  10.425 +  in
  10.426 +    map in_form #>
  10.427 +    cons (Old_SMT_Utils.prop_of term_bool) #>
  10.428 +    pair (fol_rules, [term_bool], builtin)
  10.429 +  end
  10.430 +
  10.431 +end
  10.432 +
  10.433 +
  10.434 +(* translation into intermediate format *)
  10.435 +
  10.436 +(** utility functions **)
  10.437 +
  10.438 +val quantifier = (fn
  10.439 +    @{const_name All} => SOME SForall
  10.440 +  | @{const_name Ex} => SOME SExists
  10.441 +  | _ => NONE)
  10.442 +
  10.443 +fun group_quant qname Ts (t as Const (q, _) $ Abs (_, T, u)) =
  10.444 +      if q = qname then group_quant qname (T :: Ts) u else (Ts, t)
  10.445 +  | group_quant _ Ts t = (Ts, t)
  10.446 +
  10.447 +fun dest_weight (@{const weight} $ w $ t) =
  10.448 +      (SOME (snd (HOLogic.dest_number w)), t)
  10.449 +  | dest_weight t = (NONE, t)
  10.450 +
  10.451 +fun dest_pat (Const (@{const_name pat}, _) $ t) = (t, true)
  10.452 +  | dest_pat (Const (@{const_name nopat}, _) $ t) = (t, false)
  10.453 +  | dest_pat t = raise TERM ("bad pattern", [t])
  10.454 +
  10.455 +fun dest_pats [] = I
  10.456 +  | dest_pats ts =
  10.457 +      (case map dest_pat ts |> split_list ||> distinct (op =) of
  10.458 +        (ps, [true]) => cons (SPat ps)
  10.459 +      | (ps, [false]) => cons (SNoPat ps)
  10.460 +      | _ => raise TERM ("bad multi-pattern", ts))
  10.461 +
  10.462 +fun dest_trigger (@{const trigger} $ tl $ t) =
  10.463 +      (rev (fold (dest_pats o HOLogic.dest_list) (HOLogic.dest_list tl) []), t)
  10.464 +  | dest_trigger t = ([], t)
  10.465 +
  10.466 +fun dest_quant qn T t = quantifier qn |> Option.map (fn q =>
  10.467 +  let
  10.468 +    val (Ts, u) = group_quant qn [T] t
  10.469 +    val (ps, p) = dest_trigger u
  10.470 +    val (w, b) = dest_weight p
  10.471 +  in (q, rev Ts, ps, w, b) end)
  10.472 +
  10.473 +fun fold_map_pat f (SPat ts) = fold_map f ts #>> SPat
  10.474 +  | fold_map_pat f (SNoPat ts) = fold_map f ts #>> SNoPat
  10.475 +
  10.476 +
  10.477 +(** translation from Isabelle terms into SMT intermediate terms **)
  10.478 +
  10.479 +fun intermediate header dtyps builtin ctxt ts trx =
  10.480 +  let
  10.481 +    fun transT (T as TFree _) = add_typ T true
  10.482 +      | transT (T as TVar _) = (fn _ => raise TYPE ("bad SMT type", [T], []))
  10.483 +      | transT (T as Type _) =
  10.484 +          (case Old_SMT_Builtin.dest_builtin_typ ctxt T of
  10.485 +            SOME n => pair n
  10.486 +          | NONE => add_typ T true)
  10.487 +
  10.488 +    fun app n ts = SApp (n, ts)
  10.489 +
  10.490 +    fun trans t =
  10.491 +      (case Term.strip_comb t of
  10.492 +        (Const (qn, _), [Abs (_, T, t1)]) =>
  10.493 +          (case dest_quant qn T t1 of
  10.494 +            SOME (q, Ts, ps, w, b) =>
  10.495 +              fold_map transT Ts ##>> fold_map (fold_map_pat trans) ps ##>>
  10.496 +              trans b #>> (fn ((Ts', ps'), b') => SQua (q, Ts', ps', w, b'))
  10.497 +          | NONE => raise TERM ("unsupported quantifier", [t]))
  10.498 +      | (Const (@{const_name Let}, _), [t1, Abs (_, T, t2)]) =>
  10.499 +          transT T ##>> trans t1 ##>> trans t2 #>>
  10.500 +          (fn ((U, u1), u2) => SLet (U, u1, u2))
  10.501 +      | (u as Const (c as (_, T)), ts) =>
  10.502 +          (case builtin ctxt c ts of
  10.503 +            SOME (n, _, us, _) => fold_map trans us #>> app n
  10.504 +          | NONE => transs u T ts)
  10.505 +      | (u as Free (_, T), ts) => transs u T ts
  10.506 +      | (Bound i, []) => pair (SVar i)
  10.507 +      | _ => raise TERM ("bad SMT term", [t]))
  10.508 + 
  10.509 +    and transs t T ts =
  10.510 +      let val (Us, U) = Old_SMT_Utils.dest_funT (length ts) T
  10.511 +      in
  10.512 +        fold_map transT Us ##>> transT U #-> (fn Up =>
  10.513 +        add_fun t (SOME Up) ##>> fold_map trans ts #>> SApp)
  10.514 +      end
  10.515 +
  10.516 +    val (us, trx') = fold_map trans ts trx
  10.517 +  in ((sign_of (header ts) dtyps trx', us), trx') end
  10.518 +
  10.519 +
  10.520 +
  10.521 +(* translation *)
  10.522 +
  10.523 +structure Configs = Generic_Data
  10.524 +(
  10.525 +  type T = (Proof.context -> config) Old_SMT_Utils.dict
  10.526 +  val empty = []
  10.527 +  val extend = I
  10.528 +  fun merge data = Old_SMT_Utils.dict_merge fst data
  10.529 +)
  10.530 +
  10.531 +fun add_config (cs, cfg) = Configs.map (Old_SMT_Utils.dict_update (cs, cfg))
  10.532 +
  10.533 +fun get_config ctxt = 
  10.534 +  let val cs = Old_SMT_Config.solver_class_of ctxt
  10.535 +  in
  10.536 +    (case Old_SMT_Utils.dict_get (Configs.get (Context.Proof ctxt)) cs of
  10.537 +      SOME cfg => cfg ctxt
  10.538 +    | NONE => error ("SMT: no translation configuration found " ^
  10.539 +        "for solver class " ^ quote (Old_SMT_Utils.string_of_class cs)))
  10.540 +  end
  10.541 +
  10.542 +fun translate ctxt comments ithms =
  10.543 +  let
  10.544 +    val {prefixes, is_fol, header, has_datatypes, serialize} = get_config ctxt
  10.545 +
  10.546 +    val with_datatypes =
  10.547 +      has_datatypes andalso Config.get ctxt Old_SMT_Config.datatypes
  10.548 +
  10.549 +    fun no_dtyps (tr_context, ctxt) ts =
  10.550 +      ((Termtab.empty, [], tr_context, ctxt), ts)
  10.551 +
  10.552 +    val ts1 = map (Envir.beta_eta_contract o Old_SMT_Utils.prop_of o snd) ithms
  10.553 +
  10.554 +    val ((funcs, dtyps, tr_context, ctxt1), ts2) =
  10.555 +      ((make_tr_context prefixes, ctxt), ts1)
  10.556 +      |-> (if with_datatypes then collect_datatypes_and_records else no_dtyps)
  10.557 +
  10.558 +    fun is_binder (Const (@{const_name Let}, _) $ _) = true
  10.559 +      | is_binder t = Lambda_Lifting.is_quantifier t
  10.560 +
  10.561 +    fun mk_trigger ((q as Const (@{const_name All}, _)) $ Abs (n, T, t)) =
  10.562 +          q $ Abs (n, T, mk_trigger t)
  10.563 +      | mk_trigger (eq as (Const (@{const_name HOL.eq}, T) $ lhs $ _)) =
  10.564 +          Term.domain_type T --> @{typ pattern}
  10.565 +          |> (fn T => Const (@{const_name pat}, T) $ lhs)
  10.566 +          |> HOLogic.mk_list @{typ pattern} o single
  10.567 +          |> HOLogic.mk_list @{typ "pattern list"} o single
  10.568 +          |> (fn t => @{const trigger} $ t $ eq)
  10.569 +      | mk_trigger t = t
  10.570 +
  10.571 +    val (ctxt2, ts3) =
  10.572 +      ts2
  10.573 +      |> eta_expand ctxt1 is_fol funcs
  10.574 +      |> rpair ctxt1
  10.575 +      |-> Lambda_Lifting.lift_lambdas NONE is_binder
  10.576 +      |-> (fn (ts', defs) => fn ctxt' =>
  10.577 +          map mk_trigger defs @ ts'
  10.578 +          |> intro_explicit_application ctxt' funcs 
  10.579 +          |> pair ctxt')
  10.580 +
  10.581 +    val ((rewrite_rules, extra_thms, builtin), ts4) =
  10.582 +      (if is_fol then folify ctxt2 else pair ([], [], I)) ts3
  10.583 +
  10.584 +    val rewrite_rules' = fun_app_eq :: rewrite_rules
  10.585 +  in
  10.586 +    (ts4, tr_context)
  10.587 +    |-> intermediate header dtyps (builtin Old_SMT_Builtin.dest_builtin) ctxt2
  10.588 +    |>> uncurry (serialize comments)
  10.589 +    ||> recon_of ctxt2 rewrite_rules' extra_thms ithms
  10.590 +  end
  10.591 +
  10.592 +end
    11.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.2 +++ b/src/HOL/Library/Old_SMT/old_smt_utils.ML	Thu Aug 28 00:40:38 2014 +0200
    11.3 @@ -0,0 +1,227 @@
    11.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_utils.ML
    11.5 +    Author:     Sascha Boehme, TU Muenchen
    11.6 +
    11.7 +General utility functions.
    11.8 +*)
    11.9 +
   11.10 +signature OLD_SMT_UTILS =
   11.11 +sig
   11.12 +  (*basic combinators*)
   11.13 +  val repeat: ('a -> 'a option) -> 'a -> 'a
   11.14 +  val repeat_yield: ('a -> 'b -> ('a * 'b) option) -> 'a -> 'b -> 'a * 'b
   11.15 +
   11.16 +  (*class dictionaries*)
   11.17 +  type class = string list
   11.18 +  val basicC: class
   11.19 +  val string_of_class: class -> string
   11.20 +  type 'a dict = (class * 'a) Ord_List.T
   11.21 +  val dict_map_default: class * 'a -> ('a -> 'a) -> 'a dict -> 'a dict
   11.22 +  val dict_update: class * 'a -> 'a dict -> 'a dict
   11.23 +  val dict_merge: ('a * 'a -> 'a) -> 'a dict * 'a dict -> 'a dict
   11.24 +  val dict_lookup: 'a dict -> class -> 'a list
   11.25 +  val dict_get: 'a dict -> class -> 'a option
   11.26 +
   11.27 +  (*types*)
   11.28 +  val dest_funT: int -> typ -> typ list * typ
   11.29 +
   11.30 +  (*terms*)
   11.31 +  val dest_conj: term -> term * term
   11.32 +  val dest_disj: term -> term * term
   11.33 +  val under_quant: (term -> 'a) -> term -> 'a
   11.34 +  val is_number: term -> bool
   11.35 +
   11.36 +  (*patterns and instantiations*)
   11.37 +  val mk_const_pat: theory -> string -> (ctyp -> 'a) -> 'a * cterm
   11.38 +  val destT1: ctyp -> ctyp
   11.39 +  val destT2: ctyp -> ctyp
   11.40 +  val instTs: ctyp list -> ctyp list * cterm -> cterm
   11.41 +  val instT: ctyp -> ctyp * cterm -> cterm
   11.42 +  val instT': cterm -> ctyp * cterm -> cterm
   11.43 +
   11.44 +  (*certified terms*)
   11.45 +  val certify: Proof.context -> term -> cterm
   11.46 +  val typ_of: cterm -> typ
   11.47 +  val dest_cabs: cterm -> Proof.context -> cterm * Proof.context
   11.48 +  val dest_all_cabs: cterm -> Proof.context -> cterm * Proof.context
   11.49 +  val dest_cbinder: cterm -> Proof.context -> cterm * Proof.context
   11.50 +  val dest_all_cbinders: cterm -> Proof.context -> cterm * Proof.context
   11.51 +  val mk_cprop: cterm -> cterm
   11.52 +  val dest_cprop: cterm -> cterm
   11.53 +  val mk_cequals: cterm -> cterm -> cterm
   11.54 +  val term_of: cterm -> term
   11.55 +  val prop_of: thm -> term
   11.56 +
   11.57 +  (*conversions*)
   11.58 +  val if_conv: (term -> bool) -> conv -> conv -> conv
   11.59 +  val if_true_conv: (term -> bool) -> conv -> conv
   11.60 +  val if_exists_conv: (term -> bool) -> conv -> conv
   11.61 +  val binders_conv: (Proof.context -> conv) -> Proof.context -> conv
   11.62 +  val under_quant_conv: (Proof.context * cterm list -> conv) ->
   11.63 +    Proof.context -> conv
   11.64 +  val prop_conv: conv -> conv
   11.65 +end
   11.66 +
   11.67 +structure Old_SMT_Utils: OLD_SMT_UTILS =
   11.68 +struct
   11.69 +
   11.70 +(* basic combinators *)
   11.71 +
   11.72 +fun repeat f =
   11.73 +  let fun rep x = (case f x of SOME y => rep y | NONE => x)
   11.74 +  in rep end
   11.75 +
   11.76 +fun repeat_yield f =
   11.77 +  let fun rep x y = (case f x y of SOME (x', y') => rep x' y' | NONE => (x, y))
   11.78 +  in rep end
   11.79 +
   11.80 +
   11.81 +(* class dictionaries *)
   11.82 +
   11.83 +type class = string list
   11.84 +
   11.85 +val basicC = []
   11.86 +
   11.87 +fun string_of_class [] = "basic"
   11.88 +  | string_of_class cs = "basic." ^ space_implode "." cs
   11.89 +
   11.90 +type 'a dict = (class * 'a) Ord_List.T
   11.91 +
   11.92 +fun class_ord ((cs1, _), (cs2, _)) =
   11.93 +  rev_order (list_ord fast_string_ord (cs1, cs2))
   11.94 +
   11.95 +fun dict_insert (cs, x) d =
   11.96 +  if AList.defined (op =) d cs then d
   11.97 +  else Ord_List.insert class_ord (cs, x) d
   11.98 +
   11.99 +fun dict_map_default (cs, x) f =
  11.100 +  dict_insert (cs, x) #> AList.map_entry (op =) cs f
  11.101 +
  11.102 +fun dict_update (e as (_, x)) = dict_map_default e (K x)
  11.103 +
  11.104 +fun dict_merge val_merge = sort class_ord o AList.join (op =) (K val_merge)
  11.105 +
  11.106 +fun dict_lookup d cs =
  11.107 +  let fun match (cs', x) = if is_prefix (op =) cs' cs then SOME x else NONE
  11.108 +  in map_filter match d end
  11.109 +
  11.110 +fun dict_get d cs =
  11.111 +  (case AList.lookup (op =) d cs of
  11.112 +    NONE => (case cs of [] => NONE | _ => dict_get d (take (length cs - 1) cs))
  11.113 +  | SOME x => SOME x)
  11.114 +
  11.115 +
  11.116 +(* types *)
  11.117 +
  11.118 +val dest_funT =
  11.119 +  let
  11.120 +    fun dest Ts 0 T = (rev Ts, T)
  11.121 +      | dest Ts i (Type ("fun", [T, U])) = dest (T::Ts) (i-1) U
  11.122 +      | dest _ _ T = raise TYPE ("not a function type", [T], [])
  11.123 +  in dest [] end
  11.124 +
  11.125 +
  11.126 +(* terms *)
  11.127 +
  11.128 +fun dest_conj (@{const HOL.conj} $ t $ u) = (t, u)
  11.129 +  | dest_conj t = raise TERM ("not a conjunction", [t])
  11.130 +
  11.131 +fun dest_disj (@{const HOL.disj} $ t $ u) = (t, u)
  11.132 +  | dest_disj t = raise TERM ("not a disjunction", [t])
  11.133 +
  11.134 +fun under_quant f t =
  11.135 +  (case t of
  11.136 +    Const (@{const_name All}, _) $ Abs (_, _, u) => under_quant f u
  11.137 +  | Const (@{const_name Ex}, _) $ Abs (_, _, u) => under_quant f u
  11.138 +  | _ => f t)
  11.139 +
  11.140 +val is_number =
  11.141 +  let
  11.142 +    fun is_num env (Const (@{const_name If}, _) $ _ $ t $ u) =
  11.143 +          is_num env t andalso is_num env u
  11.144 +      | is_num env (Const (@{const_name Let}, _) $ t $ Abs (_, _, u)) =
  11.145 +          is_num (t :: env) u
  11.146 +      | is_num env (Bound i) = i < length env andalso is_num env (nth env i)
  11.147 +      | is_num _ t = can HOLogic.dest_number t
  11.148 +  in is_num [] end
  11.149 +
  11.150 +
  11.151 +(* patterns and instantiations *)
  11.152 +
  11.153 +fun mk_const_pat thy name destT =
  11.154 +  let val cpat = Thm.cterm_of thy (Const (name, Sign.the_const_type thy name))
  11.155 +  in (destT (Thm.ctyp_of_term cpat), cpat) end
  11.156 +
  11.157 +val destT1 = hd o Thm.dest_ctyp
  11.158 +val destT2 = hd o tl o Thm.dest_ctyp
  11.159 +
  11.160 +fun instTs cUs (cTs, ct) = Thm.instantiate_cterm (cTs ~~ cUs, []) ct
  11.161 +fun instT cU (cT, ct) = instTs [cU] ([cT], ct)
  11.162 +fun instT' ct = instT (Thm.ctyp_of_term ct)
  11.163 +
  11.164 +
  11.165 +(* certified terms *)
  11.166 +
  11.167 +fun certify ctxt = Thm.cterm_of (Proof_Context.theory_of ctxt)
  11.168 +
  11.169 +fun typ_of ct = #T (Thm.rep_cterm ct) 
  11.170 +
  11.171 +fun dest_cabs ct ctxt =
  11.172 +  (case Thm.term_of ct of
  11.173 +    Abs _ =>
  11.174 +      let val (n, ctxt') = yield_singleton Variable.variant_fixes Name.uu ctxt
  11.175 +      in (snd (Thm.dest_abs (SOME n) ct), ctxt') end
  11.176 +  | _ => raise CTERM ("no abstraction", [ct]))
  11.177 +
  11.178 +val dest_all_cabs = repeat_yield (try o dest_cabs) 
  11.179 +
  11.180 +fun dest_cbinder ct ctxt =
  11.181 +  (case Thm.term_of ct of
  11.182 +    Const _ $ Abs _ => dest_cabs (Thm.dest_arg ct) ctxt
  11.183 +  | _ => raise CTERM ("not a binder", [ct]))
  11.184 +
  11.185 +val dest_all_cbinders = repeat_yield (try o dest_cbinder)
  11.186 +
  11.187 +val mk_cprop = Thm.apply (Thm.cterm_of @{theory} @{const Trueprop})
  11.188 +
  11.189 +fun dest_cprop ct =
  11.190 +  (case Thm.term_of ct of
  11.191 +    @{const Trueprop} $ _ => Thm.dest_arg ct
  11.192 +  | _ => raise CTERM ("not a property", [ct]))
  11.193 +
  11.194 +val equals = mk_const_pat @{theory} @{const_name Pure.eq} destT1
  11.195 +fun mk_cequals ct cu = Thm.mk_binop (instT' ct equals) ct cu
  11.196 +
  11.197 +val dest_prop = (fn @{const Trueprop} $ t => t | t => t)
  11.198 +fun term_of ct = dest_prop (Thm.term_of ct)
  11.199 +fun prop_of thm = dest_prop (Thm.prop_of thm)
  11.200 +
  11.201 +
  11.202 +(* conversions *)
  11.203 +
  11.204 +fun if_conv pred cv1 cv2 ct = if pred (Thm.term_of ct) then cv1 ct else cv2 ct
  11.205 +
  11.206 +fun if_true_conv pred cv = if_conv pred cv Conv.all_conv
  11.207 +
  11.208 +fun if_exists_conv pred = if_true_conv (Term.exists_subterm pred)
  11.209 +
  11.210 +fun binders_conv cv ctxt =
  11.211 +  Conv.binder_conv (binders_conv cv o snd) ctxt else_conv cv ctxt
  11.212 +
  11.213 +fun under_quant_conv cv ctxt =
  11.214 +  let
  11.215 +    fun quant_conv inside ctxt cvs ct =
  11.216 +      (case Thm.term_of ct of
  11.217 +        Const (@{const_name All}, _) $ Abs _ =>
  11.218 +          Conv.binder_conv (under_conv cvs) ctxt
  11.219 +      | Const (@{const_name Ex}, _) $ Abs _ =>
  11.220 +          Conv.binder_conv (under_conv cvs) ctxt
  11.221 +      | _ => if inside then cv (ctxt, cvs) else Conv.all_conv) ct
  11.222 +    and under_conv cvs (cv, ctxt) = quant_conv true ctxt (cv :: cvs)
  11.223 +  in quant_conv false ctxt [] end
  11.224 +
  11.225 +fun prop_conv cv ct =
  11.226 +  (case Thm.term_of ct of
  11.227 +    @{const Trueprop} $ _ => Conv.arg_conv cv ct
  11.228 +  | _ => raise CTERM ("not a property", [ct]))
  11.229 +
  11.230 +end
    12.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.2 +++ b/src/HOL/Library/Old_SMT/old_smt_word.ML	Thu Aug 28 00:40:38 2014 +0200
    12.3 @@ -0,0 +1,151 @@
    12.4 +(*  Title:      HOL/Library/Old_SMT/old_smt_word.ML
    12.5 +    Author:     Sascha Boehme, TU Muenchen
    12.6 +
    12.7 +SMT setup for words.
    12.8 +*)
    12.9 +
   12.10 +signature OLD_SMT_WORD =
   12.11 +sig
   12.12 +  val setup: theory -> theory
   12.13 +end
   12.14 +
   12.15 +structure Old_SMT_Word: OLD_SMT_WORD =
   12.16 +struct
   12.17 +
   12.18 +open Word_Lib
   12.19 +
   12.20 +(* SMT-LIB logic *)
   12.21 +
   12.22 +fun smtlib_logic ts =
   12.23 +  if exists (Term.exists_type (Term.exists_subtype is_wordT)) ts
   12.24 +  then SOME "QF_AUFBV"
   12.25 +  else NONE
   12.26 +
   12.27 +
   12.28 +(* SMT-LIB builtins *)
   12.29 +
   12.30 +local
   12.31 +  val smtlibC = Old_SMTLIB_Interface.smtlibC
   12.32 +
   12.33 +  val wordT = @{typ "'a::len word"}
   12.34 +
   12.35 +  fun index1 n i = n ^ "[" ^ string_of_int i ^ "]"
   12.36 +  fun index2 n i j = n ^ "[" ^ string_of_int i ^ ":" ^ string_of_int j ^ "]"
   12.37 +
   12.38 +  fun word_typ (Type (@{type_name word}, [T])) =
   12.39 +        Option.map (index1 "BitVec") (try dest_binT T)
   12.40 +    | word_typ _ = NONE
   12.41 +
   12.42 +  fun word_num (Type (@{type_name word}, [T])) i =
   12.43 +        Option.map (index1 ("bv" ^ string_of_int i)) (try dest_binT T)
   12.44 +    | word_num _ _ = NONE
   12.45 +
   12.46 +  fun if_fixed pred m n T ts =
   12.47 +    let val (Us, U) = Term.strip_type T
   12.48 +    in
   12.49 +      if pred (U, Us) then
   12.50 +        SOME (n, length Us, ts, Term.list_comb o pair (Const (m, T)))
   12.51 +      else NONE
   12.52 +    end
   12.53 +
   12.54 +  fun if_fixed_all m = if_fixed (forall (can dest_wordT) o (op ::)) m
   12.55 +  fun if_fixed_args m = if_fixed (forall (can dest_wordT) o snd) m
   12.56 +
   12.57 +  fun add_word_fun f (t, n) =
   12.58 +    let val (m, _) = Term.dest_Const t
   12.59 +    in Old_SMT_Builtin.add_builtin_fun smtlibC (Term.dest_Const t, K (f m n)) end
   12.60 +
   12.61 +  fun hd2 xs = hd (tl xs)
   12.62 +
   12.63 +  fun mk_nat i = @{const nat} $ HOLogic.mk_number @{typ nat} i
   12.64 +
   12.65 +  fun dest_nat (@{const nat} $ n) = snd (HOLogic.dest_number n)
   12.66 +    | dest_nat t = raise TERM ("not a natural number", [t])
   12.67 +
   12.68 +  fun mk_shift c [t, u] = Const c $ t $ mk_nat (snd (HOLogic.dest_number u))
   12.69 +    | mk_shift c ts = raise TERM ("bad arguments", Const c :: ts)
   12.70 +
   12.71 +  fun shift m n T ts =
   12.72 +    let val U = Term.domain_type T
   12.73 +    in
   12.74 +      (case (can dest_wordT U, try (dest_nat o hd2) ts) of
   12.75 +        (true, SOME i) =>
   12.76 +          SOME (n, 2, [hd ts, HOLogic.mk_number U i], mk_shift (m, T))
   12.77 +      | _ => NONE)   (* FIXME: also support non-numerical shifts *)
   12.78 +    end
   12.79 +
   12.80 +  fun mk_extract c i ts = Term.list_comb (Const c, mk_nat i :: ts)
   12.81 +
   12.82 +  fun extract m n T ts =
   12.83 +    let val U = Term.range_type (Term.range_type T)
   12.84 +    in
   12.85 +      (case (try (dest_nat o hd) ts, try dest_wordT U) of
   12.86 +        (SOME lb, SOME i) =>
   12.87 +          SOME (index2 n (i + lb - 1) lb, 1, tl ts, mk_extract (m, T) lb)
   12.88 +      | _ => NONE)
   12.89 +    end
   12.90 +
   12.91 +  fun mk_extend c ts = Term.list_comb (Const c, ts)
   12.92 +
   12.93 +  fun extend m n T ts =
   12.94 +    let val (U1, U2) = Term.dest_funT T
   12.95 +    in
   12.96 +      (case (try dest_wordT U1, try dest_wordT U2) of
   12.97 +        (SOME i, SOME j) =>
   12.98 +          if j-i >= 0 then SOME (index1 n (j-i), 1, ts, mk_extend (m, T))
   12.99 +          else NONE
  12.100 +      | _ => NONE)
  12.101 +    end
  12.102 +
  12.103 +  fun mk_rotate c i ts = Term.list_comb (Const c, mk_nat i :: ts)
  12.104 +
  12.105 +  fun rotate m n T ts =
  12.106 +    let val U = Term.domain_type (Term.range_type T)
  12.107 +    in
  12.108 +      (case (can dest_wordT U, try (dest_nat o hd) ts) of
  12.109 +        (true, SOME i) => SOME (index1 n i, 1, tl ts, mk_rotate (m, T) i)
  12.110 +      | _ => NONE)
  12.111 +    end
  12.112 +in
  12.113 +
  12.114 +val setup_builtins =
  12.115 +  Old_SMT_Builtin.add_builtin_typ smtlibC (wordT, word_typ, word_num) #>
  12.116 +  fold (add_word_fun if_fixed_all) [
  12.117 +    (@{term "uminus :: 'a::len word => _"}, "bvneg"),
  12.118 +    (@{term "plus :: 'a::len word => _"}, "bvadd"),
  12.119 +    (@{term "minus :: 'a::len word => _"}, "bvsub"),
  12.120 +    (@{term "times :: 'a::len word => _"}, "bvmul"),
  12.121 +    (@{term "bitNOT :: 'a::len word => _"}, "bvnot"),
  12.122 +    (@{term "bitAND :: 'a::len word => _"}, "bvand"),
  12.123 +    (@{term "bitOR :: 'a::len word => _"}, "bvor"),
  12.124 +    (@{term "bitXOR :: 'a::len word => _"}, "bvxor"),
  12.125 +    (@{term "word_cat :: 'a::len word => _"}, "concat") ] #>
  12.126 +  fold (add_word_fun shift) [
  12.127 +    (@{term "shiftl :: 'a::len word => _ "}, "bvshl"),
  12.128 +    (@{term "shiftr :: 'a::len word => _"}, "bvlshr"),
  12.129 +    (@{term "sshiftr :: 'a::len word => _"}, "bvashr") ] #>
  12.130 +  add_word_fun extract
  12.131 +    (@{term "slice :: _ => 'a::len word => _"}, "extract") #>
  12.132 +  fold (add_word_fun extend) [
  12.133 +    (@{term "ucast :: 'a::len word => _"}, "zero_extend"),
  12.134 +    (@{term "scast :: 'a::len word => _"}, "sign_extend") ] #>
  12.135 +  fold (add_word_fun rotate) [
  12.136 +    (@{term word_rotl}, "rotate_left"),
  12.137 +    (@{term word_rotr}, "rotate_right") ] #>
  12.138 +  fold (add_word_fun if_fixed_args) [
  12.139 +    (@{term "less :: 'a::len word => _"}, "bvult"),
  12.140 +    (@{term "less_eq :: 'a::len word => _"}, "bvule"),
  12.141 +    (@{term word_sless}, "bvslt"),
  12.142 +    (@{term word_sle}, "bvsle") ]
  12.143 +
  12.144 +end
  12.145 +
  12.146 +
  12.147 +(* setup *)
  12.148 +
  12.149 +val setup = 
  12.150 +  Context.theory_map (
  12.151 +    Old_SMTLIB_Interface.add_logic (20, smtlib_logic) #>
  12.152 +    setup_builtins)
  12.153 +
  12.154 +end
    13.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.2 +++ b/src/HOL/Library/Old_SMT/old_smtlib_interface.ML	Thu Aug 28 00:40:38 2014 +0200
    13.3 @@ -0,0 +1,161 @@
    13.4 +(*  Title:      HOL/Library/Old_SMT/old_smtlib_interface.ML
    13.5 +    Author:     Sascha Boehme, TU Muenchen
    13.6 +
    13.7 +Interface to SMT solvers based on the SMT-LIB format.
    13.8 +*)
    13.9 +
   13.10 +signature OLD_SMTLIB_INTERFACE =
   13.11 +sig
   13.12 +  val smtlibC: Old_SMT_Utils.class
   13.13 +  val add_logic: int * (term list -> string option) -> Context.generic ->
   13.14 +    Context.generic
   13.15 +  val translate_config: Proof.context -> Old_SMT_Translate.config
   13.16 +  val setup: theory -> theory
   13.17 +end
   13.18 +
   13.19 +structure Old_SMTLIB_Interface: OLD_SMTLIB_INTERFACE =
   13.20 +struct
   13.21 +
   13.22 +
   13.23 +val smtlibC = ["smtlib"]
   13.24 +
   13.25 +
   13.26 +(* builtins *)
   13.27 +
   13.28 +local
   13.29 +  fun int_num _ i = SOME (string_of_int i)
   13.30 +
   13.31 +  fun is_linear [t] = Old_SMT_Utils.is_number t
   13.32 +    | is_linear [t, u] = Old_SMT_Utils.is_number t orelse Old_SMT_Utils.is_number u
   13.33 +    | is_linear _ = false
   13.34 +
   13.35 +  fun times _ _ ts =
   13.36 +    let val mk = Term.list_comb o pair @{const times (int)}
   13.37 +    in if is_linear ts then SOME ("*", 2, ts, mk) else NONE end
   13.38 +in
   13.39 +
   13.40 +val setup_builtins =
   13.41 +  Old_SMT_Builtin.add_builtin_typ smtlibC (@{typ int}, K (SOME "Int"), int_num) #>
   13.42 +  fold (Old_SMT_Builtin.add_builtin_fun' smtlibC) [
   13.43 +    (@{const True}, "true"),
   13.44 +    (@{const False}, "false"),
   13.45 +    (@{const Not}, "not"),
   13.46 +    (@{const HOL.conj}, "and"),
   13.47 +    (@{const HOL.disj}, "or"),
   13.48 +    (@{const HOL.implies}, "implies"),
   13.49 +    (@{const HOL.eq (bool)}, "iff"),
   13.50 +    (@{const HOL.eq ('a)}, "="),
   13.51 +    (@{const If (bool)}, "if_then_else"),
   13.52 +    (@{const If ('a)}, "ite"),
   13.53 +    (@{const less (int)}, "<"),
   13.54 +    (@{const less_eq (int)}, "<="),
   13.55 +    (@{const uminus (int)}, "~"),
   13.56 +    (@{const plus (int)}, "+"),
   13.57 +    (@{const minus (int)}, "-") ] #>
   13.58 +  Old_SMT_Builtin.add_builtin_fun smtlibC
   13.59 +    (Term.dest_Const @{const times (int)}, times)
   13.60 +
   13.61 +end
   13.62 +
   13.63 +
   13.64 +(* serialization *)
   13.65 +
   13.66 +(** header **)
   13.67 +
   13.68 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
   13.69 +
   13.70 +structure Logics = Generic_Data
   13.71 +(
   13.72 +  type T = (int * (term list -> string option)) list
   13.73 +  val empty = []
   13.74 +  val extend = I
   13.75 +  fun merge data = Ord_List.merge fst_int_ord data
   13.76 +)
   13.77 +
   13.78 +fun add_logic pf = Logics.map (Ord_List.insert fst_int_ord pf)
   13.79 +
   13.80 +fun choose_logic ctxt ts =
   13.81 +  let
   13.82 +    fun choose [] = "AUFLIA"
   13.83 +      | choose ((_, f) :: fs) = (case f ts of SOME s => s | NONE => choose fs)
   13.84 +  in [":logic " ^ choose (Logics.get (Context.Proof ctxt))] end
   13.85 +
   13.86 +
   13.87 +(** serialization **)
   13.88 +
   13.89 +val add = Buffer.add
   13.90 +fun sep f = add " " #> f
   13.91 +fun enclose l r f = sep (add l #> f #> add r)
   13.92 +val par = enclose "(" ")"
   13.93 +fun app n f = (fn [] => sep (add n) | xs => par (add n #> fold f xs))
   13.94 +fun line f = f #> add "\n"
   13.95 +
   13.96 +fun var i = add "?v" #> add (string_of_int i)
   13.97 +
   13.98 +fun sterm l (Old_SMT_Translate.SVar i) = sep (var (l - i - 1))
   13.99 +  | sterm l (Old_SMT_Translate.SApp (n, ts)) = app n (sterm l) ts
  13.100 +  | sterm _ (Old_SMT_Translate.SLet _) =
  13.101 +      raise Fail "SMT-LIB: unsupported let expression"
  13.102 +  | sterm l (Old_SMT_Translate.SQua (q, ss, ps, w, t)) =
  13.103 +      let
  13.104 +        fun quant Old_SMT_Translate.SForall = add "forall"
  13.105 +          | quant Old_SMT_Translate.SExists = add "exists"
  13.106 +        val vs = map_index (apfst (Integer.add l)) ss
  13.107 +        fun var_decl (i, s) = par (var i #> sep (add s))
  13.108 +        val sub = sterm (l + length ss)
  13.109 +        fun pat kind ts = sep (add kind #> enclose "{" " }" (fold sub ts))
  13.110 +        fun pats (Old_SMT_Translate.SPat ts) = pat ":pat" ts
  13.111 +          | pats (Old_SMT_Translate.SNoPat ts) = pat ":nopat" ts
  13.112 +        fun weight NONE = I
  13.113 +          | weight (SOME i) =
  13.114 +              sep (add ":weight { " #> add (string_of_int i) #> add " }")
  13.115 +      in
  13.116 +        par (quant q #> fold var_decl vs #> sub t #> fold pats ps #> weight w)
  13.117 +      end
  13.118 +
  13.119 +fun ssort sorts = sort fast_string_ord sorts
  13.120 +fun fsort funcs = sort (prod_ord fast_string_ord (K EQUAL)) funcs
  13.121 +
  13.122 +fun sdatatypes decls =
  13.123 +  let
  13.124 +    fun con (n, []) = sep (add n)
  13.125 +      | con (n, sels) = par (add n #>
  13.126 +          fold (fn (n, s) => par (add n #> sep (add s))) sels)
  13.127 +    fun dtyp (n, decl) = add n #> fold con decl
  13.128 +  in line (add ":datatypes " #> par (fold (par o dtyp) decls)) end
  13.129 +
  13.130 +fun serialize comments {header, sorts, dtyps, funcs} ts =
  13.131 +  Buffer.empty
  13.132 +  |> line (add "(benchmark Isabelle")
  13.133 +  |> line (add ":status unknown")
  13.134 +  |> fold (line o add) header
  13.135 +  |> length sorts > 0 ?
  13.136 +       line (add ":extrasorts" #> par (fold (sep o add) (ssort sorts)))
  13.137 +  |> fold sdatatypes dtyps
  13.138 +  |> length funcs > 0 ? (
  13.139 +       line (add ":extrafuns" #> add " (") #>
  13.140 +       fold (fn (f, (ss, s)) =>
  13.141 +         line (sep (app f (sep o add) (ss @ [s])))) (fsort funcs) #>
  13.142 +       line (add ")"))
  13.143 +  |> fold (fn t => line (add ":assumption" #> sterm 0 t)) ts
  13.144 +  |> line (add ":formula true)")
  13.145 +  |> fold (fn str => line (add "; " #> add str)) comments
  13.146 +  |> Buffer.content
  13.147 +
  13.148 +
  13.149 +(* interface *)
  13.150 +
  13.151 +fun translate_config ctxt = {
  13.152 +  prefixes = {
  13.153 +    sort_prefix = "S",
  13.154 +    func_prefix = "f"},
  13.155 +  header = choose_logic ctxt,
  13.156 +  is_fol = true,
  13.157 +  has_datatypes = false,
  13.158 +  serialize = serialize}
  13.159 +
  13.160 +val setup = Context.theory_map (
  13.161 +  setup_builtins #>
  13.162 +  Old_SMT_Translate.add_config (smtlibC, translate_config))
  13.163 +
  13.164 +end
    14.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.2 +++ b/src/HOL/Library/Old_SMT/old_z3_interface.ML	Thu Aug 28 00:40:38 2014 +0200
    14.3 @@ -0,0 +1,239 @@
    14.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_interface.ML
    14.5 +    Author:     Sascha Boehme, TU Muenchen
    14.6 +
    14.7 +Interface to Z3 based on a relaxed version of SMT-LIB.
    14.8 +*)
    14.9 +
   14.10 +signature OLD_Z3_INTERFACE =
   14.11 +sig
   14.12 +  val smtlib_z3C: Old_SMT_Utils.class
   14.13 +  val setup: theory -> theory
   14.14 +
   14.15 +  datatype sym = Sym of string * sym list
   14.16 +  type mk_builtins = {
   14.17 +    mk_builtin_typ: sym -> typ option,
   14.18 +    mk_builtin_num: theory -> int -> typ -> cterm option,
   14.19 +    mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
   14.20 +  val add_mk_builtins: mk_builtins -> Context.generic -> Context.generic
   14.21 +  val mk_builtin_typ: Proof.context -> sym -> typ option
   14.22 +  val mk_builtin_num: Proof.context -> int -> typ -> cterm option
   14.23 +  val mk_builtin_fun: Proof.context -> sym -> cterm list -> cterm option
   14.24 +
   14.25 +  val is_builtin_theory_term: Proof.context -> term -> bool
   14.26 +end
   14.27 +
   14.28 +structure Old_Z3_Interface: OLD_Z3_INTERFACE =
   14.29 +struct
   14.30 +
   14.31 +val smtlib_z3C = Old_SMTLIB_Interface.smtlibC @ ["z3"]
   14.32 +
   14.33 +
   14.34 +
   14.35 +(* interface *)
   14.36 +
   14.37 +local
   14.38 +  fun translate_config ctxt =
   14.39 +    let
   14.40 +      val {prefixes, header, is_fol, serialize, ...} =
   14.41 +        Old_SMTLIB_Interface.translate_config ctxt
   14.42 +    in
   14.43 +      {prefixes=prefixes, header=header, is_fol=is_fol, serialize=serialize,
   14.44 +        has_datatypes=true}
   14.45 +    end
   14.46 +
   14.47 +  fun is_div_mod @{const div (int)} = true
   14.48 +    | is_div_mod @{const mod (int)} = true
   14.49 +    | is_div_mod _ = false
   14.50 +
   14.51 +  val div_by_z3div = @{lemma
   14.52 +    "ALL k l. k div l = (
   14.53 +      if k = 0 | l = 0 then 0
   14.54 +      else if (0 < k & 0 < l) | (k < 0 & 0 < l) then z3div k l
   14.55 +      else z3div (-k) (-l))"
   14.56 +    by (simp add: z3div_def)}
   14.57 +
   14.58 +  val mod_by_z3mod = @{lemma
   14.59 +    "ALL k l. k mod l = (
   14.60 +      if l = 0 then k
   14.61 +      else if k = 0 then 0
   14.62 +      else if (0 < k & 0 < l) | (k < 0 & 0 < l) then z3mod k l
   14.63 +      else - z3mod (-k) (-l))"
   14.64 +    by (simp add: z3mod_def)}
   14.65 +
   14.66 +  val have_int_div_mod =
   14.67 +    exists (Term.exists_subterm is_div_mod o Thm.prop_of)
   14.68 +
   14.69 +  fun add_div_mod _ (thms, extra_thms) =
   14.70 +    if have_int_div_mod thms orelse have_int_div_mod extra_thms then
   14.71 +      (thms, div_by_z3div :: mod_by_z3mod :: extra_thms)
   14.72 +    else (thms, extra_thms)
   14.73 +
   14.74 +  val setup_builtins =
   14.75 +    Old_SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const times (int)}, "*") #>
   14.76 +    Old_SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const z3div}, "div") #>
   14.77 +    Old_SMT_Builtin.add_builtin_fun' smtlib_z3C (@{const z3mod}, "mod")
   14.78 +in
   14.79 +
   14.80 +val setup = Context.theory_map (
   14.81 +  setup_builtins #>
   14.82 +  Old_SMT_Normalize.add_extra_norm (smtlib_z3C, add_div_mod) #>
   14.83 +  Old_SMT_Translate.add_config (smtlib_z3C, translate_config))
   14.84 +
   14.85 +end
   14.86 +
   14.87 +
   14.88 +
   14.89 +(* constructors *)
   14.90 +
   14.91 +datatype sym = Sym of string * sym list
   14.92 +
   14.93 +
   14.94 +(** additional constructors **)
   14.95 +
   14.96 +type mk_builtins = {
   14.97 +  mk_builtin_typ: sym -> typ option,
   14.98 +  mk_builtin_num: theory -> int -> typ -> cterm option,
   14.99 +  mk_builtin_fun: theory -> sym -> cterm list -> cterm option }
  14.100 +
  14.101 +fun chained _ [] = NONE
  14.102 +  | chained f (b :: bs) = (case f b of SOME y => SOME y | NONE => chained f bs)
  14.103 +
  14.104 +fun chained_mk_builtin_typ bs sym =
  14.105 +  chained (fn {mk_builtin_typ=mk, ...} : mk_builtins => mk sym) bs
  14.106 +
  14.107 +fun chained_mk_builtin_num ctxt bs i T =
  14.108 +  let val thy = Proof_Context.theory_of ctxt
  14.109 +  in chained (fn {mk_builtin_num=mk, ...} : mk_builtins => mk thy i T) bs end
  14.110 +
  14.111 +fun chained_mk_builtin_fun ctxt bs s cts =
  14.112 +  let val thy = Proof_Context.theory_of ctxt
  14.113 +  in chained (fn {mk_builtin_fun=mk, ...} : mk_builtins => mk thy s cts) bs end
  14.114 +
  14.115 +fun fst_int_ord ((i1, _), (i2, _)) = int_ord (i1, i2)
  14.116 +
  14.117 +structure Mk_Builtins = Generic_Data
  14.118 +(
  14.119 +  type T = (int * mk_builtins) list
  14.120 +  val empty = []
  14.121 +  val extend = I
  14.122 +  fun merge data = Ord_List.merge fst_int_ord data
  14.123 +)
  14.124 +
  14.125 +fun add_mk_builtins mk =
  14.126 +  Mk_Builtins.map (Ord_List.insert fst_int_ord (serial (), mk))
  14.127 +
  14.128 +fun get_mk_builtins ctxt = map snd (Mk_Builtins.get (Context.Proof ctxt))
  14.129 +
  14.130 +
  14.131 +(** basic and additional constructors **)
  14.132 +
  14.133 +fun mk_builtin_typ _ (Sym ("Bool", _)) = SOME @{typ bool}
  14.134 +  | mk_builtin_typ _ (Sym ("Int", _)) = SOME @{typ int}
  14.135 +  | mk_builtin_typ _ (Sym ("bool", _)) = SOME @{typ bool}  (*FIXME: legacy*)
  14.136 +  | mk_builtin_typ _ (Sym ("int", _)) = SOME @{typ int}  (*FIXME: legacy*)
  14.137 +  | mk_builtin_typ ctxt sym = chained_mk_builtin_typ (get_mk_builtins ctxt) sym
  14.138 +
  14.139 +fun mk_builtin_num _ i @{typ int} = SOME (Numeral.mk_cnumber @{ctyp int} i)
  14.140 +  | mk_builtin_num ctxt i T =
  14.141 +      chained_mk_builtin_num ctxt (get_mk_builtins ctxt) i T
  14.142 +
  14.143 +val mk_true = Thm.cterm_of @{theory} (@{const Not} $ @{const False})
  14.144 +val mk_false = Thm.cterm_of @{theory} @{const False}
  14.145 +val mk_not = Thm.apply (Thm.cterm_of @{theory} @{const Not})
  14.146 +val mk_implies = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.implies})
  14.147 +val mk_iff = Thm.mk_binop (Thm.cterm_of @{theory} @{const HOL.eq (bool)})
  14.148 +val conj = Thm.cterm_of @{theory} @{const HOL.conj}
  14.149 +val disj = Thm.cterm_of @{theory} @{const HOL.disj}
  14.150 +
  14.151 +fun mk_nary _ cu [] = cu
  14.152 +  | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
  14.153 +
  14.154 +val eq = Old_SMT_Utils.mk_const_pat @{theory} @{const_name HOL.eq} Old_SMT_Utils.destT1
  14.155 +fun mk_eq ct cu = Thm.mk_binop (Old_SMT_Utils.instT' ct eq) ct cu
  14.156 +
  14.157 +val if_term =
  14.158 +  Old_SMT_Utils.mk_const_pat @{theory} @{const_name If}
  14.159 +    (Old_SMT_Utils.destT1 o Old_SMT_Utils.destT2)
  14.160 +fun mk_if cc ct cu =
  14.161 +  Thm.mk_binop (Thm.apply (Old_SMT_Utils.instT' ct if_term) cc) ct cu
  14.162 +
  14.163 +val nil_term =
  14.164 +  Old_SMT_Utils.mk_const_pat @{theory} @{const_name Nil} Old_SMT_Utils.destT1
  14.165 +val cons_term =
  14.166 +  Old_SMT_Utils.mk_const_pat @{theory} @{const_name Cons} Old_SMT_Utils.destT1
  14.167 +fun mk_list cT cts =
  14.168 +  fold_rev (Thm.mk_binop (Old_SMT_Utils.instT cT cons_term)) cts
  14.169 +    (Old_SMT_Utils.instT cT nil_term)
  14.170 +
  14.171 +val distinct = Old_SMT_Utils.mk_const_pat @{theory} @{const_name distinct}
  14.172 +  (Old_SMT_Utils.destT1 o Old_SMT_Utils.destT1)
  14.173 +fun mk_distinct [] = mk_true
  14.174 +  | mk_distinct (cts as (ct :: _)) =
  14.175 +      Thm.apply (Old_SMT_Utils.instT' ct distinct)
  14.176 +        (mk_list (Thm.ctyp_of_term ct) cts)
  14.177 +
  14.178 +val access =
  14.179 +  Old_SMT_Utils.mk_const_pat @{theory} @{const_name fun_app} Old_SMT_Utils.destT1
  14.180 +fun mk_access array = Thm.apply (Old_SMT_Utils.instT' array access) array
  14.181 +
  14.182 +val update = Old_SMT_Utils.mk_const_pat @{theory} @{const_name fun_upd}
  14.183 +  (Thm.dest_ctyp o Old_SMT_Utils.destT1)
  14.184 +fun mk_update array index value =
  14.185 +  let val cTs = Thm.dest_ctyp (Thm.ctyp_of_term array)
  14.186 +  in
  14.187 +    Thm.apply (Thm.mk_binop (Old_SMT_Utils.instTs cTs update) array index) value
  14.188 +  end
  14.189 +
  14.190 +val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (int)})
  14.191 +val add = Thm.cterm_of @{theory} @{const plus (int)}
  14.192 +val int0 = Numeral.mk_cnumber @{ctyp int} 0
  14.193 +val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (int)})
  14.194 +val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (int)})
  14.195 +val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3div})
  14.196 +val mk_mod = Thm.mk_binop (Thm.cterm_of @{theory} @{const z3mod})
  14.197 +val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (int)})
  14.198 +val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (int)})
  14.199 +
  14.200 +fun mk_builtin_fun ctxt sym cts =
  14.201 +  (case (sym, cts) of
  14.202 +    (Sym ("true", _), []) => SOME mk_true
  14.203 +  | (Sym ("false", _), []) => SOME mk_false
  14.204 +  | (Sym ("not", _), [ct]) => SOME (mk_not ct)
  14.205 +  | (Sym ("and", _), _) => SOME (mk_nary conj mk_true cts)
  14.206 +  | (Sym ("or", _), _) => SOME (mk_nary disj mk_false cts)
  14.207 +  | (Sym ("implies", _), [ct, cu]) => SOME (mk_implies ct cu)
  14.208 +  | (Sym ("iff", _), [ct, cu]) => SOME (mk_iff ct cu)
  14.209 +  | (Sym ("~", _), [ct, cu]) => SOME (mk_iff ct cu)
  14.210 +  | (Sym ("xor", _), [ct, cu]) => SOME (mk_not (mk_iff ct cu))
  14.211 +  | (Sym ("if", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3)
  14.212 +  | (Sym ("ite", _), [ct1, ct2, ct3]) => SOME (mk_if ct1 ct2 ct3) (* FIXME: remove *)
  14.213 +  | (Sym ("=", _), [ct, cu]) => SOME (mk_eq ct cu)
  14.214 +  | (Sym ("distinct", _), _) => SOME (mk_distinct cts)
  14.215 +  | (Sym ("select", _), [ca, ck]) => SOME (Thm.apply (mk_access ca) ck)
  14.216 +  | (Sym ("store", _), [ca, ck, cv]) => SOME (mk_update ca ck cv)
  14.217 +  | _ =>
  14.218 +    (case (sym, try (#T o Thm.rep_cterm o hd) cts, cts) of
  14.219 +      (Sym ("+", _), SOME @{typ int}, _) => SOME (mk_nary add int0 cts)
  14.220 +    | (Sym ("-", _), SOME @{typ int}, [ct]) => SOME (mk_uminus ct)
  14.221 +    | (Sym ("-", _), SOME @{typ int}, [ct, cu]) => SOME (mk_sub ct cu)
  14.222 +    | (Sym ("*", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mul ct cu)
  14.223 +    | (Sym ("div", _), SOME @{typ int}, [ct, cu]) => SOME (mk_div ct cu)
  14.224 +    | (Sym ("mod", _), SOME @{typ int}, [ct, cu]) => SOME (mk_mod ct cu)
  14.225 +    | (Sym ("<", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt ct cu)
  14.226 +    | (Sym ("<=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le ct cu)
  14.227 +    | (Sym (">", _), SOME @{typ int}, [ct, cu]) => SOME (mk_lt cu ct)
  14.228 +    | (Sym (">=", _), SOME @{typ int}, [ct, cu]) => SOME (mk_le cu ct)
  14.229 +    | _ => chained_mk_builtin_fun ctxt (get_mk_builtins ctxt) sym cts))
  14.230 +
  14.231 +
  14.232 +
  14.233 +(* abstraction *)
  14.234 +
  14.235 +fun is_builtin_theory_term ctxt t =
  14.236 +  if Old_SMT_Builtin.is_builtin_num ctxt t then true
  14.237 +  else
  14.238 +    (case Term.strip_comb t of
  14.239 +      (Const c, ts) => Old_SMT_Builtin.is_builtin_fun ctxt c ts
  14.240 +    | _ => false)
  14.241 +
  14.242 +end
    15.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.2 +++ b/src/HOL/Library/Old_SMT/old_z3_model.ML	Thu Aug 28 00:40:38 2014 +0200
    15.3 @@ -0,0 +1,337 @@
    15.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_model.ML
    15.5 +    Author:     Sascha Boehme and Philipp Meyer, TU Muenchen
    15.6 +
    15.7 +Parser for counterexamples generated by Z3.
    15.8 +*)
    15.9 +
   15.10 +signature OLD_Z3_MODEL =
   15.11 +sig
   15.12 +  val parse_counterex: Proof.context -> Old_SMT_Translate.recon -> string list ->
   15.13 +    term list * term list
   15.14 +end
   15.15 +
   15.16 +structure Old_Z3_Model: OLD_Z3_MODEL =
   15.17 +struct
   15.18 +
   15.19 +
   15.20 +(* counterexample expressions *)
   15.21 +
   15.22 +datatype expr = True | False | Number of int * int option | Value of int |
   15.23 +  Array of array | App of string * expr list
   15.24 +and array = Fresh of expr | Store of (array * expr) * expr
   15.25 +
   15.26 +
   15.27 +(* parsing *)
   15.28 +
   15.29 +val space = Scan.many Symbol.is_ascii_blank
   15.30 +fun spaced p = p --| space
   15.31 +fun in_parens p = spaced (Scan.$$ "(") |-- p --| spaced (Scan.$$ ")")
   15.32 +fun in_braces p = spaced (Scan.$$ "{") |-- p --| spaced (Scan.$$ "}")
   15.33 +
   15.34 +val digit = (fn
   15.35 +  "0" => SOME 0 | "1" => SOME 1 | "2" => SOME 2 | "3" => SOME 3 |
   15.36 +  "4" => SOME 4 | "5" => SOME 5 | "6" => SOME 6 | "7" => SOME 7 |
   15.37 +  "8" => SOME 8 | "9" => SOME 9 | _ => NONE)
   15.38 +
   15.39 +val nat_num = spaced (Scan.repeat1 (Scan.some digit) >>
   15.40 +  (fn ds => fold (fn d => fn i => i * 10 + d) ds 0))
   15.41 +val int_num = spaced (Scan.optional ($$ "-" >> K (fn i => ~i)) I :|--
   15.42 +  (fn sign => nat_num >> sign))
   15.43 +
   15.44 +val is_char = Symbol.is_ascii_letter orf Symbol.is_ascii_digit orf
   15.45 +  member (op =) (raw_explode "_+*-/%~=<>$&|?!.@^#")
   15.46 +val name = spaced (Scan.many1 is_char >> implode)
   15.47 +
   15.48 +fun $$$ s = spaced (Scan.this_string s)
   15.49 +
   15.50 +fun array_expr st = st |> in_parens (
   15.51 +  $$$ "const" |-- expr >> Fresh ||
   15.52 +  $$$ "store" |-- array_expr -- expr -- expr >> Store)
   15.53 +
   15.54 +and expr st = st |> (
   15.55 +  $$$ "true" >> K True ||
   15.56 +  $$$ "false" >> K False ||
   15.57 +  int_num -- Scan.option ($$$ "/" |-- int_num) >> Number ||
   15.58 +  $$$ "val!" |-- nat_num >> Value ||
   15.59 +  name >> (App o rpair []) ||
   15.60 +  array_expr >> Array ||
   15.61 +  in_parens (name -- Scan.repeat1 expr) >> App)
   15.62 +
   15.63 +fun args st = ($$$ "->" >> K [] || expr ::: args) st
   15.64 +val args_case = args -- expr
   15.65 +val else_case = $$$ "else" -- $$$ "->" |-- expr >> pair ([] : expr list)
   15.66 +
   15.67 +val func =
   15.68 +  let fun cases st = (else_case >> single || args_case ::: cases) st
   15.69 +  in in_braces cases end
   15.70 +
   15.71 +val cex = space |--
   15.72 +  Scan.repeat (name --| $$$ "->" -- (func || expr >> (single o pair [])))
   15.73 +
   15.74 +fun resolve terms ((n, k), cases) =
   15.75 +  (case Symtab.lookup terms n of
   15.76 +    NONE => NONE
   15.77 +  | SOME t => SOME ((t, k), cases))
   15.78 +
   15.79 +fun annotate _ (_, []) = NONE
   15.80 +  | annotate terms (n, [([], c)]) = resolve terms ((n, 0), (c, []))
   15.81 +  | annotate _ (_, [_]) = NONE
   15.82 +  | annotate terms (n, cases as (args, _) :: _) =
   15.83 +      let val (cases', (_, else_case)) = split_last cases
   15.84 +      in resolve terms ((n, length args), (else_case, cases')) end
   15.85 +
   15.86 +fun read_cex terms ls =
   15.87 +  maps (cons "\n" o raw_explode) ls
   15.88 +  |> try (fst o Scan.finite Symbol.stopper cex)
   15.89 +  |> the_default []
   15.90 +  |> map_filter (annotate terms)
   15.91 +
   15.92 +
   15.93 +(* translation into terms *)
   15.94 +
   15.95 +fun max_value vs =
   15.96 +  let
   15.97 +    fun max_val_expr (Value i) = Integer.max i
   15.98 +      | max_val_expr (App (_, es)) = fold max_val_expr es
   15.99 +      | max_val_expr (Array a) = max_val_array a
  15.100 +      | max_val_expr _ = I
  15.101 +
  15.102 +    and max_val_array (Fresh e) = max_val_expr e
  15.103 +      | max_val_array (Store ((a, e1), e2)) =
  15.104 +          max_val_array a #> max_val_expr e1 #> max_val_expr e2
  15.105 +
  15.106 +    fun max_val (_, (ec, cs)) =
  15.107 +      max_val_expr ec #> fold (fn (es, e) => fold max_val_expr (e :: es)) cs
  15.108 +
  15.109 +  in fold max_val vs ~1 end
  15.110 +
  15.111 +fun with_context terms f vs = fst (fold_map f vs (terms, max_value vs + 1))
  15.112 +
  15.113 +fun get_term n T es (cx as (terms, next_val)) =
  15.114 +  (case Symtab.lookup terms n of
  15.115 +    SOME t => ((t, es), cx)
  15.116 +  | NONE =>
  15.117 +      let val t = Var (("skolem", next_val), T)
  15.118 +      in ((t, []), (Symtab.update (n, t) terms, next_val + 1)) end)
  15.119 +
  15.120 +fun trans_expr _ True = pair @{const True}
  15.121 +  | trans_expr _ False = pair @{const False}
  15.122 +  | trans_expr T (Number (i, NONE)) = pair (HOLogic.mk_number T i)
  15.123 +  | trans_expr T (Number (i, SOME j)) =
  15.124 +      pair (Const (@{const_name divide}, [T, T] ---> T) $
  15.125 +        HOLogic.mk_number T i $ HOLogic.mk_number T j)
  15.126 +  | trans_expr T (Value i) = pair (Var (("value", i), T))
  15.127 +  | trans_expr T (Array a) = trans_array T a
  15.128 +  | trans_expr T (App (n, es)) = get_term n T es #-> (fn (t, es') =>
  15.129 +      let val Ts = fst (Old_SMT_Utils.dest_funT (length es') (Term.fastype_of t))
  15.130 +      in
  15.131 +        fold_map (uncurry trans_expr) (Ts ~~ es') #>> Term.list_comb o pair t
  15.132 +      end)
  15.133 +
  15.134 +and trans_array T a =
  15.135 +  let val (dT, rT) = Term.dest_funT T
  15.136 +  in
  15.137 +    (case a of
  15.138 +      Fresh e => trans_expr rT e #>> (fn t => Abs ("x", dT, t))
  15.139 +    | Store ((a', e1), e2) =>
  15.140 +        trans_array T a' ##>> trans_expr dT e1 ##>> trans_expr rT e2 #>>
  15.141 +        (fn ((m, k), v) =>
  15.142 +          Const (@{const_name fun_upd}, [T, dT, rT] ---> T) $ m $ k $ v))
  15.143 +  end
  15.144 +
  15.145 +fun trans_pattern T ([], e) = trans_expr T e #>> pair []
  15.146 +  | trans_pattern T (arg :: args, e) =
  15.147 +      trans_expr (Term.domain_type T) arg ##>>
  15.148 +      trans_pattern (Term.range_type T) (args, e) #>>
  15.149 +      (fn (arg', (args', e')) => (arg' :: args', e'))
  15.150 +
  15.151 +fun mk_fun_upd T U = Const (@{const_name fun_upd}, [T --> U, T, U, T] ---> U)
  15.152 +
  15.153 +fun mk_update ([], u) _ = u
  15.154 +  | mk_update ([t], u) f =
  15.155 +      uncurry mk_fun_upd (Term.dest_funT (Term.fastype_of f)) $ f $ t $ u
  15.156 +  | mk_update (t :: ts, u) f =
  15.157 +      let
  15.158 +        val (dT, rT) = Term.dest_funT (Term.fastype_of f)
  15.159 +        val (dT', rT') = Term.dest_funT rT
  15.160 +      in
  15.161 +        mk_fun_upd dT rT $ f $ t $
  15.162 +          mk_update (ts, u) (absdummy dT' (Const ("_", rT')))
  15.163 +      end
  15.164 +
  15.165 +fun mk_lambda Ts (t, pats) =
  15.166 +  fold_rev absdummy Ts t |> fold mk_update pats
  15.167 +
  15.168 +fun translate ((t, k), (e, cs)) =
  15.169 +  let
  15.170 +    val T = Term.fastype_of t
  15.171 +    val (Us, U) = Old_SMT_Utils.dest_funT k (Term.fastype_of t)
  15.172 +
  15.173 +    fun mk_full_def u' pats =
  15.174 +      pats
  15.175 +      |> filter_out (fn (_, u) => u aconv u')
  15.176 +      |> HOLogic.mk_eq o pair t o mk_lambda Us o pair u'
  15.177 +
  15.178 +    fun mk_eq (us, u) = HOLogic.mk_eq (Term.list_comb (t, us), u)
  15.179 +    fun mk_eqs u' [] = [HOLogic.mk_eq (t, u')]
  15.180 +      | mk_eqs _ pats = map mk_eq pats
  15.181 +  in
  15.182 +    trans_expr U e ##>>
  15.183 +    (if k = 0 then pair [] else fold_map (trans_pattern T) cs) #>>
  15.184 +    (fn (u', pats) => (mk_eqs u' pats, mk_full_def u' pats))
  15.185 +  end
  15.186 +
  15.187 +
  15.188 +(* normalization *)
  15.189 +
  15.190 +fun partition_eqs f =
  15.191 +  let
  15.192 +    fun part t (xs, ts) =
  15.193 +      (case try HOLogic.dest_eq t of
  15.194 +        SOME (l, r) => (case f l r of SOME x => (x::xs, ts) | _ => (xs, t::ts))
  15.195 +      | NONE => (xs, t :: ts))
  15.196 +  in (fn ts => fold part ts ([], [])) end
  15.197 +
  15.198 +fun first_eq pred =
  15.199 +  let
  15.200 +    fun part _ [] = NONE
  15.201 +      | part us (t :: ts) =
  15.202 +          (case try (pred o HOLogic.dest_eq) t of
  15.203 +            SOME (SOME lr) => SOME (lr, fold cons us ts)
  15.204 +          | _ => part (t :: us) ts)
  15.205 +  in (fn ts => part [] ts) end
  15.206 +
  15.207 +fun replace_vars tab =
  15.208 +  let
  15.209 +    fun repl v = the_default v (AList.lookup (op aconv) tab v)
  15.210 +    fun replace (v as Var _) = repl v
  15.211 +      | replace (v as Free _) = repl v
  15.212 +      | replace t = t
  15.213 +  in map (Term.map_aterms replace) end
  15.214 +
  15.215 +fun remove_int_nat_coercions (eqs, defs) =
  15.216 +  let
  15.217 +    fun mk_nat_num t i =
  15.218 +      (case try HOLogic.dest_number i of
  15.219 +        SOME (_, n) => SOME (t, HOLogic.mk_number @{typ nat} n)
  15.220 +      | NONE => NONE)
  15.221 +    fun nat_of (@{const of_nat (int)} $ (t as Var _)) i = mk_nat_num t i
  15.222 +      | nat_of (@{const nat} $ i) (t as Var _) = mk_nat_num t i
  15.223 +      | nat_of _ _ = NONE
  15.224 +    val (nats, eqs') = partition_eqs nat_of eqs
  15.225 +
  15.226 +    fun is_coercion t =
  15.227 +      (case try HOLogic.dest_eq t of
  15.228 +        SOME (@{const of_nat (int)}, _) => true
  15.229 +      | SOME (@{const nat}, _) => true
  15.230 +      | _ => false)
  15.231 +  in pairself (replace_vars nats) (eqs', filter_out is_coercion defs) end
  15.232 +
  15.233 +fun unfold_funapp (eqs, defs) =
  15.234 +  let
  15.235 +    fun unfold_app (Const (@{const_name fun_app}, _) $ f $ t) = f $ t
  15.236 +      | unfold_app t = t
  15.237 +    fun unfold_eq ((eq as Const (@{const_name HOL.eq}, _)) $ t $ u) =
  15.238 +          eq $ unfold_app t $ u
  15.239 +      | unfold_eq t = t
  15.240 +
  15.241 +    fun is_fun_app t =
  15.242 +      (case try HOLogic.dest_eq t of
  15.243 +        SOME (Const (@{const_name fun_app}, _), _) => true
  15.244 +      | _ => false)
  15.245 +
  15.246 +  in (map unfold_eq eqs, filter_out is_fun_app defs) end
  15.247 +
  15.248 +val unfold_eqs =
  15.249 +  let
  15.250 +    val is_ground = not o Term.exists_subterm Term.is_Var
  15.251 +    fun is_non_rec (v, t) = not (Term.exists_subterm (equal v) t)
  15.252 +
  15.253 +    fun rewr_var (l as Var _, r) = if is_ground r then SOME (l, r) else NONE
  15.254 +      | rewr_var (r, l as Var _) = if is_ground r then SOME (l, r) else NONE
  15.255 +      | rewr_var _ = NONE
  15.256 +
  15.257 +    fun rewr_free' e = if is_non_rec e then SOME e else NONE
  15.258 +    fun rewr_free (e as (Free _, _)) = rewr_free' e
  15.259 +      | rewr_free (e as (_, Free _)) = rewr_free' (swap e)
  15.260 +      | rewr_free _ = NONE
  15.261 +
  15.262 +    fun is_trivial (Const (@{const_name HOL.eq}, _) $ t $ u) = t aconv u
  15.263 +      | is_trivial _ = false
  15.264 +
  15.265 +    fun replace r = replace_vars [r] #> filter_out is_trivial
  15.266 +
  15.267 +    fun unfold_vars (es, ds) =
  15.268 +      (case first_eq rewr_var es of
  15.269 +        SOME (lr, es') => unfold_vars (pairself (replace lr) (es', ds))
  15.270 +      | NONE => (es, ds))
  15.271 +
  15.272 +    fun unfold_frees ues (es, ds) =
  15.273 +      (case first_eq rewr_free es of
  15.274 +        SOME (lr, es') =>
  15.275 +          pairself (replace lr) (es', ds)
  15.276 +          |> unfold_frees (HOLogic.mk_eq lr :: replace lr ues)
  15.277 +      | NONE => (ues @ es, ds))
  15.278 +
  15.279 +  in unfold_vars #> unfold_frees [] end
  15.280 +
  15.281 +fun swap_free ((eq as Const (@{const_name HOL.eq}, _)) $ t $ (u as Free _)) =
  15.282 +      eq $ u $ t
  15.283 +  | swap_free t = t
  15.284 +
  15.285 +fun frees_for_vars ctxt (eqs, defs) =
  15.286 +  let
  15.287 +    fun fresh_free i T (cx as (frees, ctxt)) =
  15.288 +      (case Inttab.lookup frees i of
  15.289 +        SOME t => (t, cx)
  15.290 +      | NONE =>
  15.291 +          let
  15.292 +            val (n, ctxt') = yield_singleton Variable.variant_fixes "" ctxt
  15.293 +            val t = Free (n, T)
  15.294 +          in (t, (Inttab.update (i, t) frees, ctxt')) end)
  15.295 +
  15.296 +    fun repl_var (Var ((_, i), T)) = fresh_free i T
  15.297 +      | repl_var (t $ u) = repl_var t ##>> repl_var u #>> op $
  15.298 +      | repl_var (Abs (n, T, t)) = repl_var t #>> (fn t' => Abs (n, T, t'))
  15.299 +      | repl_var t = pair t
  15.300 +  in
  15.301 +    (Inttab.empty, ctxt)
  15.302 +    |> fold_map repl_var eqs
  15.303 +    ||>> fold_map repl_var defs
  15.304 +    |> fst
  15.305 +  end
  15.306 +
  15.307 +
  15.308 +(* overall procedure *)
  15.309 +
  15.310 +val is_free_constraint = Term.exists_subterm (fn Free _ => true | _ => false)
  15.311 +
  15.312 +fun is_free_def (Const (@{const_name HOL.eq}, _) $ Free _ $ _) = true
  15.313 +  | is_free_def _ = false
  15.314 +
  15.315 +fun defined tp =
  15.316 +  try (pairself (fst o HOLogic.dest_eq)) tp
  15.317 +  |> the_default false o Option.map (op aconv)
  15.318 +
  15.319 +fun add_free_defs free_cs defs =
  15.320 +  let val (free_defs, defs') = List.partition is_free_def defs
  15.321 +  in (free_cs @ filter_out (member defined free_cs) free_defs, defs') end
  15.322 +
  15.323 +fun is_const_def (Const (@{const_name HOL.eq}, _) $ Const _ $ _) = true
  15.324 +  | is_const_def _ = false
  15.325 +
  15.326 +fun parse_counterex ctxt ({terms, ...} : Old_SMT_Translate.recon) ls =
  15.327 +  read_cex terms ls
  15.328 +  |> with_context terms translate
  15.329 +  |> apfst flat o split_list
  15.330 +  |> remove_int_nat_coercions
  15.331 +  |> unfold_funapp
  15.332 +  |> unfold_eqs
  15.333 +  |>> map swap_free
  15.334 +  |>> filter is_free_constraint
  15.335 +  |-> add_free_defs
  15.336 +  |> frees_for_vars ctxt
  15.337 +  ||> filter is_const_def
  15.338 +
  15.339 +end
  15.340 +
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_literals.ML	Thu Aug 28 00:40:38 2014 +0200
    16.3 @@ -0,0 +1,361 @@
    16.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_proof_literals.ML
    16.5 +    Author:     Sascha Boehme, TU Muenchen
    16.6 +
    16.7 +Proof tools related to conjunctions and disjunctions.
    16.8 +*)
    16.9 +
   16.10 +signature OLD_Z3_PROOF_LITERALS =
   16.11 +sig
   16.12 +  (*literal table*)
   16.13 +  type littab = thm Termtab.table
   16.14 +  val make_littab: thm list -> littab
   16.15 +  val insert_lit: thm -> littab -> littab
   16.16 +  val delete_lit: thm -> littab -> littab
   16.17 +  val lookup_lit: littab -> term -> thm option
   16.18 +  val get_first_lit: (term -> bool) -> littab -> thm option
   16.19 +
   16.20 +  (*rules*)
   16.21 +  val true_thm: thm
   16.22 +  val rewrite_true: thm
   16.23 +
   16.24 +  (*properties*)
   16.25 +  val is_conj: term -> bool
   16.26 +  val is_disj: term -> bool
   16.27 +  val exists_lit: bool -> (term -> bool) -> term -> bool
   16.28 +  val negate: cterm -> cterm
   16.29 +
   16.30 +  (*proof tools*)
   16.31 +  val explode: bool -> bool -> bool -> term list -> thm -> thm list
   16.32 +  val join: bool -> littab -> term -> thm
   16.33 +  val prove_conj_disj_eq: cterm -> thm
   16.34 +end
   16.35 +
   16.36 +structure Old_Z3_Proof_Literals: OLD_Z3_PROOF_LITERALS =
   16.37 +struct
   16.38 +
   16.39 +
   16.40 +
   16.41 +(* literal table *)
   16.42 +
   16.43 +type littab = thm Termtab.table
   16.44 +
   16.45 +fun make_littab thms =
   16.46 +  fold (Termtab.update o `Old_SMT_Utils.prop_of) thms Termtab.empty
   16.47 +
   16.48 +fun insert_lit thm = Termtab.update (`Old_SMT_Utils.prop_of thm)
   16.49 +fun delete_lit thm = Termtab.delete (Old_SMT_Utils.prop_of thm)
   16.50 +fun lookup_lit lits = Termtab.lookup lits
   16.51 +fun get_first_lit f =
   16.52 +  Termtab.get_first (fn (t, thm) => if f t then SOME thm else NONE)
   16.53 +
   16.54 +
   16.55 +
   16.56 +(* rules *)
   16.57 +
   16.58 +val true_thm = @{lemma "~False" by simp}
   16.59 +val rewrite_true = @{lemma "True == ~ False" by simp}
   16.60 +
   16.61 +
   16.62 +
   16.63 +(* properties and term operations *)
   16.64 +
   16.65 +val is_neg = (fn @{const Not} $ _ => true | _ => false)
   16.66 +fun is_neg' f = (fn @{const Not} $ t => f t | _ => false)
   16.67 +val is_dneg = is_neg' is_neg
   16.68 +val is_conj = (fn @{const HOL.conj} $ _ $ _ => true | _ => false)
   16.69 +val is_disj = (fn @{const HOL.disj} $ _ $ _ => true | _ => false)
   16.70 +
   16.71 +fun dest_disj_term' f = (fn
   16.72 +    @{const Not} $ (@{const HOL.disj} $ t $ u) => SOME (f t, f u)
   16.73 +  | _ => NONE)
   16.74 +
   16.75 +val dest_conj_term = (fn @{const HOL.conj} $ t $ u => SOME (t, u) | _ => NONE)
   16.76 +val dest_disj_term =
   16.77 +  dest_disj_term' (fn @{const Not} $ t => t | t => @{const Not} $ t)
   16.78 +
   16.79 +fun exists_lit is_conj P =
   16.80 +  let
   16.81 +    val dest = if is_conj then dest_conj_term else dest_disj_term
   16.82 +    fun exists t = P t orelse
   16.83 +      (case dest t of
   16.84 +        SOME (t1, t2) => exists t1 orelse exists t2
   16.85 +      | NONE => false)
   16.86 +  in exists end
   16.87 +
   16.88 +val negate = Thm.apply (Thm.cterm_of @{theory} @{const Not})
   16.89 +
   16.90 +
   16.91 +
   16.92 +(* proof tools *)
   16.93 +
   16.94 +(** explosion of conjunctions and disjunctions **)
   16.95 +
   16.96 +local
   16.97 +  val precomp = Old_Z3_Proof_Tools.precompose2
   16.98 +
   16.99 +  fun destc ct = Thm.dest_binop (Thm.dest_arg ct)
  16.100 +  val dest_conj1 = precomp destc @{thm conjunct1}
  16.101 +  val dest_conj2 = precomp destc @{thm conjunct2}
  16.102 +  fun dest_conj_rules t =
  16.103 +    dest_conj_term t |> Option.map (K (dest_conj1, dest_conj2))
  16.104 +    
  16.105 +  fun destd f ct = f (Thm.dest_binop (Thm.dest_arg (Thm.dest_arg ct)))
  16.106 +  val dn1 = apfst Thm.dest_arg and dn2 = apsnd Thm.dest_arg
  16.107 +  val dest_disj1 = precomp (destd I) @{lemma "~(P | Q) ==> ~P" by fast}
  16.108 +  val dest_disj2 = precomp (destd dn1) @{lemma "~(~P | Q) ==> P" by fast}
  16.109 +  val dest_disj3 = precomp (destd I) @{lemma "~(P | Q) ==> ~Q" by fast}
  16.110 +  val dest_disj4 = precomp (destd dn2) @{lemma "~(P | ~Q) ==> Q" by fast}
  16.111 +
  16.112 +  fun dest_disj_rules t =
  16.113 +    (case dest_disj_term' is_neg t of
  16.114 +      SOME (true, true) => SOME (dest_disj2, dest_disj4)
  16.115 +    | SOME (true, false) => SOME (dest_disj2, dest_disj3)
  16.116 +    | SOME (false, true) => SOME (dest_disj1, dest_disj4)
  16.117 +    | SOME (false, false) => SOME (dest_disj1, dest_disj3)
  16.118 +    | NONE => NONE)
  16.119 +
  16.120 +  fun destn ct = [Thm.dest_arg (Thm.dest_arg (Thm.dest_arg ct))]
  16.121 +  val dneg_rule = Old_Z3_Proof_Tools.precompose destn @{thm notnotD}
  16.122 +in
  16.123 +
  16.124 +(*
  16.125 +  explode a term into literals and collect all rules to be able to deduce
  16.126 +  particular literals afterwards
  16.127 +*)
  16.128 +fun explode_term is_conj =
  16.129 +  let
  16.130 +    val dest = if is_conj then dest_conj_term else dest_disj_term
  16.131 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  16.132 +
  16.133 +    fun add (t, rs) = Termtab.map_default (t, rs)
  16.134 +      (fn rs' => if length rs' < length rs then rs' else rs)
  16.135 +
  16.136 +    fun explode1 rules t =
  16.137 +      (case dest t of
  16.138 +        SOME (t1, t2) =>
  16.139 +          let val (rule1, rule2) = the (dest_rules t)
  16.140 +          in
  16.141 +            explode1 (rule1 :: rules) t1 #>
  16.142 +            explode1 (rule2 :: rules) t2 #>
  16.143 +            add (t, rev rules)
  16.144 +          end
  16.145 +      | NONE => add (t, rev rules))
  16.146 +
  16.147 +    fun explode0 (@{const Not} $ (@{const Not} $ t)) =
  16.148 +          Termtab.make [(t, [dneg_rule])]
  16.149 +      | explode0 t = explode1 [] t Termtab.empty
  16.150 +
  16.151 +  in explode0 end
  16.152 +
  16.153 +(*
  16.154 +  extract a literal by applying previously collected rules
  16.155 +*)
  16.156 +fun extract_lit thm rules = fold Old_Z3_Proof_Tools.compose rules thm
  16.157 +
  16.158 +
  16.159 +(*
  16.160 +  explode a theorem into its literals
  16.161 +*)
  16.162 +fun explode is_conj full keep_intermediate stop_lits =
  16.163 +  let
  16.164 +    val dest_rules = if is_conj then dest_conj_rules else dest_disj_rules
  16.165 +    val tab = fold (Termtab.update o rpair ()) stop_lits Termtab.empty
  16.166 +
  16.167 +    fun explode1 thm =
  16.168 +      if Termtab.defined tab (Old_SMT_Utils.prop_of thm) then cons thm
  16.169 +      else
  16.170 +        (case dest_rules (Old_SMT_Utils.prop_of thm) of
  16.171 +          SOME (rule1, rule2) =>
  16.172 +            explode2 rule1 thm #>
  16.173 +            explode2 rule2 thm #>
  16.174 +            keep_intermediate ? cons thm
  16.175 +        | NONE => cons thm)
  16.176 +
  16.177 +    and explode2 dest_rule thm =
  16.178 +      if full orelse
  16.179 +        exists_lit is_conj (Termtab.defined tab) (Old_SMT_Utils.prop_of thm)
  16.180 +      then explode1 (Old_Z3_Proof_Tools.compose dest_rule thm)
  16.181 +      else cons (Old_Z3_Proof_Tools.compose dest_rule thm)
  16.182 +
  16.183 +    fun explode0 thm =
  16.184 +      if not is_conj andalso is_dneg (Old_SMT_Utils.prop_of thm)
  16.185 +      then [Old_Z3_Proof_Tools.compose dneg_rule thm]
  16.186 +      else explode1 thm []
  16.187 +
  16.188 +  in explode0 end
  16.189 +
  16.190 +end
  16.191 +
  16.192 +
  16.193 +
  16.194 +(** joining of literals to conjunctions or disjunctions **)
  16.195 +
  16.196 +local
  16.197 +  fun on_cprem i f thm = f (Thm.cprem_of thm i)
  16.198 +  fun on_cprop f thm = f (Thm.cprop_of thm)
  16.199 +  fun precomp2 f g thm = (on_cprem 1 f thm, on_cprem 2 g thm, f, g, thm)
  16.200 +  fun comp2 (cv1, cv2, f, g, rule) thm1 thm2 =
  16.201 +    Thm.instantiate ([], [(cv1, on_cprop f thm1), (cv2, on_cprop g thm2)]) rule
  16.202 +    |> Old_Z3_Proof_Tools.discharge thm1 |> Old_Z3_Proof_Tools.discharge thm2
  16.203 +
  16.204 +  fun d1 ct = Thm.dest_arg ct and d2 ct = Thm.dest_arg (Thm.dest_arg ct)
  16.205 +
  16.206 +  val conj_rule = precomp2 d1 d1 @{thm conjI}
  16.207 +  fun comp_conj ((_, thm1), (_, thm2)) = comp2 conj_rule thm1 thm2
  16.208 +
  16.209 +  val disj1 = precomp2 d2 d2 @{lemma "~P ==> ~Q ==> ~(P | Q)" by fast}
  16.210 +  val disj2 = precomp2 d2 d1 @{lemma "~P ==> Q ==> ~(P | ~Q)" by fast}
  16.211 +  val disj3 = precomp2 d1 d2 @{lemma "P ==> ~Q ==> ~(~P | Q)" by fast}
  16.212 +  val disj4 = precomp2 d1 d1 @{lemma "P ==> Q ==> ~(~P | ~Q)" by fast}
  16.213 +
  16.214 +  fun comp_disj ((false, thm1), (false, thm2)) = comp2 disj1 thm1 thm2
  16.215 +    | comp_disj ((false, thm1), (true, thm2)) = comp2 disj2 thm1 thm2
  16.216 +    | comp_disj ((true, thm1), (false, thm2)) = comp2 disj3 thm1 thm2
  16.217 +    | comp_disj ((true, thm1), (true, thm2)) = comp2 disj4 thm1 thm2
  16.218 +
  16.219 +  fun dest_conj (@{const HOL.conj} $ t $ u) = ((false, t), (false, u))
  16.220 +    | dest_conj t = raise TERM ("dest_conj", [t])
  16.221 +
  16.222 +  val neg = (fn @{const Not} $ t => (true, t) | t => (false, @{const Not} $ t))
  16.223 +  fun dest_disj (@{const Not} $ (@{const HOL.disj} $ t $ u)) = (neg t, neg u)
  16.224 +    | dest_disj t = raise TERM ("dest_disj", [t])
  16.225 +
  16.226 +  val precomp = Old_Z3_Proof_Tools.precompose
  16.227 +  val dnegE = precomp (single o d2 o d1) @{thm notnotD}
  16.228 +  val dnegI = precomp (single o d1) @{lemma "P ==> ~~P" by fast}
  16.229 +  fun as_dneg f t = f (@{const Not} $ (@{const Not} $ t))
  16.230 +
  16.231 +  val precomp2 = Old_Z3_Proof_Tools.precompose2
  16.232 +  fun dni f = apsnd f o Thm.dest_binop o f o d1
  16.233 +  val negIffE = precomp2 (dni d1) @{lemma "~(P = (~Q)) ==> Q = P" by fast}
  16.234 +  val negIffI = precomp2 (dni I) @{lemma "P = Q ==> ~(Q = (~P))" by fast}
  16.235 +  val iff_const = @{const HOL.eq (bool)}
  16.236 +  fun as_negIff f (@{const HOL.eq (bool)} $ t $ u) =
  16.237 +        f (@{const Not} $ (iff_const $ u $ (@{const Not} $ t)))
  16.238 +    | as_negIff _ _ = NONE
  16.239 +in
  16.240 +
  16.241 +fun join is_conj littab t =
  16.242 +  let
  16.243 +    val comp = if is_conj then comp_conj else comp_disj
  16.244 +    val dest = if is_conj then dest_conj else dest_disj
  16.245 +
  16.246 +    val lookup = lookup_lit littab
  16.247 +
  16.248 +    fun lookup_rule t =
  16.249 +      (case t of
  16.250 +        @{const Not} $ (@{const Not} $ t) =>
  16.251 +          (Old_Z3_Proof_Tools.compose dnegI, lookup t)
  16.252 +      | @{const Not} $ (@{const HOL.eq (bool)} $ t $ (@{const Not} $ u)) =>
  16.253 +          (Old_Z3_Proof_Tools.compose negIffI, lookup (iff_const $ u $ t))
  16.254 +      | @{const Not} $ ((eq as Const (@{const_name HOL.eq}, _)) $ t $ u) =>
  16.255 +          let fun rewr lit = lit COMP @{thm not_sym}
  16.256 +          in (rewr, lookup (@{const Not} $ (eq $ u $ t))) end
  16.257 +      | _ =>
  16.258 +          (case as_dneg lookup t of
  16.259 +            NONE => (Old_Z3_Proof_Tools.compose negIffE, as_negIff lookup t)
  16.260 +          | x => (Old_Z3_Proof_Tools.compose dnegE, x)))
  16.261 +
  16.262 +    fun join1 (s, t) =
  16.263 +      (case lookup t of
  16.264 +        SOME lit => (s, lit)
  16.265 +      | NONE => 
  16.266 +          (case lookup_rule t of
  16.267 +            (rewrite, SOME lit) => (s, rewrite lit)
  16.268 +          | (_, NONE) => (s, comp (pairself join1 (dest t)))))
  16.269 +
  16.270 +  in snd (join1 (if is_conj then (false, t) else (true, t))) end
  16.271 +
  16.272 +end
  16.273 +
  16.274 +
  16.275 +
  16.276 +(** proving equality of conjunctions or disjunctions **)
  16.277 +
  16.278 +fun iff_intro thm1 thm2 = thm2 COMP (thm1 COMP @{thm iffI})
  16.279 +
  16.280 +local
  16.281 +  val cp1 = @{lemma "(~P) = (~Q) ==> P = Q" by simp}
  16.282 +  val cp2 = @{lemma "(~P) = Q ==> P = (~Q)" by fastforce}
  16.283 +  val cp3 = @{lemma "P = (~Q) ==> (~P) = Q" by simp}
  16.284 +in
  16.285 +fun contrapos1 prove (ct, cu) = prove (negate ct, negate cu) COMP cp1
  16.286 +fun contrapos2 prove (ct, cu) = prove (negate ct, Thm.dest_arg cu) COMP cp2
  16.287 +fun contrapos3 prove (ct, cu) = prove (Thm.dest_arg ct, negate cu) COMP cp3
  16.288 +end
  16.289 +
  16.290 +
  16.291 +local
  16.292 +  val contra_rule = @{lemma "P ==> ~P ==> False" by (rule notE)}
  16.293 +  fun contra_left conj thm =
  16.294 +    let
  16.295 +      val rules = explode_term conj (Old_SMT_Utils.prop_of thm)
  16.296 +      fun contra_lits (t, rs) =
  16.297 +        (case t of
  16.298 +          @{const Not} $ u => Termtab.lookup rules u |> Option.map (pair rs)
  16.299 +        | _ => NONE)
  16.300 +    in
  16.301 +      (case Termtab.lookup rules @{const False} of
  16.302 +        SOME rs => extract_lit thm rs
  16.303 +      | NONE =>
  16.304 +          the (Termtab.get_first contra_lits rules)
  16.305 +          |> pairself (extract_lit thm)
  16.306 +          |> (fn (nlit, plit) => nlit COMP (plit COMP contra_rule)))
  16.307 +    end
  16.308 +
  16.309 +  val falseE_v = Thm.dest_arg (Thm.dest_arg (Thm.cprop_of @{thm FalseE}))
  16.310 +  fun contra_right ct = Thm.instantiate ([], [(falseE_v, ct)]) @{thm FalseE}
  16.311 +in
  16.312 +fun contradict conj ct =
  16.313 +  iff_intro (Old_Z3_Proof_Tools.under_assumption (contra_left conj) ct)
  16.314 +    (contra_right ct)
  16.315 +end
  16.316 +
  16.317 +
  16.318 +local
  16.319 +  fun prove_eq l r (cl, cr) =
  16.320 +    let
  16.321 +      fun explode' is_conj = explode is_conj true (l <> r) []
  16.322 +      fun make_tab is_conj thm = make_littab (true_thm :: explode' is_conj thm)
  16.323 +      fun prove is_conj ct tab = join is_conj tab (Thm.term_of ct)
  16.324 +
  16.325 +      val thm1 = Old_Z3_Proof_Tools.under_assumption (prove r cr o make_tab l) cl
  16.326 +      val thm2 = Old_Z3_Proof_Tools.under_assumption (prove l cl o make_tab r) cr
  16.327 +    in iff_intro thm1 thm2 end
  16.328 +
  16.329 +  datatype conj_disj = CONJ | DISJ | NCON | NDIS
  16.330 +  fun kind_of t =
  16.331 +    if is_conj t then SOME CONJ
  16.332 +    else if is_disj t then SOME DISJ
  16.333 +    else if is_neg' is_conj t then SOME NCON
  16.334 +    else if is_neg' is_disj t then SOME NDIS
  16.335 +    else NONE
  16.336 +in
  16.337 +
  16.338 +fun prove_conj_disj_eq ct =
  16.339 +  let val cp as (cl, cr) = Thm.dest_binop (Thm.dest_arg ct)
  16.340 +  in
  16.341 +    (case (kind_of (Thm.term_of cl), Thm.term_of cr) of
  16.342 +      (SOME CONJ, @{const False}) => contradict true cl
  16.343 +    | (SOME DISJ, @{const Not} $ @{const False}) =>
  16.344 +        contrapos2 (contradict false o fst) cp
  16.345 +    | (kl, _) =>
  16.346 +        (case (kl, kind_of (Thm.term_of cr)) of
  16.347 +          (SOME CONJ, SOME CONJ) => prove_eq true true cp
  16.348 +        | (SOME CONJ, SOME NDIS) => prove_eq true false cp
  16.349 +        | (SOME CONJ, _) => prove_eq true true cp
  16.350 +        | (SOME DISJ, SOME DISJ) => contrapos1 (prove_eq false false) cp
  16.351 +        | (SOME DISJ, SOME NCON) => contrapos2 (prove_eq false true) cp
  16.352 +        | (SOME DISJ, _) => contrapos1 (prove_eq false false) cp
  16.353 +        | (SOME NCON, SOME NCON) => contrapos1 (prove_eq true true) cp
  16.354 +        | (SOME NCON, SOME DISJ) => contrapos3 (prove_eq true false) cp
  16.355 +        | (SOME NCON, NONE) => contrapos3 (prove_eq true false) cp
  16.356 +        | (SOME NDIS, SOME NDIS) => prove_eq false false cp
  16.357 +        | (SOME NDIS, SOME CONJ) => prove_eq false true cp
  16.358 +        | (SOME NDIS, NONE) => prove_eq false true cp
  16.359 +        | _ => raise CTERM ("prove_conj_disj_eq", [ct])))
  16.360 +  end
  16.361 +
  16.362 +end
  16.363 +
  16.364 +end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_methods.ML	Thu Aug 28 00:40:38 2014 +0200
    17.3 @@ -0,0 +1,149 @@
    17.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_proof_methods.ML
    17.5 +    Author:     Sascha Boehme, TU Muenchen
    17.6 +
    17.7 +Proof methods for Z3 proof reconstruction.
    17.8 +*)
    17.9 +
   17.10 +signature OLD_Z3_PROOF_METHODS =
   17.11 +sig
   17.12 +  val prove_injectivity: Proof.context -> cterm -> thm
   17.13 +  val prove_ite: Proof.context -> cterm -> thm
   17.14 +end
   17.15 +
   17.16 +structure Old_Z3_Proof_Methods: OLD_Z3_PROOF_METHODS =
   17.17 +struct
   17.18 +
   17.19 +
   17.20 +fun apply tac st =
   17.21 +  (case Seq.pull (tac 1 st) of
   17.22 +    NONE => raise THM ("tactic failed", 1, [st])
   17.23 +  | SOME (st', _) => st')
   17.24 +
   17.25 +
   17.26 +
   17.27 +(* if-then-else *)
   17.28 +
   17.29 +val pull_ite = mk_meta_eq
   17.30 +  @{lemma "f (if P then x else y) = (if P then f x else f y)" by simp}
   17.31 +
   17.32 +fun pull_ites_conv ct =
   17.33 +  (Conv.rewr_conv pull_ite then_conv
   17.34 +   Conv.binop_conv (Conv.try_conv pull_ites_conv)) ct
   17.35 +
   17.36 +fun prove_ite ctxt =
   17.37 +  Old_Z3_Proof_Tools.by_tac ctxt (
   17.38 +    CONVERSION (Conv.arg_conv (Conv.arg1_conv pull_ites_conv))
   17.39 +    THEN' rtac @{thm refl})
   17.40 +
   17.41 +
   17.42 +
   17.43 +(* injectivity *)
   17.44 +
   17.45 +local
   17.46 +
   17.47 +val B = @{typ bool}
   17.48 +fun mk_univ T = Const (@{const_name top}, HOLogic.mk_setT T)
   17.49 +fun mk_inj_on T U =
   17.50 +  Const (@{const_name inj_on}, (T --> U) --> HOLogic.mk_setT T --> B)
   17.51 +fun mk_inv_into T U =
   17.52 +  Const (@{const_name inv_into}, [HOLogic.mk_setT T, T --> U, U] ---> T)
   17.53 +
   17.54 +fun mk_inv_of ctxt ct =
   17.55 +  let
   17.56 +    val (dT, rT) = Term.dest_funT (Old_SMT_Utils.typ_of ct)
   17.57 +    val inv = Old_SMT_Utils.certify ctxt (mk_inv_into dT rT)
   17.58 +    val univ = Old_SMT_Utils.certify ctxt (mk_univ dT)
   17.59 +  in Thm.mk_binop inv univ ct end
   17.60 +
   17.61 +fun mk_inj_prop ctxt ct =
   17.62 +  let
   17.63 +    val (dT, rT) = Term.dest_funT (Old_SMT_Utils.typ_of ct)
   17.64 +    val inj = Old_SMT_Utils.certify ctxt (mk_inj_on dT rT)
   17.65 +    val univ = Old_SMT_Utils.certify ctxt (mk_univ dT)
   17.66 +  in Old_SMT_Utils.mk_cprop (Thm.mk_binop inj ct univ) end
   17.67 +
   17.68 +
   17.69 +val disjE = @{lemma "~P | Q ==> P ==> Q" by fast}
   17.70 +
   17.71 +fun prove_inj_prop ctxt def lhs =
   17.72 +  let
   17.73 +    val (ct, ctxt') = Old_SMT_Utils.dest_all_cabs (Thm.rhs_of def) ctxt
   17.74 +    val rule = disjE OF [Object_Logic.rulify ctxt' (Thm.assume lhs)]
   17.75 +  in
   17.76 +    Goal.init (mk_inj_prop ctxt' (Thm.dest_arg ct))
   17.77 +    |> apply (rtac @{thm injI})
   17.78 +    |> apply (Tactic.solve_tac [rule, rule RS @{thm sym}])
   17.79 +    |> Goal.norm_result ctxt' o Goal.finish ctxt'
   17.80 +    |> singleton (Variable.export ctxt' ctxt)
   17.81 +  end
   17.82 +
   17.83 +fun prove_rhs ctxt def lhs =
   17.84 +  Old_Z3_Proof_Tools.by_tac ctxt (
   17.85 +    CONVERSION (Conv.top_sweep_conv (K (Conv.rewr_conv def)) ctxt)
   17.86 +    THEN' REPEAT_ALL_NEW (match_tac @{thms allI})
   17.87 +    THEN' rtac (@{thm inv_f_f} OF [prove_inj_prop ctxt def lhs]))
   17.88 +
   17.89 +
   17.90 +fun expand thm ct =
   17.91 +  let
   17.92 +    val cpat = Thm.dest_arg (Thm.rhs_of thm)
   17.93 +    val (cl, cr) = Thm.dest_binop (Thm.dest_arg (Thm.dest_arg1 ct))
   17.94 +    val thm1 = Thm.instantiate (Thm.match (cpat, cl)) thm
   17.95 +    val thm2 = Thm.instantiate (Thm.match (cpat, cr)) thm
   17.96 +  in Conv.arg_conv (Conv.binop_conv (Conv.rewrs_conv [thm1, thm2])) ct end
   17.97 +
   17.98 +fun prove_lhs ctxt rhs =
   17.99 +  let
  17.100 +    val eq = Thm.symmetric (mk_meta_eq (Object_Logic.rulify ctxt (Thm.assume rhs)))
  17.101 +    val conv = Old_SMT_Utils.binders_conv (K (expand eq)) ctxt
  17.102 +  in
  17.103 +    Old_Z3_Proof_Tools.by_tac ctxt (
  17.104 +      CONVERSION (Old_SMT_Utils.prop_conv conv)
  17.105 +      THEN' Simplifier.simp_tac (put_simpset HOL_ss ctxt))
  17.106 +  end
  17.107 +
  17.108 +
  17.109 +fun mk_inv_def ctxt rhs =
  17.110 +  let
  17.111 +    val (ct, ctxt') =
  17.112 +      Old_SMT_Utils.dest_all_cbinders (Old_SMT_Utils.dest_cprop rhs) ctxt
  17.113 +    val (cl, cv) = Thm.dest_binop ct
  17.114 +    val (cg, (cargs, cf)) = Drule.strip_comb cl ||> split_last
  17.115 +    val cu = fold_rev Thm.lambda cargs (mk_inv_of ctxt' (Thm.lambda cv cf))
  17.116 +  in Thm.assume (Old_SMT_Utils.mk_cequals cg cu) end
  17.117 +
  17.118 +fun prove_inj_eq ctxt ct =
  17.119 +  let
  17.120 +    val (lhs, rhs) =
  17.121 +      pairself Old_SMT_Utils.mk_cprop (Thm.dest_binop (Old_SMT_Utils.dest_cprop ct))
  17.122 +    val lhs_thm = Thm.implies_intr rhs (prove_lhs ctxt rhs lhs)
  17.123 +    val rhs_thm =
  17.124 +      Thm.implies_intr lhs (prove_rhs ctxt (mk_inv_def ctxt rhs) lhs rhs)
  17.125 +  in lhs_thm COMP (rhs_thm COMP @{thm iffI}) end
  17.126 +
  17.127 +
  17.128 +val swap_eq_thm = mk_meta_eq @{thm eq_commute}
  17.129 +val swap_disj_thm = mk_meta_eq @{thm disj_commute}
  17.130 +
  17.131 +fun swap_conv dest eq =
  17.132 +  Old_SMT_Utils.if_true_conv ((op <) o pairself Term.size_of_term o dest)
  17.133 +    (Conv.rewr_conv eq)
  17.134 +
  17.135 +val swap_eq_conv = swap_conv HOLogic.dest_eq swap_eq_thm
  17.136 +val swap_disj_conv = swap_conv Old_SMT_Utils.dest_disj swap_disj_thm
  17.137 +
  17.138 +fun norm_conv ctxt =
  17.139 +  swap_eq_conv then_conv
  17.140 +  Conv.arg1_conv (Old_SMT_Utils.binders_conv (K swap_disj_conv) ctxt) then_conv
  17.141 +  Conv.arg_conv (Old_SMT_Utils.binders_conv (K swap_eq_conv) ctxt)
  17.142 +
  17.143 +in
  17.144 +
  17.145 +fun prove_injectivity ctxt =
  17.146 +  Old_Z3_Proof_Tools.by_tac ctxt (
  17.147 +    CONVERSION (Old_SMT_Utils.prop_conv (norm_conv ctxt))
  17.148 +    THEN' CSUBGOAL (uncurry (rtac o prove_inj_eq ctxt)))
  17.149 +
  17.150 +end
  17.151 +
  17.152 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_parser.ML	Thu Aug 28 00:40:38 2014 +0200
    18.3 @@ -0,0 +1,445 @@
    18.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_proof_parser.ML
    18.5 +    Author:     Sascha Boehme, TU Muenchen
    18.6 +
    18.7 +Parser for Z3 proofs.
    18.8 +*)
    18.9 +
   18.10 +signature OLD_Z3_PROOF_PARSER =
   18.11 +sig
   18.12 +  (*proof rules*)
   18.13 +  datatype rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity |
   18.14 +    Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro |
   18.15 +    Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star |
   18.16 +    Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars |
   18.17 +    Dest_Eq_Res | Quant_Inst | Hypothesis | Lemma | Unit_Resolution |
   18.18 +    Iff_True | Iff_False | Commutativity | Def_Axiom | Intro_Def | Apply_Def |
   18.19 +    Iff_Oeq | Nnf_Pos | Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize |
   18.20 +    Modus_Ponens_Oeq | Th_Lemma of string list
   18.21 +  val string_of_rule: rule -> string
   18.22 +
   18.23 +  (*proof parser*)
   18.24 +  datatype proof_step = Proof_Step of {
   18.25 +    rule: rule,
   18.26 +    args: cterm list,
   18.27 +    prems: int list,
   18.28 +    prop: cterm }
   18.29 +  val parse: Proof.context -> typ Symtab.table -> term Symtab.table ->
   18.30 +    string list ->
   18.31 +    (int * cterm) list * (int * proof_step) list * string list * Proof.context
   18.32 +end
   18.33 +
   18.34 +structure Old_Z3_Proof_Parser: OLD_Z3_PROOF_PARSER =
   18.35 +struct
   18.36 +
   18.37 +
   18.38 +(* proof rules *)
   18.39 +
   18.40 +datatype rule = True_Axiom | Asserted | Goal | Modus_Ponens | Reflexivity |
   18.41 +  Symmetry | Transitivity | Transitivity_Star | Monotonicity | Quant_Intro |
   18.42 +  Distributivity | And_Elim | Not_Or_Elim | Rewrite | Rewrite_Star |
   18.43 +  Pull_Quant | Pull_Quant_Star | Push_Quant | Elim_Unused_Vars | Dest_Eq_Res |
   18.44 +  Quant_Inst | Hypothesis | Lemma | Unit_Resolution | Iff_True | Iff_False |
   18.45 +  Commutativity | Def_Axiom | Intro_Def | Apply_Def | Iff_Oeq | Nnf_Pos |
   18.46 +  Nnf_Neg | Nnf_Star | Cnf_Star | Skolemize | Modus_Ponens_Oeq |
   18.47 +  Th_Lemma of string list
   18.48 +
   18.49 +val rule_names = Symtab.make [
   18.50 +  ("true-axiom", True_Axiom),
   18.51 +  ("asserted", Asserted),
   18.52 +  ("goal", Goal),
   18.53 +  ("mp", Modus_Ponens),
   18.54 +  ("refl", Reflexivity),
   18.55 +  ("symm", Symmetry),
   18.56 +  ("trans", Transitivity),
   18.57 +  ("trans*", Transitivity_Star),
   18.58 +  ("monotonicity", Monotonicity),
   18.59 +  ("quant-intro", Quant_Intro),
   18.60 +  ("distributivity", Distributivity),
   18.61 +  ("and-elim", And_Elim),
   18.62 +  ("not-or-elim", Not_Or_Elim),
   18.63 +  ("rewrite", Rewrite),
   18.64 +  ("rewrite*", Rewrite_Star),
   18.65 +  ("pull-quant", Pull_Quant),
   18.66 +  ("pull-quant*", Pull_Quant_Star),
   18.67 +  ("push-quant", Push_Quant),
   18.68 +  ("elim-unused", Elim_Unused_Vars),
   18.69 +  ("der", Dest_Eq_Res),
   18.70 +  ("quant-inst", Quant_Inst),
   18.71 +  ("hypothesis", Hypothesis),
   18.72 +  ("lemma", Lemma),
   18.73 +  ("unit-resolution", Unit_Resolution),
   18.74 +  ("iff-true", Iff_True),
   18.75 +  ("iff-false", Iff_False),
   18.76 +  ("commutativity", Commutativity),
   18.77 +  ("def-axiom", Def_Axiom),
   18.78 +  ("intro-def", Intro_Def),
   18.79 +  ("apply-def", Apply_Def),
   18.80 +  ("iff~", Iff_Oeq),
   18.81 +  ("nnf-pos", Nnf_Pos),
   18.82 +  ("nnf-neg", Nnf_Neg),
   18.83 +  ("nnf*", Nnf_Star),
   18.84 +  ("cnf*", Cnf_Star),
   18.85 +  ("sk", Skolemize),
   18.86 +  ("mp~", Modus_Ponens_Oeq),
   18.87 +  ("th-lemma", Th_Lemma [])]
   18.88 +
   18.89 +fun string_of_rule (Th_Lemma args) = space_implode " " ("th-lemma" :: args)
   18.90 +  | string_of_rule r =
   18.91 +      let fun eq_rule (s, r') = if r = r' then SOME s else NONE 
   18.92 +      in the (Symtab.get_first eq_rule rule_names) end
   18.93 +
   18.94 +
   18.95 +
   18.96 +(* certified terms and variables *)
   18.97 +
   18.98 +val (var_prefix, decl_prefix) = ("v", "sk")
   18.99 +(*
  18.100 +  "decl_prefix" is for skolem constants (represented by free variables),
  18.101 +  "var_prefix" is for pseudo-schematic variables (schematic with respect
  18.102 +  to the Z3 proof, but represented by free variables).
  18.103 +
  18.104 +  Both prefixes must be distinct to avoid name interferences.
  18.105 +  More precisely, the naming of pseudo-schematic variables must be
  18.106 +  context-independent modulo the current proof context to be able to
  18.107 +  use fast inference kernel rules during proof reconstruction.
  18.108 +*)
  18.109 +
  18.110 +val maxidx_of = #maxidx o Thm.rep_cterm
  18.111 +
  18.112 +fun mk_inst ctxt vars =
  18.113 +  let
  18.114 +    val max = fold (Integer.max o fst) vars 0
  18.115 +    val ns = fst (Variable.variant_fixes (replicate (max + 1) var_prefix) ctxt)
  18.116 +    fun mk (i, v) =
  18.117 +      (v, Old_SMT_Utils.certify ctxt (Free (nth ns i, #T (Thm.rep_cterm v))))
  18.118 +  in map mk vars end
  18.119 +
  18.120 +fun close ctxt (ct, vars) =
  18.121 +  let
  18.122 +    val inst = mk_inst ctxt vars
  18.123 +    val names = fold (Term.add_free_names o Thm.term_of o snd) inst []
  18.124 +  in (Thm.instantiate_cterm ([], inst) ct, names) end
  18.125 +
  18.126 +
  18.127 +fun mk_bound ctxt (i, T) =
  18.128 +  let val ct = Old_SMT_Utils.certify ctxt (Var ((Name.uu, 0), T))
  18.129 +  in (ct, [(i, ct)]) end
  18.130 +
  18.131 +local
  18.132 +  fun mk_quant1 ctxt q T (ct, vars) =
  18.133 +    let
  18.134 +      val cv =
  18.135 +        (case AList.lookup (op =) vars 0 of
  18.136 +          SOME cv => cv
  18.137 +        | _ => Old_SMT_Utils.certify ctxt (Var ((Name.uu, maxidx_of ct + 1), T)))
  18.138 +      fun dec (i, v) = if i = 0 then NONE else SOME (i-1, v)
  18.139 +      val vars' = map_filter dec vars
  18.140 +    in (Thm.apply (Old_SMT_Utils.instT' cv q) (Thm.lambda cv ct), vars') end
  18.141 +
  18.142 +  fun quant name =
  18.143 +    Old_SMT_Utils.mk_const_pat @{theory} name (Old_SMT_Utils.destT1 o Old_SMT_Utils.destT1)
  18.144 +  val forall = quant @{const_name All}
  18.145 +  val exists = quant @{const_name Ex}
  18.146 +in
  18.147 +
  18.148 +fun mk_quant is_forall ctxt =
  18.149 +  fold_rev (mk_quant1 ctxt (if is_forall then forall else exists))
  18.150 +
  18.151 +end
  18.152 +
  18.153 +local
  18.154 +  fun prep (ct, vars) (maxidx, all_vars) =
  18.155 +    let
  18.156 +      val maxidx' = maxidx + maxidx_of ct + 1
  18.157 +
  18.158 +      fun part (i, cv) =
  18.159 +        (case AList.lookup (op =) all_vars i of
  18.160 +          SOME cu => apfst (if cu aconvc cv then I else cons (cv, cu))
  18.161 +        | NONE =>
  18.162 +            let val cv' = Thm.incr_indexes_cterm maxidx cv
  18.163 +            in apfst (cons (cv, cv')) #> apsnd (cons (i, cv')) end)
  18.164 +
  18.165 +      val (inst, vars') =
  18.166 +        if null vars then ([], vars)
  18.167 +        else fold part vars ([], [])
  18.168 +
  18.169 +    in (Thm.instantiate_cterm ([], inst) ct, (maxidx', vars' @ all_vars)) end
  18.170 +in
  18.171 +fun mk_fun f ts =
  18.172 +  let val (cts, (_, vars)) = fold_map prep ts (0, [])
  18.173 +  in f cts |> Option.map (rpair vars) end
  18.174 +end
  18.175 +
  18.176 +
  18.177 +
  18.178 +(* proof parser *)
  18.179 +
  18.180 +datatype proof_step = Proof_Step of {
  18.181 +  rule: rule,
  18.182 +  args: cterm list,
  18.183 +  prems: int list,
  18.184 +  prop: cterm }
  18.185 +
  18.186 +
  18.187 +(** parser context **)
  18.188 +
  18.189 +val not_false = Thm.cterm_of @{theory} (@{const Not} $ @{const False})
  18.190 +
  18.191 +fun make_context ctxt typs terms =
  18.192 +  let
  18.193 +    val ctxt' = 
  18.194 +      ctxt
  18.195 +      |> Symtab.fold (Variable.declare_typ o snd) typs
  18.196 +      |> Symtab.fold (Variable.declare_term o snd) terms
  18.197 +
  18.198 +    fun cert @{const True} = not_false
  18.199 +      | cert t = Old_SMT_Utils.certify ctxt' t
  18.200 +
  18.201 +  in (typs, Symtab.map (K cert) terms, Inttab.empty, [], [], ctxt') end
  18.202 +
  18.203 +fun fresh_name n (typs, terms, exprs, steps, vars, ctxt) =
  18.204 +  let val (n', ctxt') = yield_singleton Variable.variant_fixes n ctxt
  18.205 +  in (n', (typs, terms, exprs, steps, vars, ctxt')) end
  18.206 +
  18.207 +fun context_of (_, _, _, _, _, ctxt) = ctxt
  18.208 +
  18.209 +fun add_decl (n, T) (cx as (_, terms, _, _, _, _)) =
  18.210 +  (case Symtab.lookup terms n of
  18.211 +    SOME _ => cx
  18.212 +  | NONE => cx |> fresh_name (decl_prefix ^ n)
  18.213 +      |> (fn (m, (typs, terms, exprs, steps, vars, ctxt)) =>
  18.214 +           let
  18.215 +             val upd = Symtab.update (n, Old_SMT_Utils.certify ctxt (Free (m, T)))
  18.216 +           in (typs, upd terms, exprs, steps, vars, ctxt) end))
  18.217 +
  18.218 +fun mk_typ (typs, _, _, _, _, ctxt) (s as Old_Z3_Interface.Sym (n, _)) = 
  18.219 +  (case Old_Z3_Interface.mk_builtin_typ ctxt s of
  18.220 +    SOME T => SOME T
  18.221 +  | NONE => Symtab.lookup typs n)
  18.222 +
  18.223 +fun mk_num (_, _, _, _, _, ctxt) (i, T) =
  18.224 +  mk_fun (K (Old_Z3_Interface.mk_builtin_num ctxt i T)) []
  18.225 +
  18.226 +fun mk_app (_, terms, _, _, _, ctxt) (s as Old_Z3_Interface.Sym (n, _), es) =
  18.227 +  mk_fun (fn cts =>
  18.228 +    (case Old_Z3_Interface.mk_builtin_fun ctxt s cts of
  18.229 +      SOME ct => SOME ct
  18.230 +    | NONE =>
  18.231 +        Symtab.lookup terms n |> Option.map (Drule.list_comb o rpair cts))) es
  18.232 +
  18.233 +fun add_expr k t (typs, terms, exprs, steps, vars, ctxt) =
  18.234 +  (typs, terms, Inttab.update (k, t) exprs, steps, vars, ctxt)
  18.235 +
  18.236 +fun lookup_expr (_, _, exprs, _, _, _) = Inttab.lookup exprs
  18.237 +
  18.238 +fun add_proof_step k ((r, args), prop) cx =
  18.239 +  let
  18.240 +    val (typs, terms, exprs, steps, vars, ctxt) = cx
  18.241 +    val (ct, vs) = close ctxt prop
  18.242 +    fun part (SOME e, _) (cts, ps) = (close ctxt e :: cts, ps)
  18.243 +      | part (NONE, i) (cts, ps) = (cts, i :: ps)
  18.244 +    val (args', prems) = fold (part o `(lookup_expr cx)) args ([], [])
  18.245 +    val (cts, vss) = split_list args'
  18.246 +    val step = Proof_Step {rule=r, args=rev cts, prems=rev prems,
  18.247 +      prop = Old_SMT_Utils.mk_cprop ct}
  18.248 +    val vars' = fold (union (op =)) (vs :: vss) vars
  18.249 +  in (typs, terms, exprs, (k, step) :: steps, vars', ctxt) end
  18.250 +
  18.251 +fun finish (_, _, _, steps, vars, ctxt) =
  18.252 +  let
  18.253 +    fun coll (p as (k, Proof_Step {prems, rule, prop, ...})) (ars, ps, ids) =
  18.254 +      (case rule of
  18.255 +        Asserted => ((k, prop) :: ars, ps, ids)
  18.256 +      | Goal => ((k, prop) :: ars, ps, ids)
  18.257 +      | _ =>
  18.258 +          if Inttab.defined ids k then
  18.259 +            (ars, p :: ps, fold (Inttab.update o rpair ()) prems ids)
  18.260 +          else (ars, ps, ids))
  18.261 +
  18.262 +    val (ars, steps', _) = fold coll steps ([], [], Inttab.make [(~1, ())])
  18.263 +  in (ars, steps', vars, ctxt) end
  18.264 +
  18.265 +
  18.266 +(** core parser **)
  18.267 +
  18.268 +fun parse_exn line_no msg = raise Old_SMT_Failure.SMT (Old_SMT_Failure.Other_Failure
  18.269 +  ("Z3 proof parser (line " ^ string_of_int line_no ^ "): " ^ msg))
  18.270 +
  18.271 +fun scan_exn msg ((line_no, _), _) = parse_exn line_no msg
  18.272 +
  18.273 +fun with_info f cx =
  18.274 +  (case f ((NONE, 1), cx) of
  18.275 +    ((SOME _, _), cx') => cx'
  18.276 +  | ((_, line_no), _) => parse_exn line_no "bad proof")
  18.277 +
  18.278 +fun parse_line _ _ (st as ((SOME _, _), _)) = st
  18.279 +  | parse_line scan line ((_, line_no), cx) =
  18.280 +      let val st = ((line_no, cx), raw_explode line)
  18.281 +      in
  18.282 +        (case Scan.catch (Scan.finite' Symbol.stopper (Scan.option scan)) st of
  18.283 +          (SOME r, ((_, cx'), _)) => ((r, line_no+1), cx')
  18.284 +        | (NONE, _) => parse_exn line_no ("bad proof line: " ^ quote line))
  18.285 +      end
  18.286 +
  18.287 +fun with_context f x ((line_no, cx), st) =
  18.288 +  let val (y, cx') = f x cx
  18.289 +  in (y, ((line_no, cx'), st)) end
  18.290 +  
  18.291 +
  18.292 +fun lookup_context f x (st as ((_, cx), _)) = (f cx x, st)
  18.293 +
  18.294 +
  18.295 +(** parser combinators and parsers for basic entities **)
  18.296 +
  18.297 +fun $$ s = Scan.lift (Scan.$$ s)
  18.298 +fun this s = Scan.lift (Scan.this_string s)
  18.299 +val is_blank = Symbol.is_ascii_blank
  18.300 +fun blank st = Scan.lift (Scan.many1 is_blank) st
  18.301 +fun sep scan = blank |-- scan
  18.302 +fun seps scan = Scan.repeat (sep scan)
  18.303 +fun seps1 scan = Scan.repeat1 (sep scan)
  18.304 +fun seps_by scan_sep scan = scan ::: Scan.repeat (scan_sep |-- scan)
  18.305 +
  18.306 +val lpar = "(" and rpar = ")"
  18.307 +val lbra = "[" and rbra = "]"
  18.308 +fun par scan = $$ lpar |-- scan --| $$ rpar
  18.309 +fun bra scan = $$ lbra |-- scan --| $$ rbra
  18.310 +
  18.311 +val digit = (fn
  18.312 +  "0" => SOME 0 | "1" => SOME 1 | "2" => SOME 2 | "3" => SOME 3 |
  18.313 +  "4" => SOME 4 | "5" => SOME 5 | "6" => SOME 6 | "7" => SOME 7 |
  18.314 +  "8" => SOME 8 | "9" => SOME 9 | _ => NONE)
  18.315 +
  18.316 +fun digits st = (Scan.lift (Scan.many1 Symbol.is_ascii_digit) >> implode) st
  18.317 +
  18.318 +fun nat_num st = (Scan.lift (Scan.repeat1 (Scan.some digit)) >> (fn ds =>
  18.319 +  fold (fn d => fn i => i * 10 + d) ds 0)) st
  18.320 +
  18.321 +fun int_num st = (Scan.optional ($$ "-" >> K (fn i => ~i)) I :|--
  18.322 +  (fn sign => nat_num >> sign)) st
  18.323 +
  18.324 +val is_char = Symbol.is_ascii_letter orf Symbol.is_ascii_digit orf
  18.325 +  member (op =) (raw_explode "_+*-/%~=<>$&|?!.@^#")
  18.326 +
  18.327 +fun name st = (Scan.lift (Scan.many1 is_char) >> implode) st
  18.328 +
  18.329 +fun sym st = (name --
  18.330 +  Scan.optional (bra (seps_by ($$ ":") sym)) [] >> Old_Z3_Interface.Sym) st
  18.331 +
  18.332 +fun id st = ($$ "#" |-- nat_num) st
  18.333 +
  18.334 +
  18.335 +(** parsers for various parts of Z3 proofs **)
  18.336 +
  18.337 +fun sort st = Scan.first [
  18.338 +  this "array" |-- bra (sort --| $$ ":" -- sort) >> (op -->),
  18.339 +  par (this "->" |-- seps1 sort) >> ((op --->) o split_last),
  18.340 +  sym :|-- (fn s as Old_Z3_Interface.Sym (n, _) => lookup_context mk_typ s :|-- (fn
  18.341 +    SOME T => Scan.succeed T
  18.342 +  | NONE => scan_exn ("unknown sort: " ^ quote n)))] st
  18.343 +
  18.344 +fun bound st = (par (this ":var" |-- sep nat_num -- sep sort) :|--
  18.345 +  lookup_context (mk_bound o context_of)) st
  18.346 +
  18.347 +fun numb (n as (i, _)) = lookup_context mk_num n :|-- (fn
  18.348 +    SOME n' => Scan.succeed n'
  18.349 +  | NONE => scan_exn ("unknown number: " ^ quote (string_of_int i)))
  18.350 +
  18.351 +fun appl (app as (Old_Z3_Interface.Sym (n, _), _)) =
  18.352 +  lookup_context mk_app app :|-- (fn 
  18.353 +      SOME app' => Scan.succeed app'
  18.354 +    | NONE => scan_exn ("unknown function symbol: " ^ quote n))
  18.355 +
  18.356 +fun bv_size st = (digits >> (fn sz =>
  18.357 +  Old_Z3_Interface.Sym ("bv", [Old_Z3_Interface.Sym (sz, [])]))) st
  18.358 +
  18.359 +fun bv_number_sort st = (bv_size :|-- lookup_context mk_typ :|-- (fn
  18.360 +    SOME cT => Scan.succeed cT
  18.361 +  | NONE => scan_exn ("unknown sort: " ^ quote "bv"))) st
  18.362 +
  18.363 +fun bv_number st =
  18.364 +  (this "bv" |-- bra (nat_num --| $$ ":" -- bv_number_sort) :|-- numb) st
  18.365 +
  18.366 +fun frac_number st = (
  18.367 +  int_num --| $$ "/" -- int_num --| this "::" -- sort :|-- (fn ((i, j), T) =>
  18.368 +    numb (i, T) -- numb (j, T) :|-- (fn (n, m) =>
  18.369 +      appl (Old_Z3_Interface.Sym ("/", []), [n, m])))) st
  18.370 +
  18.371 +fun plain_number st = (int_num --| this "::" -- sort :|-- numb) st
  18.372 +
  18.373 +fun number st = Scan.first [bv_number, frac_number, plain_number] st
  18.374 +
  18.375 +fun constant st = ((sym >> rpair []) :|-- appl) st
  18.376 +
  18.377 +fun expr_id st = (id :|-- (fn i => lookup_context lookup_expr i :|-- (fn
  18.378 +    SOME e => Scan.succeed e
  18.379 +  | NONE => scan_exn ("unknown term id: " ^ quote (string_of_int i))))) st
  18.380 +
  18.381 +fun arg st = Scan.first [expr_id, number, constant] st
  18.382 +
  18.383 +fun application st = par ((sym -- Scan.repeat1 (sep arg)) :|-- appl) st
  18.384 +
  18.385 +fun variables st = par (this "vars" |-- seps1 (par (name |-- sep sort))) st
  18.386 +
  18.387 +fun pats st = seps (par ((this ":pat" || this ":nopat") |-- seps1 id)) st
  18.388 +
  18.389 +val ctrue = Thm.cterm_of @{theory} @{const True}
  18.390 +
  18.391 +fun pattern st = par (this "pattern" |-- Scan.repeat1 (sep arg) >>
  18.392 +  (the o mk_fun (K (SOME ctrue)))) st
  18.393 +
  18.394 +fun quant_kind st = st |> (
  18.395 +  this "forall" >> K (mk_quant true o context_of) ||
  18.396 +  this "exists" >> K (mk_quant false o context_of))
  18.397 +
  18.398 +fun quantifier st =
  18.399 +  (par (quant_kind -- sep variables --| pats -- sep arg) :|--
  18.400 +     lookup_context (fn cx => fn ((mk_q, Ts), body) => mk_q cx Ts body)) st
  18.401 +
  18.402 +fun expr k =
  18.403 +  Scan.first [bound, quantifier, pattern, application, number, constant] :|--
  18.404 +  with_context (pair NONE oo add_expr k)
  18.405 +
  18.406 +val rule_arg = id
  18.407 +  (* if this is modified, then 'th_lemma_arg' needs reviewing *)
  18.408 +
  18.409 +fun th_lemma_arg st = Scan.unless (sep rule_arg >> K "" || $$ rbra) (sep name) st
  18.410 +
  18.411 +fun rule_name st = ((name >> `(Symtab.lookup rule_names)) :|-- (fn 
  18.412 +    (SOME (Th_Lemma _), _) => Scan.repeat th_lemma_arg >> Th_Lemma
  18.413 +  | (SOME r, _) => Scan.succeed r
  18.414 +  | (NONE, n) => scan_exn ("unknown proof rule: " ^ quote n))) st
  18.415 +
  18.416 +fun rule f k =
  18.417 +  bra (rule_name -- seps id) --| $$ ":" -- sep arg #->
  18.418 +  with_context (pair (f k) oo add_proof_step k)
  18.419 +
  18.420 +fun decl st = (this "decl" |-- sep name --| sep (this "::") -- sep sort :|--
  18.421 +  with_context (pair NONE oo add_decl)) st
  18.422 +
  18.423 +fun def st = (id --| sep (this ":=")) st
  18.424 +
  18.425 +fun node st = st |> (
  18.426 +  decl ||
  18.427 +  def :|-- (fn k => sep (expr k) || sep (rule (K NONE) k)) ||
  18.428 +  rule SOME ~1)
  18.429 +
  18.430 +
  18.431 +(** overall parser **)
  18.432 +
  18.433 +(*
  18.434 +  Currently, terms are parsed bottom-up (i.e., along with parsing the proof
  18.435 +  text line by line), but proofs are reconstructed top-down (i.e. by an
  18.436 +  in-order top-down traversal of the proof tree/graph).  The latter approach
  18.437 +  was taken because some proof texts comprise irrelevant proof steps which
  18.438 +  will thus not be reconstructed.  This approach might also be beneficial
  18.439 +  for constructing terms, but it would also increase the complexity of the
  18.440 +  (otherwise rather modular) code.
  18.441 +*)
  18.442 +
  18.443 +fun parse ctxt typs terms proof_text =
  18.444 +  make_context ctxt typs terms
  18.445 +  |> with_info (fold (parse_line node) proof_text)
  18.446 +  |> finish
  18.447 +
  18.448 +end
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_reconstruction.ML	Thu Aug 28 00:40:38 2014 +0200
    19.3 @@ -0,0 +1,888 @@
    19.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_proof_reconstruction.ML
    19.5 +    Author:     Sascha Boehme, TU Muenchen
    19.6 +
    19.7 +Proof reconstruction for proofs found by Z3.
    19.8 +*)
    19.9 +
   19.10 +signature OLD_Z3_PROOF_RECONSTRUCTION =
   19.11 +sig
   19.12 +  val add_z3_rule: thm -> Context.generic -> Context.generic
   19.13 +  val reconstruct: Proof.context -> Old_SMT_Translate.recon -> string list -> int list * thm
   19.14 +end
   19.15 +
   19.16 +structure Old_Z3_Proof_Reconstruction: OLD_Z3_PROOF_RECONSTRUCTION =
   19.17 +struct
   19.18 +
   19.19 +
   19.20 +fun z3_exn msg = raise Old_SMT_Failure.SMT (Old_SMT_Failure.Other_Failure
   19.21 +  ("Z3 proof reconstruction: " ^ msg))
   19.22 +
   19.23 +
   19.24 +
   19.25 +(* net of schematic rules *)
   19.26 +
   19.27 +local
   19.28 +  val description = "declaration of Z3 proof rules"
   19.29 +
   19.30 +  val eq = Thm.eq_thm
   19.31 +
   19.32 +  structure Old_Z3_Rules = Generic_Data
   19.33 +  (
   19.34 +    type T = thm Net.net
   19.35 +    val empty = Net.empty
   19.36 +    val extend = I
   19.37 +    val merge = Net.merge eq
   19.38 +  )
   19.39 +
   19.40 +  fun prep context =
   19.41 +    `Thm.prop_of o rewrite_rule (Context.proof_of context) [Old_Z3_Proof_Literals.rewrite_true]
   19.42 +
   19.43 +  fun ins thm context =
   19.44 +    context |> Old_Z3_Rules.map (fn net => Net.insert_term eq (prep context thm) net handle Net.INSERT => net)
   19.45 +  fun rem thm context =
   19.46 +    context |> Old_Z3_Rules.map (fn net => Net.delete_term eq (prep context thm) net handle Net.DELETE => net)
   19.47 +
   19.48 +  val add = Thm.declaration_attribute ins
   19.49 +  val del = Thm.declaration_attribute rem
   19.50 +in
   19.51 +
   19.52 +val add_z3_rule = ins
   19.53 +
   19.54 +fun by_schematic_rule ctxt ct =
   19.55 +  the (Old_Z3_Proof_Tools.net_instance (Old_Z3_Rules.get (Context.Proof ctxt)) ct)
   19.56 +
   19.57 +val _ = Theory.setup
   19.58 + (Attrib.setup @{binding z3_rule} (Attrib.add_del add del) description #>
   19.59 +  Global_Theory.add_thms_dynamic (@{binding z3_rule}, Net.content o Old_Z3_Rules.get))
   19.60 +
   19.61 +end
   19.62 +
   19.63 +
   19.64 +
   19.65 +(* proof tools *)
   19.66 +
   19.67 +fun named ctxt name prover ct =
   19.68 +  let val _ = Old_SMT_Config.trace_msg ctxt I ("Z3: trying " ^ name ^ " ...")
   19.69 +  in prover ct end
   19.70 +
   19.71 +fun NAMED ctxt name tac i st =
   19.72 +  let val _ = Old_SMT_Config.trace_msg ctxt I ("Z3: trying " ^ name ^ " ...")
   19.73 +  in tac i st end
   19.74 +
   19.75 +fun pretty_goal ctxt thms t =
   19.76 +  [Pretty.block [Pretty.str "proposition: ", Syntax.pretty_term ctxt t]]
   19.77 +  |> not (null thms) ? cons (Pretty.big_list "assumptions:"
   19.78 +       (map (Display.pretty_thm ctxt) thms))
   19.79 +
   19.80 +fun try_apply ctxt thms =
   19.81 +  let
   19.82 +    fun try_apply_err ct = Pretty.string_of (Pretty.chunks [
   19.83 +      Pretty.big_list ("Z3 found a proof," ^
   19.84 +        " but proof reconstruction failed at the following subgoal:")
   19.85 +        (pretty_goal ctxt thms (Thm.term_of ct)),
   19.86 +      Pretty.str ("Declaring a rule as [z3_rule] might solve this problem.")])
   19.87 +
   19.88 +    fun apply [] ct = error (try_apply_err ct)
   19.89 +      | apply (prover :: provers) ct =
   19.90 +          (case try prover ct of
   19.91 +            SOME thm => (Old_SMT_Config.trace_msg ctxt I "Z3: succeeded"; thm)
   19.92 +          | NONE => apply provers ct)
   19.93 +
   19.94 +    fun schematic_label full = "schematic rules" |> full ? suffix " (full)"
   19.95 +    fun schematic ctxt full ct =
   19.96 +      ct
   19.97 +      |> full ? fold_rev (curry Drule.mk_implies o Thm.cprop_of) thms
   19.98 +      |> named ctxt (schematic_label full) (by_schematic_rule ctxt)
   19.99 +      |> fold Thm.elim_implies thms
  19.100 +
  19.101 +  in apply o cons (schematic ctxt false) o cons (schematic ctxt true) end
  19.102 +
  19.103 +local
  19.104 +  val rewr_if =
  19.105 +    @{lemma "(if P then Q1 else Q2) = ((P --> Q1) & (~P --> Q2))" by simp}
  19.106 +in
  19.107 +
  19.108 +fun HOL_fast_tac ctxt =
  19.109 +  Classical.fast_tac (put_claset HOL_cs ctxt)
  19.110 +
  19.111 +fun simp_fast_tac ctxt =
  19.112 +  Simplifier.simp_tac (put_simpset HOL_ss ctxt addsimps [rewr_if])
  19.113 +  THEN_ALL_NEW HOL_fast_tac ctxt
  19.114 +
  19.115 +end
  19.116 +
  19.117 +
  19.118 +
  19.119 +(* theorems and proofs *)
  19.120 +
  19.121 +(** theorem incarnations **)
  19.122 +
  19.123 +datatype theorem =
  19.124 +  Thm of thm | (* theorem without special features *)
  19.125 +  MetaEq of thm | (* meta equality "t == s" *)
  19.126 +  Literals of thm * Old_Z3_Proof_Literals.littab
  19.127 +    (* "P1 & ... & Pn" and table of all literals P1, ..., Pn *)
  19.128 +
  19.129 +fun thm_of (Thm thm) = thm
  19.130 +  | thm_of (MetaEq thm) = thm COMP @{thm meta_eq_to_obj_eq}
  19.131 +  | thm_of (Literals (thm, _)) = thm
  19.132 +
  19.133 +fun meta_eq_of (MetaEq thm) = thm
  19.134 +  | meta_eq_of p = mk_meta_eq (thm_of p)
  19.135 +
  19.136 +fun literals_of (Literals (_, lits)) = lits
  19.137 +  | literals_of p = Old_Z3_Proof_Literals.make_littab [thm_of p]
  19.138 +
  19.139 +
  19.140 +
  19.141 +(** core proof rules **)
  19.142 +
  19.143 +(* assumption *)
  19.144 +
  19.145 +local
  19.146 +  val remove_trigger = mk_meta_eq @{thm trigger_def}
  19.147 +  val remove_weight = mk_meta_eq @{thm weight_def}
  19.148 +  val remove_fun_app = mk_meta_eq @{thm fun_app_def}
  19.149 +
  19.150 +  fun rewrite_conv _ [] = Conv.all_conv
  19.151 +    | rewrite_conv ctxt eqs = Simplifier.full_rewrite (empty_simpset ctxt addsimps eqs)
  19.152 +
  19.153 +  val prep_rules = [@{thm Let_def}, remove_trigger, remove_weight,
  19.154 +    remove_fun_app, Old_Z3_Proof_Literals.rewrite_true]
  19.155 +
  19.156 +  fun rewrite _ [] = I
  19.157 +    | rewrite ctxt eqs = Conv.fconv_rule (rewrite_conv ctxt eqs)
  19.158 +
  19.159 +  fun lookup_assm assms_net ct =
  19.160 +    Old_Z3_Proof_Tools.net_instances assms_net ct
  19.161 +    |> map (fn ithm as (_, thm) => (ithm, Thm.cprop_of thm aconvc ct))
  19.162 +in
  19.163 +
  19.164 +fun add_asserted outer_ctxt rewrite_rules assms asserted ctxt =
  19.165 +  let
  19.166 +    val eqs = map (rewrite ctxt [Old_Z3_Proof_Literals.rewrite_true]) rewrite_rules
  19.167 +    val eqs' = union Thm.eq_thm eqs prep_rules
  19.168 +
  19.169 +    val assms_net =
  19.170 +      assms
  19.171 +      |> map (apsnd (rewrite ctxt eqs'))
  19.172 +      |> map (apsnd (Conv.fconv_rule Thm.eta_conversion))
  19.173 +      |> Old_Z3_Proof_Tools.thm_net_of snd 
  19.174 +
  19.175 +    fun revert_conv ctxt = rewrite_conv ctxt eqs' then_conv Thm.eta_conversion
  19.176 +
  19.177 +    fun assume thm ctxt =
  19.178 +      let
  19.179 +        val ct = Thm.cprem_of thm 1
  19.180 +        val (thm', ctxt') = yield_singleton Assumption.add_assumes ct ctxt
  19.181 +      in (Thm.implies_elim thm thm', ctxt') end
  19.182 +
  19.183 +    fun add1 idx thm1 ((i, th), exact) ((is, thms), (ctxt, ptab)) =
  19.184 +      let
  19.185 +        val (thm, ctxt') =
  19.186 +          if exact then (Thm.implies_elim thm1 th, ctxt)
  19.187 +          else assume thm1 ctxt
  19.188 +        val thms' = if exact then thms else th :: thms
  19.189 +      in 
  19.190 +        ((insert (op =) i is, thms'),
  19.191 +          (ctxt', Inttab.update (idx, Thm thm) ptab))
  19.192 +      end
  19.193 +
  19.194 +    fun add (idx, ct) (cx as ((is, thms), (ctxt, ptab))) =
  19.195 +      let
  19.196 +        val thm1 = 
  19.197 +          Thm.trivial ct
  19.198 +          |> Conv.fconv_rule (Conv.arg1_conv (revert_conv outer_ctxt))
  19.199 +        val thm2 = singleton (Variable.export ctxt outer_ctxt) thm1
  19.200 +      in
  19.201 +        (case lookup_assm assms_net (Thm.cprem_of thm2 1) of
  19.202 +          [] =>
  19.203 +            let val (thm, ctxt') = assume thm1 ctxt
  19.204 +            in ((is, thms), (ctxt', Inttab.update (idx, Thm thm) ptab)) end
  19.205 +        | ithms => fold (add1 idx thm1) ithms cx)
  19.206 +      end
  19.207 +  in fold add asserted (([], []), (ctxt, Inttab.empty)) end
  19.208 +
  19.209 +end
  19.210 +
  19.211 +
  19.212 +(* P = Q ==> P ==> Q   or   P --> Q ==> P ==> Q *)
  19.213 +local
  19.214 +  val precomp = Old_Z3_Proof_Tools.precompose2
  19.215 +  val comp = Old_Z3_Proof_Tools.compose
  19.216 +
  19.217 +  val meta_iffD1 = @{lemma "P == Q ==> P ==> (Q::bool)" by simp}
  19.218 +  val meta_iffD1_c = precomp Thm.dest_binop meta_iffD1
  19.219 +
  19.220 +  val iffD1_c = precomp (Thm.dest_binop o Thm.dest_arg) @{thm iffD1}
  19.221 +  val mp_c = precomp (Thm.dest_binop o Thm.dest_arg) @{thm mp}
  19.222 +in
  19.223 +fun mp (MetaEq thm) p = Thm (Thm.implies_elim (comp meta_iffD1_c thm) p)
  19.224 +  | mp p_q p = 
  19.225 +      let
  19.226 +        val pq = thm_of p_q
  19.227 +        val thm = comp iffD1_c pq handle THM _ => comp mp_c pq
  19.228 +      in Thm (Thm.implies_elim thm p) end
  19.229 +end
  19.230 +
  19.231 +
  19.232 +(* and_elim:     P1 & ... & Pn ==> Pi *)
  19.233 +(* not_or_elim:  ~(P1 | ... | Pn) ==> ~Pi *)
  19.234 +local
  19.235 +  fun is_sublit conj t = Old_Z3_Proof_Literals.exists_lit conj (fn u => u aconv t)
  19.236 +
  19.237 +  fun derive conj t lits idx ptab =
  19.238 +    let
  19.239 +      val lit = the (Old_Z3_Proof_Literals.get_first_lit (is_sublit conj t) lits)
  19.240 +      val ls = Old_Z3_Proof_Literals.explode conj false false [t] lit
  19.241 +      val lits' = fold Old_Z3_Proof_Literals.insert_lit ls
  19.242 +        (Old_Z3_Proof_Literals.delete_lit lit lits)
  19.243 +
  19.244 +      fun upd thm = Literals (thm_of thm, lits')
  19.245 +      val ptab' = Inttab.map_entry idx upd ptab
  19.246 +    in (the (Old_Z3_Proof_Literals.lookup_lit lits' t), ptab') end
  19.247 +
  19.248 +  fun lit_elim conj (p, idx) ct ptab =
  19.249 +    let val lits = literals_of p
  19.250 +    in
  19.251 +      (case Old_Z3_Proof_Literals.lookup_lit lits (Old_SMT_Utils.term_of ct) of
  19.252 +        SOME lit => (Thm lit, ptab)
  19.253 +      | NONE => apfst Thm (derive conj (Old_SMT_Utils.term_of ct) lits idx ptab))
  19.254 +    end
  19.255 +in
  19.256 +val and_elim = lit_elim true
  19.257 +val not_or_elim = lit_elim false
  19.258 +end
  19.259 +
  19.260 +
  19.261 +(* P1, ..., Pn |- False ==> |- ~P1 | ... | ~Pn *)
  19.262 +local
  19.263 +  fun step lit thm =
  19.264 +    Thm.implies_elim (Thm.implies_intr (Thm.cprop_of lit) thm) lit
  19.265 +  val explode_disj = Old_Z3_Proof_Literals.explode false false false
  19.266 +  fun intro hyps thm th = fold step (explode_disj hyps th) thm
  19.267 +
  19.268 +  fun dest_ccontr ct = [Thm.dest_arg (Thm.dest_arg (Thm.dest_arg1 ct))]
  19.269 +  val ccontr = Old_Z3_Proof_Tools.precompose dest_ccontr @{thm ccontr}
  19.270 +in
  19.271 +fun lemma thm ct =
  19.272 +  let
  19.273 +    val cu = Old_Z3_Proof_Literals.negate (Thm.dest_arg ct)
  19.274 +    val hyps = map_filter (try HOLogic.dest_Trueprop) (Thm.hyps_of thm)
  19.275 +    val th = Old_Z3_Proof_Tools.under_assumption (intro hyps thm) cu
  19.276 +  in Thm (Old_Z3_Proof_Tools.compose ccontr th) end
  19.277 +end
  19.278 +
  19.279 +
  19.280 +(* \/{P1, ..., Pn, Q1, ..., Qn}, ~P1, ..., ~Pn ==> \/{Q1, ..., Qn} *)
  19.281 +local
  19.282 +  val explode_disj = Old_Z3_Proof_Literals.explode false true false
  19.283 +  val join_disj = Old_Z3_Proof_Literals.join false
  19.284 +  fun unit thm thms th =
  19.285 +    let
  19.286 +      val t = @{const Not} $ Old_SMT_Utils.prop_of thm
  19.287 +      val ts = map Old_SMT_Utils.prop_of thms
  19.288 +    in
  19.289 +      join_disj (Old_Z3_Proof_Literals.make_littab (thms @ explode_disj ts th)) t
  19.290 +    end
  19.291 +
  19.292 +  fun dest_arg2 ct = Thm.dest_arg (Thm.dest_arg ct)
  19.293 +  fun dest ct = pairself dest_arg2 (Thm.dest_binop ct)
  19.294 +  val contrapos =
  19.295 +    Old_Z3_Proof_Tools.precompose2 dest @{lemma "(~P ==> ~Q) ==> Q ==> P" by fast}
  19.296 +in
  19.297 +fun unit_resolution thm thms ct =
  19.298 +  Old_Z3_Proof_Literals.negate (Thm.dest_arg ct)
  19.299 +  |> Old_Z3_Proof_Tools.under_assumption (unit thm thms)
  19.300 +  |> Thm o Old_Z3_Proof_Tools.discharge thm o Old_Z3_Proof_Tools.compose contrapos
  19.301 +end
  19.302 +
  19.303 +
  19.304 +(* P ==> P == True   or   P ==> P == False *)
  19.305 +local
  19.306 +  val iff1 = @{lemma "P ==> P == (~ False)" by simp}
  19.307 +  val iff2 = @{lemma "~P ==> P == False" by simp}
  19.308 +in
  19.309 +fun iff_true thm = MetaEq (thm COMP iff1)
  19.310 +fun iff_false thm = MetaEq (thm COMP iff2)
  19.311 +end
  19.312 +
  19.313 +
  19.314 +(* distributivity of | over & *)
  19.315 +fun distributivity ctxt = Thm o try_apply ctxt [] [
  19.316 +  named ctxt "fast" (Old_Z3_Proof_Tools.by_tac ctxt (HOL_fast_tac ctxt))]
  19.317 +    (* FIXME: not very well tested *)
  19.318 +
  19.319 +
  19.320 +(* Tseitin-like axioms *)
  19.321 +local
  19.322 +  val disjI1 = @{lemma "(P ==> Q) ==> ~P | Q" by fast}
  19.323 +  val disjI2 = @{lemma "(~P ==> Q) ==> P | Q" by fast}
  19.324 +  val disjI3 = @{lemma "(~Q ==> P) ==> P | Q" by fast}
  19.325 +  val disjI4 = @{lemma "(Q ==> P) ==> P | ~Q" by fast}
  19.326 +
  19.327 +  fun prove' conj1 conj2 ct2 thm =
  19.328 +    let
  19.329 +      val littab =
  19.330 +        Old_Z3_Proof_Literals.explode conj1 true (conj1 <> conj2) [] thm
  19.331 +        |> cons Old_Z3_Proof_Literals.true_thm
  19.332 +        |> Old_Z3_Proof_Literals.make_littab
  19.333 +    in Old_Z3_Proof_Literals.join conj2 littab (Thm.term_of ct2) end
  19.334 +
  19.335 +  fun prove rule (ct1, conj1) (ct2, conj2) =
  19.336 +    Old_Z3_Proof_Tools.under_assumption (prove' conj1 conj2 ct2) ct1 COMP rule
  19.337 +
  19.338 +  fun prove_def_axiom ct =
  19.339 +    let val (ct1, ct2) = Thm.dest_binop (Thm.dest_arg ct)
  19.340 +    in
  19.341 +      (case Thm.term_of ct1 of
  19.342 +        @{const Not} $ (@{const HOL.conj} $ _ $ _) =>
  19.343 +          prove disjI1 (Thm.dest_arg ct1, true) (ct2, true)
  19.344 +      | @{const HOL.conj} $ _ $ _ =>
  19.345 +          prove disjI3 (Old_Z3_Proof_Literals.negate ct2, false) (ct1, true)
  19.346 +      | @{const Not} $ (@{const HOL.disj} $ _ $ _) =>
  19.347 +          prove disjI3 (Old_Z3_Proof_Literals.negate ct2, false) (ct1, false)
  19.348 +      | @{const HOL.disj} $ _ $ _ =>
  19.349 +          prove disjI2 (Old_Z3_Proof_Literals.negate ct1, false) (ct2, true)
  19.350 +      | Const (@{const_name distinct}, _) $ _ =>
  19.351 +          let
  19.352 +            fun dis_conv cv = Conv.arg_conv (Conv.arg1_conv cv)
  19.353 +            val unfold_dis_conv = dis_conv Old_Z3_Proof_Tools.unfold_distinct_conv
  19.354 +            fun prv cu =
  19.355 +              let val (cu1, cu2) = Thm.dest_binop (Thm.dest_arg cu)
  19.356 +              in prove disjI4 (Thm.dest_arg cu2, true) (cu1, true) end
  19.357 +          in Old_Z3_Proof_Tools.with_conv unfold_dis_conv prv ct end
  19.358 +      | @{const Not} $ (Const (@{const_name distinct}, _) $ _) =>
  19.359 +          let
  19.360 +            fun dis_conv cv = Conv.arg_conv (Conv.arg1_conv (Conv.arg_conv cv))
  19.361 +            val unfold_dis_conv = dis_conv Old_Z3_Proof_Tools.unfold_distinct_conv
  19.362 +            fun prv cu =
  19.363 +              let val (cu1, cu2) = Thm.dest_binop (Thm.dest_arg cu)
  19.364 +              in prove disjI1 (Thm.dest_arg cu1, true) (cu2, true) end
  19.365 +          in Old_Z3_Proof_Tools.with_conv unfold_dis_conv prv ct end
  19.366 +      | _ => raise CTERM ("prove_def_axiom", [ct]))
  19.367 +    end
  19.368 +in
  19.369 +fun def_axiom ctxt = Thm o try_apply ctxt [] [
  19.370 +  named ctxt "conj/disj/distinct" prove_def_axiom,
  19.371 +  Old_Z3_Proof_Tools.by_abstraction 0 (true, false) ctxt [] (fn ctxt' =>
  19.372 +    named ctxt' "simp+fast" (Old_Z3_Proof_Tools.by_tac ctxt (simp_fast_tac ctxt')))]
  19.373 +end
  19.374 +
  19.375 +
  19.376 +(* local definitions *)
  19.377 +local
  19.378 +  val intro_rules = [
  19.379 +    @{lemma "n == P ==> (~n | P) & (n | ~P)" by simp},
  19.380 +    @{lemma "n == (if P then s else t) ==> (~P | n = s) & (P | n = t)"
  19.381 +      by simp},
  19.382 +    @{lemma "n == P ==> n = P" by (rule meta_eq_to_obj_eq)} ]
  19.383 +
  19.384 +  val apply_rules = [
  19.385 +    @{lemma "(~n | P) & (n | ~P) ==> P == n" by (atomize(full)) fast},
  19.386 +    @{lemma "(~P | n = s) & (P | n = t) ==> (if P then s else t) == n"
  19.387 +      by (atomize(full)) fastforce} ]
  19.388 +
  19.389 +  val inst_rule = Old_Z3_Proof_Tools.match_instantiate Thm.dest_arg
  19.390 +
  19.391 +  fun apply_rule ct =
  19.392 +    (case get_first (try (inst_rule ct)) intro_rules of
  19.393 +      SOME thm => thm
  19.394 +    | NONE => raise CTERM ("intro_def", [ct]))
  19.395 +in
  19.396 +fun intro_def ct = Old_Z3_Proof_Tools.make_hyp_def (apply_rule ct) #>> Thm
  19.397 +
  19.398 +fun apply_def thm =
  19.399 +  get_first (try (fn rule => MetaEq (thm COMP rule))) apply_rules
  19.400 +  |> the_default (Thm thm)
  19.401 +end
  19.402 +
  19.403 +
  19.404 +(* negation normal form *)
  19.405 +local
  19.406 +  val quant_rules1 = ([
  19.407 +    @{lemma "(!!x. P x == Q) ==> ALL x. P x == Q" by simp},
  19.408 +    @{lemma "(!!x. P x == Q) ==> EX x. P x == Q" by simp}], [
  19.409 +    @{lemma "(!!x. P x == Q x) ==> ALL x. P x == ALL x. Q x" by simp},
  19.410 +    @{lemma "(!!x. P x == Q x) ==> EX x. P x == EX x. Q x" by simp}])
  19.411 +
  19.412 +  val quant_rules2 = ([
  19.413 +    @{lemma "(!!x. ~P x == Q) ==> ~(ALL x. P x) == Q" by simp},
  19.414 +    @{lemma "(!!x. ~P x == Q) ==> ~(EX x. P x) == Q" by simp}], [
  19.415 +    @{lemma "(!!x. ~P x == Q x) ==> ~(ALL x. P x) == EX x. Q x" by simp},
  19.416 +    @{lemma "(!!x. ~P x == Q x) ==> ~(EX x. P x) == ALL x. Q x" by simp}])
  19.417 +
  19.418 +  fun nnf_quant_tac thm (qs as (qs1, qs2)) i st = (
  19.419 +    rtac thm ORELSE'
  19.420 +    (match_tac qs1 THEN' nnf_quant_tac thm qs) ORELSE'
  19.421 +    (match_tac qs2 THEN' nnf_quant_tac thm qs)) i st
  19.422 +
  19.423 +  fun nnf_quant_tac_varified vars eq =
  19.424 +    nnf_quant_tac (Old_Z3_Proof_Tools.varify vars eq)
  19.425 +
  19.426 +  fun nnf_quant ctxt vars qs p ct =
  19.427 +    Old_Z3_Proof_Tools.as_meta_eq ct
  19.428 +    |> Old_Z3_Proof_Tools.by_tac ctxt (nnf_quant_tac_varified vars (meta_eq_of p) qs)
  19.429 +
  19.430 +  fun prove_nnf ctxt = try_apply ctxt [] [
  19.431 +    named ctxt "conj/disj" Old_Z3_Proof_Literals.prove_conj_disj_eq,
  19.432 +    Old_Z3_Proof_Tools.by_abstraction 0 (true, false) ctxt [] (fn ctxt' =>
  19.433 +      named ctxt' "simp+fast" (Old_Z3_Proof_Tools.by_tac ctxt' (simp_fast_tac ctxt')))]
  19.434 +in
  19.435 +fun nnf ctxt vars ps ct =
  19.436 +  (case Old_SMT_Utils.term_of ct of
  19.437 +    _ $ (l as Const _ $ Abs _) $ (r as Const _ $ Abs _) =>
  19.438 +      if l aconv r
  19.439 +      then MetaEq (Thm.reflexive (Thm.dest_arg (Thm.dest_arg ct)))
  19.440 +      else MetaEq (nnf_quant ctxt vars quant_rules1 (hd ps) ct)
  19.441 +  | _ $ (@{const Not} $ (Const _ $ Abs _)) $ (Const _ $ Abs _) =>
  19.442 +      MetaEq (nnf_quant ctxt vars quant_rules2 (hd ps) ct)
  19.443 +  | _ =>
  19.444 +      let
  19.445 +        val nnf_rewr_conv = Conv.arg_conv (Conv.arg_conv
  19.446 +          (Old_Z3_Proof_Tools.unfold_eqs ctxt
  19.447 +            (map (Thm.symmetric o meta_eq_of) ps)))
  19.448 +      in Thm (Old_Z3_Proof_Tools.with_conv nnf_rewr_conv (prove_nnf ctxt) ct) end)
  19.449 +end
  19.450 +
  19.451 +
  19.452 +
  19.453 +(** equality proof rules **)
  19.454 +
  19.455 +(* |- t = t *)
  19.456 +fun refl ct = MetaEq (Thm.reflexive (Thm.dest_arg (Thm.dest_arg ct)))
  19.457 +
  19.458 +
  19.459 +(* s = t ==> t = s *)
  19.460 +local
  19.461 +  val symm_rule = @{lemma "s = t ==> t == s" by simp}
  19.462 +in
  19.463 +fun symm (MetaEq thm) = MetaEq (Thm.symmetric thm)
  19.464 +  | symm p = MetaEq (thm_of p COMP symm_rule)
  19.465 +end
  19.466 +
  19.467 +
  19.468 +(* s = t ==> t = u ==> s = u *)
  19.469 +local
  19.470 +  val trans1 = @{lemma "s == t ==> t =  u ==> s == u" by simp}
  19.471 +  val trans2 = @{lemma "s =  t ==> t == u ==> s == u" by simp}
  19.472 +  val trans3 = @{lemma "s =  t ==> t =  u ==> s == u" by simp}
  19.473 +in
  19.474 +fun trans (MetaEq thm1) (MetaEq thm2) = MetaEq (Thm.transitive thm1 thm2)
  19.475 +  | trans (MetaEq thm) q = MetaEq (thm_of q COMP (thm COMP trans1))
  19.476 +  | trans p (MetaEq thm) = MetaEq (thm COMP (thm_of p COMP trans2))
  19.477 +  | trans p q = MetaEq (thm_of q COMP (thm_of p COMP trans3))
  19.478 +end
  19.479 +
  19.480 +
  19.481 +(* t1 = s1 ==> ... ==> tn = sn ==> f t1 ... tn = f s1 .. sn
  19.482 +   (reflexive antecendents are droppped) *)
  19.483 +local
  19.484 +  exception MONO
  19.485 +
  19.486 +  fun prove_refl (ct, _) = Thm.reflexive ct
  19.487 +  fun prove_comb f g cp =
  19.488 +    let val ((ct1, ct2), (cu1, cu2)) = pairself Thm.dest_comb cp
  19.489 +    in Thm.combination (f (ct1, cu1)) (g (ct2, cu2)) end
  19.490 +  fun prove_arg f = prove_comb prove_refl f
  19.491 +
  19.492 +  fun prove f cp = prove_comb (prove f) f cp handle CTERM _ => prove_refl cp
  19.493 +
  19.494 +  fun prove_nary is_comb f =
  19.495 +    let
  19.496 +      fun prove (cp as (ct, _)) = f cp handle MONO =>
  19.497 +        if is_comb (Thm.term_of ct)
  19.498 +        then prove_comb (prove_arg prove) prove cp
  19.499 +        else prove_refl cp
  19.500 +    in prove end
  19.501 +
  19.502 +  fun prove_list f n cp =
  19.503 +    if n = 0 then prove_refl cp
  19.504 +    else prove_comb (prove_arg f) (prove_list f (n-1)) cp
  19.505 +
  19.506 +  fun with_length f (cp as (cl, _)) =
  19.507 +    f (length (HOLogic.dest_list (Thm.term_of cl))) cp
  19.508 +
  19.509 +  fun prove_distinct f = prove_arg (with_length (prove_list f))
  19.510 +
  19.511 +  fun prove_eq exn lookup cp =
  19.512 +    (case lookup (Logic.mk_equals (pairself Thm.term_of cp)) of
  19.513 +      SOME eq => eq
  19.514 +    | NONE => if exn then raise MONO else prove_refl cp)
  19.515 +  
  19.516 +  val prove_exn = prove_eq true
  19.517 +  and prove_safe = prove_eq false
  19.518 +
  19.519 +  fun mono f (cp as (cl, _)) =
  19.520 +    (case Term.head_of (Thm.term_of cl) of
  19.521 +      @{const HOL.conj} => prove_nary Old_Z3_Proof_Literals.is_conj (prove_exn f)
  19.522 +    | @{const HOL.disj} => prove_nary Old_Z3_Proof_Literals.is_disj (prove_exn f)
  19.523 +    | Const (@{const_name distinct}, _) => prove_distinct (prove_safe f)
  19.524 +    | _ => prove (prove_safe f)) cp
  19.525 +in
  19.526 +fun monotonicity eqs ct =
  19.527 +  let
  19.528 +    fun and_symmetric (t, thm) = [(t, thm), (t, Thm.symmetric thm)]
  19.529 +    val teqs = maps (and_symmetric o `Thm.prop_of o meta_eq_of) eqs
  19.530 +    val lookup = AList.lookup (op aconv) teqs
  19.531 +    val cp = Thm.dest_binop (Thm.dest_arg ct)
  19.532 +  in MetaEq (prove_exn lookup cp handle MONO => mono lookup cp) end
  19.533 +end
  19.534 +
  19.535 +
  19.536 +(* |- f a b = f b a (where f is equality) *)
  19.537 +local
  19.538 +  val rule = @{lemma "a = b == b = a" by (atomize(full)) (rule eq_commute)}
  19.539 +in
  19.540 +fun commutativity ct =
  19.541 +  MetaEq (Old_Z3_Proof_Tools.match_instantiate I
  19.542 +    (Old_Z3_Proof_Tools.as_meta_eq ct) rule)
  19.543 +end
  19.544 +
  19.545 +
  19.546 +
  19.547 +(** quantifier proof rules **)
  19.548 +
  19.549 +(* P ?x = Q ?x ==> (ALL x. P x) = (ALL x. Q x)
  19.550 +   P ?x = Q ?x ==> (EX x. P x) = (EX x. Q x)    *)
  19.551 +local
  19.552 +  val rules = [
  19.553 +    @{lemma "(!!x. P x == Q x) ==> (ALL x. P x) == (ALL x. Q x)" by simp},
  19.554 +    @{lemma "(!!x. P x == Q x) ==> (EX x. P x) == (EX x. Q x)" by simp}]
  19.555 +in
  19.556 +fun quant_intro ctxt vars p ct =
  19.557 +  let
  19.558 +    val thm = meta_eq_of p
  19.559 +    val rules' = Old_Z3_Proof_Tools.varify vars thm :: rules
  19.560 +    val cu = Old_Z3_Proof_Tools.as_meta_eq ct
  19.561 +    val tac = REPEAT_ALL_NEW (match_tac rules')
  19.562 +  in MetaEq (Old_Z3_Proof_Tools.by_tac ctxt tac cu) end
  19.563 +end
  19.564 +
  19.565 +
  19.566 +(* |- ((ALL x. P x) | Q) = (ALL x. P x | Q) *)
  19.567 +fun pull_quant ctxt = Thm o try_apply ctxt [] [
  19.568 +  named ctxt "fast" (Old_Z3_Proof_Tools.by_tac ctxt (HOL_fast_tac ctxt))]
  19.569 +    (* FIXME: not very well tested *)
  19.570 +
  19.571 +
  19.572 +(* |- (ALL x. P x & Q x) = ((ALL x. P x) & (ALL x. Q x)) *)
  19.573 +fun push_quant ctxt = Thm o try_apply ctxt [] [
  19.574 +  named ctxt "fast" (Old_Z3_Proof_Tools.by_tac ctxt (HOL_fast_tac ctxt))]
  19.575 +    (* FIXME: not very well tested *)
  19.576 +
  19.577 +
  19.578 +(* |- (ALL x1 ... xn y1 ... yn. P x1 ... xn) = (ALL x1 ... xn. P x1 ... xn) *)
  19.579 +local
  19.580 +  val elim_all = @{lemma "P = Q ==> (ALL x. P) = Q" by fast}
  19.581 +  val elim_ex = @{lemma "P = Q ==> (EX x. P) = Q" by fast}
  19.582 +
  19.583 +  fun elim_unused_tac i st = (
  19.584 +    match_tac [@{thm refl}]
  19.585 +    ORELSE' (match_tac [elim_all, elim_ex] THEN' elim_unused_tac)
  19.586 +    ORELSE' (
  19.587 +      match_tac [@{thm iff_allI}, @{thm iff_exI}]
  19.588 +      THEN' elim_unused_tac)) i st
  19.589 +in
  19.590 +
  19.591 +fun elim_unused_vars ctxt = Thm o Old_Z3_Proof_Tools.by_tac ctxt elim_unused_tac
  19.592 +
  19.593 +end
  19.594 +
  19.595 +
  19.596 +(* |- (ALL x1 ... xn. ~(x1 = t1 & ... xn = tn) | P x1 ... xn) = P t1 ... tn *)
  19.597 +fun dest_eq_res ctxt = Thm o try_apply ctxt [] [
  19.598 +  named ctxt "fast" (Old_Z3_Proof_Tools.by_tac ctxt (HOL_fast_tac ctxt))]
  19.599 +    (* FIXME: not very well tested *)
  19.600 +
  19.601 +
  19.602 +(* |- ~(ALL x1...xn. P x1...xn) | P a1...an *)
  19.603 +local
  19.604 +  val rule = @{lemma "~ P x | Q ==> ~(ALL x. P x) | Q" by fast}
  19.605 +in
  19.606 +fun quant_inst ctxt = Thm o Old_Z3_Proof_Tools.by_tac ctxt (
  19.607 +  REPEAT_ALL_NEW (match_tac [rule])
  19.608 +  THEN' rtac @{thm excluded_middle})
  19.609 +end
  19.610 +
  19.611 +
  19.612 +(* |- (EX x. P x) = P c     |- ~(ALL x. P x) = ~ P c *)
  19.613 +local
  19.614 +  val forall =
  19.615 +    Old_SMT_Utils.mk_const_pat @{theory} @{const_name Pure.all}
  19.616 +      (Old_SMT_Utils.destT1 o Old_SMT_Utils.destT1)
  19.617 +  fun mk_forall cv ct =
  19.618 +    Thm.apply (Old_SMT_Utils.instT' cv forall) (Thm.lambda cv ct)
  19.619 +
  19.620 +  fun get_vars f mk pred ctxt t =
  19.621 +    Term.fold_aterms f t []
  19.622 +    |> map_filter (fn v =>
  19.623 +         if pred v then SOME (Old_SMT_Utils.certify ctxt (mk v)) else NONE)
  19.624 +
  19.625 +  fun close vars f ct ctxt =
  19.626 +    let
  19.627 +      val frees_of = get_vars Term.add_frees Free (member (op =) vars o fst)
  19.628 +      val vs = frees_of ctxt (Thm.term_of ct)
  19.629 +      val (thm, ctxt') = f (fold_rev mk_forall vs ct) ctxt
  19.630 +      val vars_of = get_vars Term.add_vars Var (K true) ctxt'
  19.631 +    in (Thm.instantiate ([], vars_of (Thm.prop_of thm) ~~ vs) thm, ctxt') end
  19.632 +
  19.633 +  val sk_rules = @{lemma
  19.634 +    "c = (SOME x. P x) ==> (EX x. P x) = P c"
  19.635 +    "c = (SOME x. ~P x) ==> (~(ALL x. P x)) = (~P c)"
  19.636 +    by (metis someI_ex)+}
  19.637 +in
  19.638 +
  19.639 +fun skolemize vars =
  19.640 +  apfst Thm oo close vars (yield_singleton Assumption.add_assumes)
  19.641 +
  19.642 +fun discharge_sk_tac i st = (
  19.643 +  rtac @{thm trans} i
  19.644 +  THEN resolve_tac sk_rules i
  19.645 +  THEN (rtac @{thm refl} ORELSE' discharge_sk_tac) (i+1)
  19.646 +  THEN rtac @{thm refl} i) st
  19.647 +
  19.648 +end
  19.649 +
  19.650 +
  19.651 +
  19.652 +(** theory proof rules **)
  19.653 +
  19.654 +(* theory lemmas: linear arithmetic, arrays *)
  19.655 +fun th_lemma ctxt simpset thms = Thm o try_apply ctxt thms [
  19.656 +  Old_Z3_Proof_Tools.by_abstraction 0 (false, true) ctxt thms (fn ctxt' =>
  19.657 +    Old_Z3_Proof_Tools.by_tac ctxt' (
  19.658 +      NAMED ctxt' "arith" (Arith_Data.arith_tac ctxt')
  19.659 +      ORELSE' NAMED ctxt' "simp+arith" (
  19.660 +        Simplifier.asm_full_simp_tac (put_simpset simpset ctxt')
  19.661 +        THEN_ALL_NEW Arith_Data.arith_tac ctxt')))]
  19.662 +
  19.663 +
  19.664 +(* rewriting: prove equalities:
  19.665 +     * ACI of conjunction/disjunction
  19.666 +     * contradiction, excluded middle
  19.667 +     * logical rewriting rules (for negation, implication, equivalence,
  19.668 +         distinct)
  19.669 +     * normal forms for polynoms (integer/real arithmetic)
  19.670 +     * quantifier elimination over linear arithmetic
  19.671 +     * ... ? **)
  19.672 +local
  19.673 +  fun spec_meta_eq_of thm =
  19.674 +    (case try (fn th => th RS @{thm spec}) thm of
  19.675 +      SOME thm' => spec_meta_eq_of thm'
  19.676 +    | NONE => mk_meta_eq thm)
  19.677 +
  19.678 +  fun prep (Thm thm) = spec_meta_eq_of thm
  19.679 +    | prep (MetaEq thm) = thm
  19.680 +    | prep (Literals (thm, _)) = spec_meta_eq_of thm
  19.681 +
  19.682 +  fun unfold_conv ctxt ths =
  19.683 +    Conv.arg_conv (Conv.binop_conv (Old_Z3_Proof_Tools.unfold_eqs ctxt
  19.684 +      (map prep ths)))
  19.685 +
  19.686 +  fun with_conv _ [] prv = prv
  19.687 +    | with_conv ctxt ths prv =
  19.688 +        Old_Z3_Proof_Tools.with_conv (unfold_conv ctxt ths) prv
  19.689 +
  19.690 +  val unfold_conv =
  19.691 +    Conv.arg_conv (Conv.binop_conv
  19.692 +      (Conv.try_conv Old_Z3_Proof_Tools.unfold_distinct_conv))
  19.693 +  val prove_conj_disj_eq =
  19.694 +    Old_Z3_Proof_Tools.with_conv unfold_conv Old_Z3_Proof_Literals.prove_conj_disj_eq
  19.695 +
  19.696 +  fun declare_hyps ctxt thm =
  19.697 +    (thm, snd (Assumption.add_assumes (#hyps (Thm.crep_thm thm)) ctxt))
  19.698 +in
  19.699 +
  19.700 +val abstraction_depth = 3
  19.701 +  (*
  19.702 +    This value was chosen large enough to potentially catch exceptions,
  19.703 +    yet small enough to not cause too much harm.  The value might be
  19.704 +    increased in the future, if reconstructing 'rewrite' fails on problems
  19.705 +    that get too much abstracted to be reconstructable.
  19.706 +  *)
  19.707 +
  19.708 +fun rewrite simpset ths ct ctxt =
  19.709 +  apfst Thm (declare_hyps ctxt (with_conv ctxt ths (try_apply ctxt [] [
  19.710 +    named ctxt "conj/disj/distinct" prove_conj_disj_eq,
  19.711 +    named ctxt "pull-ite" Old_Z3_Proof_Methods.prove_ite ctxt,
  19.712 +    Old_Z3_Proof_Tools.by_abstraction 0 (true, false) ctxt [] (fn ctxt' =>
  19.713 +      Old_Z3_Proof_Tools.by_tac ctxt' (
  19.714 +        NAMED ctxt' "simp (logic)" (Simplifier.simp_tac (put_simpset simpset ctxt'))
  19.715 +        THEN_ALL_NEW NAMED ctxt' "fast (logic)" (fast_tac ctxt'))),
  19.716 +    Old_Z3_Proof_Tools.by_abstraction 0 (false, true) ctxt [] (fn ctxt' =>
  19.717 +      Old_Z3_Proof_Tools.by_tac ctxt' (
  19.718 +        (rtac @{thm iff_allI} ORELSE' K all_tac)
  19.719 +        THEN' NAMED ctxt' "simp (theory)" (Simplifier.simp_tac (put_simpset simpset ctxt'))
  19.720 +        THEN_ALL_NEW (
  19.721 +          NAMED ctxt' "fast (theory)" (HOL_fast_tac ctxt')
  19.722 +          ORELSE' NAMED ctxt' "arith (theory)" (Arith_Data.arith_tac ctxt')))),
  19.723 +    Old_Z3_Proof_Tools.by_abstraction 0 (true, true) ctxt [] (fn ctxt' =>
  19.724 +      Old_Z3_Proof_Tools.by_tac ctxt' (
  19.725 +        (rtac @{thm iff_allI} ORELSE' K all_tac)
  19.726 +        THEN' NAMED ctxt' "simp (full)" (Simplifier.simp_tac (put_simpset simpset ctxt'))
  19.727 +        THEN_ALL_NEW (
  19.728 +          NAMED ctxt' "fast (full)" (HOL_fast_tac ctxt')
  19.729 +          ORELSE' NAMED ctxt' "arith (full)" (Arith_Data.arith_tac ctxt')))),
  19.730 +    named ctxt "injectivity" (Old_Z3_Proof_Methods.prove_injectivity ctxt),
  19.731 +    Old_Z3_Proof_Tools.by_abstraction abstraction_depth (true, true) ctxt []
  19.732 +      (fn ctxt' =>
  19.733 +        Old_Z3_Proof_Tools.by_tac ctxt' (
  19.734 +          (rtac @{thm iff_allI} ORELSE' K all_tac)
  19.735 +          THEN' NAMED ctxt' "simp (deepen)" (Simplifier.simp_tac (put_simpset simpset ctxt'))
  19.736 +          THEN_ALL_NEW (
  19.737 +            NAMED ctxt' "fast (deepen)" (HOL_fast_tac ctxt')
  19.738 +            ORELSE' NAMED ctxt' "arith (deepen)" (Arith_Data.arith_tac
  19.739 +              ctxt'))))]) ct))
  19.740 +
  19.741 +end
  19.742 +
  19.743 +
  19.744 +
  19.745 +(* proof reconstruction *)
  19.746 +
  19.747 +(** tracing and checking **)
  19.748 +
  19.749 +fun trace_before ctxt idx = Old_SMT_Config.trace_msg ctxt (fn r =>
  19.750 +  "Z3: #" ^ string_of_int idx ^ ": " ^ Old_Z3_Proof_Parser.string_of_rule r)
  19.751 +
  19.752 +fun check_after idx r ps ct (p, (ctxt, _)) =
  19.753 +  if not (Config.get ctxt Old_SMT_Config.trace) then ()
  19.754 +  else
  19.755 +    let val thm = thm_of p |> tap (Thm.join_proofs o single)
  19.756 +    in
  19.757 +      if (Thm.cprop_of thm) aconvc ct then ()
  19.758 +      else
  19.759 +        z3_exn (Pretty.string_of (Pretty.big_list
  19.760 +          ("proof step failed: " ^ quote (Old_Z3_Proof_Parser.string_of_rule r) ^
  19.761 +            " (#" ^ string_of_int idx ^ ")")
  19.762 +          (pretty_goal ctxt (map (thm_of o fst) ps) (Thm.prop_of thm) @
  19.763 +            [Pretty.block [Pretty.str "expected: ",
  19.764 +              Syntax.pretty_term ctxt (Thm.term_of ct)]])))
  19.765 +    end
  19.766 +
  19.767 +
  19.768 +(** overall reconstruction procedure **)
  19.769 +
  19.770 +local
  19.771 +  fun not_supported r = raise Fail ("Z3: proof rule not implemented: " ^
  19.772 +    quote (Old_Z3_Proof_Parser.string_of_rule r))
  19.773 +
  19.774 +  fun prove_step simpset vars r ps ct (cxp as (cx, ptab)) =
  19.775 +    (case (r, ps) of
  19.776 +      (* core rules *)
  19.777 +      (Old_Z3_Proof_Parser.True_Axiom, _) => (Thm Old_Z3_Proof_Literals.true_thm, cxp)
  19.778 +    | (Old_Z3_Proof_Parser.Asserted, _) => raise Fail "bad assertion"
  19.779 +    | (Old_Z3_Proof_Parser.Goal, _) => raise Fail "bad assertion"
  19.780 +    | (Old_Z3_Proof_Parser.Modus_Ponens, [(p, _), (q, _)]) =>
  19.781 +        (mp q (thm_of p), cxp)
  19.782 +    | (Old_Z3_Proof_Parser.Modus_Ponens_Oeq, [(p, _), (q, _)]) =>
  19.783 +        (mp q (thm_of p), cxp)
  19.784 +    | (Old_Z3_Proof_Parser.And_Elim, [(p, i)]) =>
  19.785 +        and_elim (p, i) ct ptab ||> pair cx
  19.786 +    | (Old_Z3_Proof_Parser.Not_Or_Elim, [(p, i)]) =>
  19.787 +        not_or_elim (p, i) ct ptab ||> pair cx
  19.788 +    | (Old_Z3_Proof_Parser.Hypothesis, _) => (Thm (Thm.assume ct), cxp)
  19.789 +    | (Old_Z3_Proof_Parser.Lemma, [(p, _)]) => (lemma (thm_of p) ct, cxp)
  19.790 +    | (Old_Z3_Proof_Parser.Unit_Resolution, (p, _) :: ps) =>
  19.791 +        (unit_resolution (thm_of p) (map (thm_of o fst) ps) ct, cxp)
  19.792 +    | (Old_Z3_Proof_Parser.Iff_True, [(p, _)]) => (iff_true (thm_of p), cxp)
  19.793 +    | (Old_Z3_Proof_Parser.Iff_False, [(p, _)]) => (iff_false (thm_of p), cxp)
  19.794 +    | (Old_Z3_Proof_Parser.Distributivity, _) => (distributivity cx ct, cxp)
  19.795 +    | (Old_Z3_Proof_Parser.Def_Axiom, _) => (def_axiom cx ct, cxp)
  19.796 +    | (Old_Z3_Proof_Parser.Intro_Def, _) => intro_def ct cx ||> rpair ptab
  19.797 +    | (Old_Z3_Proof_Parser.Apply_Def, [(p, _)]) => (apply_def (thm_of p), cxp)
  19.798 +    | (Old_Z3_Proof_Parser.Iff_Oeq, [(p, _)]) => (p, cxp)
  19.799 +    | (Old_Z3_Proof_Parser.Nnf_Pos, _) => (nnf cx vars (map fst ps) ct, cxp)
  19.800 +    | (Old_Z3_Proof_Parser.Nnf_Neg, _) => (nnf cx vars (map fst ps) ct, cxp)
  19.801 +
  19.802 +      (* equality rules *)
  19.803 +    | (Old_Z3_Proof_Parser.Reflexivity, _) => (refl ct, cxp)
  19.804 +    | (Old_Z3_Proof_Parser.Symmetry, [(p, _)]) => (symm p, cxp)
  19.805 +    | (Old_Z3_Proof_Parser.Transitivity, [(p, _), (q, _)]) => (trans p q, cxp)
  19.806 +    | (Old_Z3_Proof_Parser.Monotonicity, _) => (monotonicity (map fst ps) ct, cxp)
  19.807 +    | (Old_Z3_Proof_Parser.Commutativity, _) => (commutativity ct, cxp)
  19.808 +
  19.809 +      (* quantifier rules *)
  19.810 +    | (Old_Z3_Proof_Parser.Quant_Intro, [(p, _)]) => (quant_intro cx vars p ct, cxp)
  19.811 +    | (Old_Z3_Proof_Parser.Pull_Quant, _) => (pull_quant cx ct, cxp)
  19.812 +    | (Old_Z3_Proof_Parser.Push_Quant, _) => (push_quant cx ct, cxp)
  19.813 +    | (Old_Z3_Proof_Parser.Elim_Unused_Vars, _) => (elim_unused_vars cx ct, cxp)
  19.814 +    | (Old_Z3_Proof_Parser.Dest_Eq_Res, _) => (dest_eq_res cx ct, cxp)
  19.815 +    | (Old_Z3_Proof_Parser.Quant_Inst, _) => (quant_inst cx ct, cxp)
  19.816 +    | (Old_Z3_Proof_Parser.Skolemize, _) => skolemize vars ct cx ||> rpair ptab
  19.817 +
  19.818 +      (* theory rules *)
  19.819 +    | (Old_Z3_Proof_Parser.Th_Lemma _, _) =>  (* FIXME: use arguments *)
  19.820 +        (th_lemma cx simpset (map (thm_of o fst) ps) ct, cxp)
  19.821 +    | (Old_Z3_Proof_Parser.Rewrite, _) => rewrite simpset [] ct cx ||> rpair ptab
  19.822 +    | (Old_Z3_Proof_Parser.Rewrite_Star, ps) =>
  19.823 +        rewrite simpset (map fst ps) ct cx ||> rpair ptab
  19.824 +
  19.825 +    | (Old_Z3_Proof_Parser.Nnf_Star, _) => not_supported r
  19.826 +    | (Old_Z3_Proof_Parser.Cnf_Star, _) => not_supported r
  19.827 +    | (Old_Z3_Proof_Parser.Transitivity_Star, _) => not_supported r
  19.828 +    | (Old_Z3_Proof_Parser.Pull_Quant_Star, _) => not_supported r
  19.829 +
  19.830 +    | _ => raise Fail ("Z3: proof rule " ^
  19.831 +        quote (Old_Z3_Proof_Parser.string_of_rule r) ^
  19.832 +        " has an unexpected number of arguments."))
  19.833 +
  19.834 +  fun lookup_proof ptab idx =
  19.835 +    (case Inttab.lookup ptab idx of
  19.836 +      SOME p => (p, idx)
  19.837 +    | NONE => z3_exn ("unknown proof id: " ^ quote (string_of_int idx)))
  19.838 +
  19.839 +  fun prove simpset vars (idx, step) (_, cxp as (ctxt, ptab)) =
  19.840 +    let
  19.841 +      val Old_Z3_Proof_Parser.Proof_Step {rule=r, prems, prop, ...} = step
  19.842 +      val ps = map (lookup_proof ptab) prems
  19.843 +      val _ = trace_before ctxt idx r
  19.844 +      val (thm, (ctxt', ptab')) =
  19.845 +        cxp
  19.846 +        |> prove_step simpset vars r ps prop
  19.847 +        |> tap (check_after idx r ps prop)
  19.848 +    in (thm, (ctxt', Inttab.update (idx, thm) ptab')) end
  19.849 +
  19.850 +  fun make_discharge_rules rules = rules @ [@{thm allI}, @{thm refl},
  19.851 +    @{thm reflexive}, Old_Z3_Proof_Literals.true_thm]
  19.852 +
  19.853 +  fun discharge_assms_tac rules =
  19.854 +    REPEAT (HEADGOAL (resolve_tac rules ORELSE' SOLVED' discharge_sk_tac))
  19.855 +    
  19.856 +  fun discharge_assms ctxt rules thm =
  19.857 +    if Thm.nprems_of thm = 0 then Goal.norm_result ctxt thm
  19.858 +    else
  19.859 +      (case Seq.pull (discharge_assms_tac rules thm) of
  19.860 +        SOME (thm', _) => Goal.norm_result ctxt thm'
  19.861 +      | NONE => raise THM ("failed to discharge premise", 1, [thm]))
  19.862 +
  19.863 +  fun discharge rules outer_ctxt (p, (inner_ctxt, _)) =
  19.864 +    thm_of p
  19.865 +    |> singleton (Proof_Context.export inner_ctxt outer_ctxt)
  19.866 +    |> discharge_assms outer_ctxt (make_discharge_rules rules)
  19.867 +in
  19.868 +
  19.869 +fun reconstruct outer_ctxt recon output =
  19.870 +  let
  19.871 +    val {context=ctxt, typs, terms, rewrite_rules, assms} = recon
  19.872 +    val (asserted, steps, vars, ctxt1) =
  19.873 +      Old_Z3_Proof_Parser.parse ctxt typs terms output
  19.874 +
  19.875 +    val simpset =
  19.876 +      Old_Z3_Proof_Tools.make_simpset ctxt1 (Named_Theorems.get ctxt1 @{named_theorems z3_simp})
  19.877 +
  19.878 +    val ((is, rules), cxp as (ctxt2, _)) =
  19.879 +      add_asserted outer_ctxt rewrite_rules assms asserted ctxt1
  19.880 +  in
  19.881 +    if Config.get ctxt2 Old_SMT_Config.filter_only_facts then (is, @{thm TrueI})
  19.882 +    else
  19.883 +      (Thm @{thm TrueI}, cxp)
  19.884 +      |> fold (prove simpset vars) steps 
  19.885 +      |> discharge rules outer_ctxt
  19.886 +      |> pair []
  19.887 +  end
  19.888 +
  19.889 +end
  19.890 +
  19.891 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/Library/Old_SMT/old_z3_proof_tools.ML	Thu Aug 28 00:40:38 2014 +0200
    20.3 @@ -0,0 +1,371 @@
    20.4 +(*  Title:      HOL/Library/Old_SMT/old_z3_proof_tools.ML
    20.5 +    Author:     Sascha Boehme, TU Muenchen
    20.6 +
    20.7 +Helper functions required for Z3 proof reconstruction.
    20.8 +*)
    20.9 +
   20.10 +signature OLD_Z3_PROOF_TOOLS =
   20.11 +sig
   20.12 +  (*modifying terms*)
   20.13 +  val as_meta_eq: cterm -> cterm
   20.14 +
   20.15 +  (*theorem nets*)
   20.16 +  val thm_net_of: ('a -> thm) -> 'a list -> 'a Net.net
   20.17 +  val net_instances: (int * thm) Net.net -> cterm -> (int * thm) list
   20.18 +  val net_instance: thm Net.net -> cterm -> thm option
   20.19 +
   20.20 +  (*proof combinators*)
   20.21 +  val under_assumption: (thm -> thm) -> cterm -> thm
   20.22 +  val with_conv: conv -> (cterm -> thm) -> cterm -> thm
   20.23 +  val discharge: thm -> thm -> thm
   20.24 +  val varify: string list -> thm -> thm
   20.25 +  val unfold_eqs: Proof.context -> thm list -> conv
   20.26 +  val match_instantiate: (cterm -> cterm) -> cterm -> thm -> thm
   20.27 +  val by_tac: Proof.context -> (int -> tactic) -> cterm -> thm
   20.28 +  val make_hyp_def: thm -> Proof.context -> thm * Proof.context
   20.29 +  val by_abstraction: int -> bool * bool -> Proof.context -> thm list ->
   20.30 +    (Proof.context -> cterm -> thm) -> cterm -> thm
   20.31 +
   20.32 +  (*a faster COMP*)
   20.33 +  type compose_data
   20.34 +  val precompose: (cterm -> cterm list) -> thm -> compose_data
   20.35 +  val precompose2: (cterm -> cterm * cterm) -> thm -> compose_data
   20.36 +  val compose: compose_data -> thm -> thm
   20.37 +
   20.38 +  (*unfolding of 'distinct'*)
   20.39 +  val unfold_distinct_conv: conv
   20.40 +
   20.41 +  (*simpset*)
   20.42 +  val add_simproc: Simplifier.simproc -> Context.generic -> Context.generic
   20.43 +  val make_simpset: Proof.context -> thm list -> simpset
   20.44 +end
   20.45 +
   20.46 +structure Old_Z3_Proof_Tools: OLD_Z3_PROOF_TOOLS =
   20.47 +struct
   20.48 +
   20.49 +
   20.50 +
   20.51 +(* modifying terms *)
   20.52 +
   20.53 +fun as_meta_eq ct =
   20.54 +  uncurry Old_SMT_Utils.mk_cequals (Thm.dest_binop (Old_SMT_Utils.dest_cprop ct))
   20.55 +
   20.56 +
   20.57 +
   20.58 +(* theorem nets *)
   20.59 +
   20.60 +fun thm_net_of f xthms =
   20.61 +  let fun insert xthm = Net.insert_term (K false) (Thm.prop_of (f xthm), xthm)
   20.62 +  in fold insert xthms Net.empty end
   20.63 +
   20.64 +fun maybe_instantiate ct thm =
   20.65 +  try Thm.first_order_match (Thm.cprop_of thm, ct)
   20.66 +  |> Option.map (fn inst => Thm.instantiate inst thm)
   20.67 +
   20.68 +local
   20.69 +  fun instances_from_net match f net ct =
   20.70 +    let
   20.71 +      val lookup = if match then Net.match_term else Net.unify_term
   20.72 +      val xthms = lookup net (Thm.term_of ct)
   20.73 +      fun select ct = map_filter (f (maybe_instantiate ct)) xthms 
   20.74 +      fun select' ct =
   20.75 +        let val thm = Thm.trivial ct
   20.76 +        in map_filter (f (try (fn rule => rule COMP thm))) xthms end
   20.77 +    in (case select ct of [] => select' ct | xthms' => xthms') end
   20.78 +in
   20.79 +
   20.80 +fun net_instances net =
   20.81 +  instances_from_net false (fn f => fn (i, thm) => Option.map (pair i) (f thm))
   20.82 +    net
   20.83 +
   20.84 +fun net_instance net = try hd o instances_from_net true I net
   20.85 +
   20.86 +end
   20.87 +
   20.88 +
   20.89 +
   20.90 +(* proof combinators *)
   20.91 +
   20.92 +fun under_assumption f ct =
   20.93 +  let val ct' = Old_SMT_Utils.mk_cprop ct
   20.94 +  in Thm.implies_intr ct' (f (Thm.assume ct')) end
   20.95 +
   20.96 +fun with_conv conv prove ct =
   20.97 +  let val eq = Thm.symmetric (conv ct)
   20.98 +  in Thm.equal_elim eq (prove (Thm.lhs_of eq)) end
   20.99 +
  20.100 +fun discharge p pq = Thm.implies_elim pq p
  20.101 +
  20.102 +fun varify vars = Drule.generalize ([], vars)
  20.103 +
  20.104 +fun unfold_eqs _ [] = Conv.all_conv
  20.105 +  | unfold_eqs ctxt eqs =
  20.106 +      Conv.top_sweep_conv (K (Conv.rewrs_conv eqs)) ctxt
  20.107 +
  20.108 +fun match_instantiate f ct thm =
  20.109 +  Thm.instantiate (Thm.match (f (Thm.cprop_of thm), ct)) thm
  20.110 +
  20.111 +fun by_tac ctxt tac ct = Goal.norm_result ctxt (Goal.prove_internal ctxt [] ct (K (tac 1)))
  20.112 +
  20.113 +(*
  20.114 +   |- c x == t x ==> P (c x)
  20.115 +  ---------------------------
  20.116 +      c == t |- P (c x)
  20.117 +*) 
  20.118 +fun make_hyp_def thm ctxt =
  20.119 +  let
  20.120 +    val (lhs, rhs) = Thm.dest_binop (Thm.cprem_of thm 1)
  20.121 +    val (cf, cvs) = Drule.strip_comb lhs
  20.122 +    val eq = Old_SMT_Utils.mk_cequals cf (fold_rev Thm.lambda cvs rhs)
  20.123 +    fun apply cv th =
  20.124 +      Thm.combination th (Thm.reflexive cv)
  20.125 +      |> Conv.fconv_rule (Conv.arg_conv (Thm.beta_conversion false))
  20.126 +  in
  20.127 +    yield_singleton Assumption.add_assumes eq ctxt
  20.128 +    |>> Thm.implies_elim thm o fold apply cvs
  20.129 +  end
  20.130 +
  20.131 +
  20.132 +
  20.133 +(* abstraction *)
  20.134 +
  20.135 +local
  20.136 +
  20.137 +fun abs_context ctxt = (ctxt, Termtab.empty, 1, false)
  20.138 +
  20.139 +fun context_of (ctxt, _, _, _) = ctxt
  20.140 +
  20.141 +fun replace (_, (cv, ct)) = Thm.forall_elim ct o Thm.forall_intr cv
  20.142 +
  20.143 +fun abs_instantiate (_, tab, _, beta_norm) =
  20.144 +  fold replace (Termtab.dest tab) #>
  20.145 +  beta_norm ? Conv.fconv_rule (Thm.beta_conversion true)
  20.146 +
  20.147 +fun lambda_abstract cvs t =
  20.148 +  let
  20.149 +    val frees = map Free (Term.add_frees t [])
  20.150 +    val cvs' = filter (fn cv => member (op aconv) frees (Thm.term_of cv)) cvs
  20.151 +    val vs = map (Term.dest_Free o Thm.term_of) cvs'
  20.152 +  in (fold_rev absfree vs t, cvs') end
  20.153 +
  20.154 +fun fresh_abstraction (_, cvs) ct (cx as (ctxt, tab, idx, beta_norm)) =
  20.155 +  let val (t, cvs') = lambda_abstract cvs (Thm.term_of ct)
  20.156 +  in
  20.157 +    (case Termtab.lookup tab t of
  20.158 +      SOME (cv, _) => (Drule.list_comb (cv, cvs'), cx)
  20.159 +    | NONE =>
  20.160 +        let
  20.161 +          val (n, ctxt') = yield_singleton Variable.variant_fixes "x" ctxt
  20.162 +          val cv = Old_SMT_Utils.certify ctxt'
  20.163 +            (Free (n, map Old_SMT_Utils.typ_of cvs' ---> Old_SMT_Utils.typ_of ct))
  20.164 +          val cu = Drule.list_comb (cv, cvs')
  20.165 +          val e = (t, (cv, fold_rev Thm.lambda cvs' ct))
  20.166 +          val beta_norm' = beta_norm orelse not (null cvs')
  20.167 +        in (cu, (ctxt', Termtab.update e tab, idx + 1, beta_norm')) end)
  20.168 +  end
  20.169 +
  20.170 +fun abs_comb f g dcvs ct =
  20.171 +  let val (cf, cu) = Thm.dest_comb ct
  20.172 +  in f dcvs cf ##>> g dcvs cu #>> uncurry Thm.apply end
  20.173 +
  20.174 +fun abs_arg f = abs_comb (K pair) f
  20.175 +
  20.176 +fun abs_args f dcvs ct =
  20.177 +  (case Thm.term_of ct of
  20.178 +    _ $ _ => abs_comb (abs_args f) f dcvs ct
  20.179 +  | _ => pair ct)
  20.180 +
  20.181 +fun abs_list f g dcvs ct =
  20.182 +  (case Thm.term_of ct of
  20.183 +    Const (@{const_name Nil}, _) => pair ct
  20.184 +  | Const (@{const_name Cons}, _) $ _ $ _ =>
  20.185 +      abs_comb (abs_arg f) (abs_list f g) dcvs ct
  20.186 +  | _ => g dcvs ct)
  20.187 +
  20.188 +fun abs_abs f (depth, cvs) ct =
  20.189 +  let val (cv, cu) = Thm.dest_abs NONE ct
  20.190 +  in f (depth, cv :: cvs) cu #>> Thm.lambda cv end
  20.191 +
  20.192 +val is_atomic =
  20.193 +  (fn Free _ => true | Var _ => true | Bound _ => true | _ => false)
  20.194 +
  20.195 +fun abstract depth (ext_logic, with_theories) =
  20.196 +  let
  20.197 +    fun abstr1 cvs ct = abs_arg abstr cvs ct
  20.198 +    and abstr2 cvs ct = abs_comb abstr1 abstr cvs ct
  20.199 +    and abstr3 cvs ct = abs_comb abstr2 abstr cvs ct
  20.200 +    and abstr_abs cvs ct = abs_arg (abs_abs abstr) cvs ct
  20.201 +
  20.202 +    and abstr (dcvs as (d, cvs)) ct =
  20.203 +      (case Thm.term_of ct of
  20.204 +        @{const Trueprop} $ _ => abstr1 dcvs ct
  20.205 +      | @{const Pure.imp} $ _ $ _ => abstr2 dcvs ct
  20.206 +      | @{const True} => pair ct
  20.207 +      | @{const False} => pair ct
  20.208 +      | @{const Not} $ _ => abstr1 dcvs ct
  20.209 +      | @{const HOL.conj} $ _ $ _ => abstr2 dcvs ct
  20.210 +      | @{const HOL.disj} $ _ $ _ => abstr2 dcvs ct
  20.211 +      | @{const HOL.implies} $ _ $ _ => abstr2 dcvs ct
  20.212 +      | Const (@{const_name HOL.eq}, _) $ _ $ _ => abstr2 dcvs ct
  20.213 +      | Const (@{const_name distinct}, _) $ _ =>
  20.214 +          if ext_logic then abs_arg (abs_list abstr fresh_abstraction) dcvs ct
  20.215 +          else fresh_abstraction dcvs ct
  20.216 +      | Const (@{const_name If}, _) $ _ $ _ $ _ =>
  20.217 +          if ext_logic then abstr3 dcvs ct else fresh_abstraction dcvs ct
  20.218 +      | Const (@{const_name All}, _) $ _ =>
  20.219 +          if ext_logic then abstr_abs dcvs ct else fresh_abstraction dcvs ct
  20.220 +      | Const (@{const_name Ex}, _) $ _ =>
  20.221 +          if ext_logic then abstr_abs dcvs ct else fresh_abstraction dcvs ct
  20.222 +      | t => (fn cx =>
  20.223 +          if is_atomic t orelse can HOLogic.dest_number t then (ct, cx)
  20.224 +          else if with_theories andalso
  20.225 +            Old_Z3_Interface.is_builtin_theory_term (context_of cx) t
  20.226 +          then abs_args abstr dcvs ct cx
  20.227 +          else if d = 0 then fresh_abstraction dcvs ct cx
  20.228 +          else
  20.229 +            (case Term.strip_comb t of
  20.230 +              (Const _, _) => abs_args abstr (d-1, cvs) ct cx
  20.231 +            | (Free _, _) => abs_args abstr (d-1, cvs) ct cx
  20.232 +            | _ => fresh_abstraction dcvs ct cx)))
  20.233 +  in abstr (depth, []) end
  20.234 +
  20.235 +val cimp = Thm.cterm_of @{theory} @{const Pure.imp}
  20.236 +
  20.237 +fun deepen depth f x =
  20.238 +  if depth = 0 then f depth x
  20.239 +  else (case try (f depth) x of SOME y => y | NONE => deepen (depth - 1) f x)
  20.240 +
  20.241 +fun with_prems depth thms f ct =
  20.242 +  fold_rev (Thm.mk_binop cimp o Thm.cprop_of) thms ct
  20.243 +  |> deepen depth f
  20.244 +  |> fold (fn prem => fn th => Thm.implies_elim th prem) thms
  20.245 +
  20.246 +in
  20.247 +
  20.248 +fun by_abstraction depth mode ctxt thms prove =
  20.249 +  with_prems depth thms (fn d => fn ct =>
  20.250 +    let val (cu, cx) = abstract d mode ct (abs_context ctxt)
  20.251 +    in abs_instantiate cx (prove (context_of cx) cu) end)
  20.252 +
  20.253 +end
  20.254 +
  20.255 +
  20.256 +
  20.257 +(* a faster COMP *)
  20.258 +
  20.259 +type compose_data = cterm list * (cterm -> cterm list) * thm
  20.260 +
  20.261 +fun list2 (x, y) = [x, y]
  20.262 +
  20.263 +fun precompose f rule = (f (Thm.cprem_of rule 1), f, rule)
  20.264 +fun precompose2 f rule = precompose (list2 o f) rule
  20.265 +
  20.266 +fun compose (cvs, f, rule) thm =
  20.267 +  discharge thm (Thm.instantiate ([], cvs ~~ f (Thm.cprop_of thm)) rule)
  20.268 +
  20.269 +
  20.270 +
  20.271 +(* unfolding of 'distinct' *)
  20.272 +
  20.273 +local
  20.274 +  val set1 = @{lemma "x ~: set [] == ~False" by simp}
  20.275 +  val set2 = @{lemma "x ~: set [x] == False" by simp}
  20.276 +  val set3 = @{lemma "x ~: set [y] == x ~= y" by simp}
  20.277 +  val set4 = @{lemma "x ~: set (x # ys) == False" by simp}
  20.278 +  val set5 = @{lemma "x ~: set (y # ys) == x ~= y & x ~: set ys" by simp}
  20.279 +
  20.280 +  fun set_conv ct =
  20.281 +    (Conv.rewrs_conv [set1, set2, set3, set4] else_conv
  20.282 +    (Conv.rewr_conv set5 then_conv Conv.arg_conv set_conv)) ct
  20.283 +
  20.284 +  val dist1 = @{lemma "distinct [] == ~False" by (simp add: distinct_def)}
  20.285 +  val dist2 = @{lemma "distinct [x] == ~False" by (simp add: distinct_def)}
  20.286 +  val dist3 = @{lemma "distinct (x # xs) == x ~: set xs & distinct xs"
  20.287 +    by (simp add: distinct_def)}
  20.288 +
  20.289 +  fun binop_conv cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
  20.290 +in
  20.291 +fun unfold_distinct_conv ct =
  20.292 +  (Conv.rewrs_conv [dist1, dist2] else_conv
  20.293 +  (Conv.rewr_conv dist3 then_conv binop_conv set_conv unfold_distinct_conv)) ct
  20.294 +end
  20.295 +
  20.296 +
  20.297 +
  20.298 +(* simpset *)
  20.299 +
  20.300 +local
  20.301 +  val antisym_le1 = mk_meta_eq @{thm order_class.antisym_conv}
  20.302 +  val antisym_le2 = mk_meta_eq @{thm linorder_class.antisym_conv2}
  20.303 +  val antisym_less1 = mk_meta_eq @{thm linorder_class.antisym_conv1}
  20.304 +  val antisym_less2 = mk_meta_eq @{thm linorder_class.antisym_conv3}
  20.305 +
  20.306 +  fun eq_prop t thm = HOLogic.mk_Trueprop t aconv Thm.prop_of thm
  20.307 +  fun dest_binop ((c as Const _) $ t $ u) = (c, t, u)
  20.308 +    | dest_binop t = raise TERM ("dest_binop", [t])
  20.309 +
  20.310 +  fun prove_antisym_le ctxt t =
  20.311 +    let
  20.312 +      val (le, r, s) = dest_binop t
  20.313 +      val less = Const (@{const_name less}, Term.fastype_of le)
  20.314 +      val prems = Simplifier.prems_of ctxt
  20.315 +    in
  20.316 +      (case find_first (eq_prop (le $ s $ r)) prems of
  20.317 +        NONE =>
  20.318 +          find_first (eq_prop (HOLogic.mk_not (less $ r $ s))) prems
  20.319 +          |> Option.map (fn thm => thm RS antisym_less1)
  20.320 +      | SOME thm => SOME (thm RS antisym_le1))
  20.321 +    end
  20.322 +    handle THM _ => NONE
  20.323 +
  20.324 +  fun prove_antisym_less ctxt t =
  20.325 +    let
  20.326 +      val (less, r, s) = dest_binop (HOLogic.dest_not t)
  20.327 +      val le = Const (@{const_name less_eq}, Term.fastype_of less)
  20.328 +      val prems = Simplifier.prems_of ctxt
  20.329 +    in
  20.330 +      (case find_first (eq_prop (le $ r $ s)) prems of
  20.331 +        NONE =>
  20.332 +          find_first (eq_prop (HOLogic.mk_not (less $ s $ r))) prems
  20.333 +          |> Option.map (fn thm => thm RS antisym_less2)
  20.334 +      | SOME thm => SOME (thm RS antisym_le2))
  20.335 +  end
  20.336 +  handle THM _ => NONE
  20.337 +
  20.338 +  val basic_simpset =
  20.339 +    simpset_of (put_simpset HOL_ss @{context}
  20.340 +      addsimps @{thms field_simps}
  20.341 +      addsimps [@{thm times_divide_eq_right}, @{thm times_divide_eq_left}]
  20.342 +      addsimps @{thms arith_special} addsimps @{thms arith_simps}
  20.343 +      addsimps @{thms rel_simps}
  20.344 +      addsimps @{thms array_rules}
  20.345 +      addsimps @{thms term_true_def} addsimps @{thms term_false_def}
  20.346 +      addsimps @{thms z3div_def} addsimps @{thms z3mod_def}
  20.347 +      addsimprocs [@{simproc binary_int_div}, @{simproc binary_int_mod}]
  20.348 +      addsimprocs [
  20.349 +        Simplifier.simproc_global @{theory} "fast_int_arith" [
  20.350 +          "(m::int) < n", "(m::int) <= n", "(m::int) = n"] Lin_Arith.simproc,
  20.351 +        Simplifier.simproc_global @{theory} "antisym_le" ["(x::'a::order) <= y"]
  20.352 +          prove_antisym_le,
  20.353 +        Simplifier.simproc_global @{theory} "antisym_less" ["~ (x::'a::linorder) < y"]
  20.354 +          prove_antisym_less])
  20.355 +
  20.356 +  structure Simpset = Generic_Data
  20.357 +  (
  20.358 +    type T = simpset
  20.359 +    val empty = basic_simpset
  20.360 +    val extend = I
  20.361 +    val merge = Simplifier.merge_ss
  20.362 +  )
  20.363 +in
  20.364 +
  20.365 +fun add_simproc simproc context =
  20.366 +  Simpset.map (simpset_map (Context.proof_of context)
  20.367 +    (fn ctxt => ctxt addsimprocs [simproc])) context
  20.368 +
  20.369 +fun make_simpset ctxt rules =
  20.370 +  simpset_of (put_simpset (Simpset.get (Context.Proof ctxt)) ctxt addsimps rules)
  20.371 +
  20.372 +end
  20.373 +
  20.374 +end
    21.1 --- a/src/HOL/Library/Old_SMT/smt_builtin.ML	Thu Aug 28 00:40:38 2014 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,231 +0,0 @@
    21.4 -(*  Title:      HOL/Library/Old_SMT/smt_builtin.ML
    21.5 -    Author:     Sascha Boehme, TU Muenchen
    21.6 -
    21.7 -Tables of types and terms directly supported by SMT solvers.
    21.8 -*)
    21.9 -
   21.10 -signature SMT_BUILTIN =
   21.11 -sig
   21.12 -  (*for experiments*)
   21.13 -  val filter_builtins: (typ -> bool) -> Proof.context -> Proof.context
   21.14 -
   21.15 -  (*built-in types*)
   21.16 -  val add_builtin_typ: SMT_Utils.class ->
   21.17 -    typ * (typ -> string option) * (typ -> int -> string option) ->
   21.18 -    Context.generic -> Context.generic
   21.19 -  val add_builtin_typ_ext: typ * (typ -> bool) -> Context.generic ->
   21.20 -    Context.generic
   21.21 -  val dest_builtin_typ: Proof.context -> typ -> string option
   21.22 -  val is_builtin_typ_ext: Proof.context -> typ -> bool
   21.23 -
   21.24 -  (*built-in numbers*)
   21.25 -  val dest_builtin_num: Proof.context -> term -> (string * typ) option
   21.26 -  val is_builtin_num: Proof.context -> term -> bool
   21.27 -  val is_builtin_num_ext: Proof.context -> term -> bool
   21.28 -
   21.29 -  (*built-in functions*)
   21.30 -  type 'a bfun = Proof.context -> typ -> term list -> 'a
   21.31 -  type bfunr = string * int * term list * (term list -> term)
   21.32 -  val add_builtin_fun: SMT_Utils.class ->
   21.33 -    (string * typ) * bfunr option bfun -> Context.generic -> Context.generic
   21.34 -  val add_builtin_fun': SMT_Utils.class -> term * string -> Context.generic ->
   21.35 -    Context.generic
   21.36 -  val add_builtin_fun_ext: (string * typ) * term list bfun ->
   21.37 -    Context.generic -> Context.generic
   21.38 -  val add_builtin_fun_ext': string * typ -> Context.generic -> Context.generic
   21.39 -  val add_builtin_fun_ext'': string -> Context.generic -> Context.generic
   21.40 -  val dest_builtin_fun: Proof.context -> string * typ -> term list ->
   21.41 -    bfunr option
   21.42 -  val dest_builtin_eq: Proof.context -> term -> term -> bfunr option
   21.43 -  val dest_builtin_pred: Proof.context -> string * typ -> term list ->
   21.44 -    bfunr option
   21.45 -  val dest_builtin_conn: Proof.context -> string * typ -> term list ->
   21.46 -    bfunr option
   21.47 -  val dest_builtin: Proof.context -> string * typ -> term list -> bfunr option
   21.48 -  val dest_builtin_ext: Proof.context -> string * typ -> term list ->
   21.49 -    term list option
   21.50 -  val is_builtin_fun: Proof.context -> string * typ -> term list -> bool
   21.51 -  val is_builtin_fun_ext: Proof.context -> string * typ -> term list -> bool
   21.52 -end
   21.53 -
   21.54 -structure SMT_Builtin: SMT_BUILTIN =
   21.55 -struct
   21.56 -
   21.57 -
   21.58 -(* built-in tables *)
   21.59 -
   21.60 -datatype ('a, 'b) kind = Ext of 'a | Int of 'b
   21.61 -
   21.62 -type ('a, 'b) ttab = ((typ * ('a, 'b) kind) Ord_List.T) SMT_Utils.dict 
   21.63 -
   21.64 -fun typ_ord ((T, _), (U, _)) =
   21.65 -  let
   21.66 -    fun tord (TVar _, Type _) = GREATER
   21.67 -      | tord (Type _, TVar _) = LESS
   21.68 -      | tord (Type (n, Ts), Type (m, Us)) =
   21.69 -          if n = m then list_ord tord (Ts, Us)
   21.70 -          else Term_Ord.typ_ord (T, U)
   21.71 -      | tord TU = Term_Ord.typ_ord TU
   21.72 -  in tord (T, U) end
   21.73 -
   21.74 -fun insert_ttab cs T f =
   21.75 -  SMT_Utils.dict_map_default (cs, [])
   21.76 -    (Ord_List.insert typ_ord (perhaps (try Logic.varifyT_global) T, f))
   21.77 -
   21.78 -fun merge_ttab ttabp =
   21.79 -  SMT_Utils.dict_merge (Ord_List.merge typ_ord) ttabp
   21.80 -
   21.81 -fun lookup_ttab ctxt ttab T =
   21.82 -  let fun match (U, _) = Sign.typ_instance (Proof_Context.theory_of ctxt) (T, U)
   21.83 -  in
   21.84 -    get_first (find_first match)
   21.85 -      (SMT_Utils.dict_lookup ttab (SMT_Config.solver_class_of ctxt))
   21.86 -  end
   21.87 -
   21.88 -type ('a, 'b) btab = ('a, 'b) ttab Symtab.table
   21.89 -
   21.90 -fun insert_btab cs n T f =
   21.91 -  Symtab.map_default (n, []) (insert_ttab cs T f)
   21.92 -
   21.93 -fun merge_btab btabp = Symtab.join (K merge_ttab) btabp
   21.94 -
   21.95 -fun lookup_btab ctxt btab (n, T) =
   21.96 -  (case Symtab.lookup btab n of
   21.97 -    NONE => NONE
   21.98 -  | SOME ttab => lookup_ttab ctxt ttab T)
   21.99 -
  21.100 -type 'a bfun = Proof.context -> typ -> term list -> 'a
  21.101 -
  21.102 -type bfunr = string * int * term list * (term list -> term)
  21.103 -
  21.104 -structure Builtins = Generic_Data
  21.105 -(
  21.106 -  type T =
  21.107 -    (typ -> bool, (typ -> string option) * (typ -> int -> string option)) ttab *
  21.108 -    (term list bfun, bfunr option bfun) btab
  21.109 -  val empty = ([], Symtab.empty)
  21.110 -  val extend = I
  21.111 -  fun merge ((t1, b1), (t2, b2)) = (merge_ttab (t1, t2), merge_btab (b1, b2))
  21.112 -)
  21.113 -
  21.114 -fun filter_ttab keep_T = map (apsnd (filter (keep_T o fst)))
  21.115 -
  21.116 -fun filter_builtins keep_T =
  21.117 -  Context.proof_map (Builtins.map (fn (ttab, btab) =>
  21.118 -    (filter_ttab keep_T ttab, Symtab.map (K (filter_ttab keep_T)) btab)))
  21.119 -
  21.120 -
  21.121 -(* built-in types *)
  21.122 -
  21.123 -fun add_builtin_typ cs (T, f, g) =
  21.124 -  Builtins.map (apfst (insert_ttab cs T (Int (f, g))))
  21.125 -
  21.126 -fun add_builtin_typ_ext (T, f) =
  21.127 -  Builtins.map (apfst (insert_ttab SMT_Utils.basicC T (Ext f)))
  21.128 -
  21.129 -fun lookup_builtin_typ ctxt =
  21.130 -  lookup_ttab ctxt (fst (Builtins.get (Context.Proof ctxt)))
  21.131 -
  21.132 -fun dest_builtin_typ ctxt T =
  21.133 -  (case lookup_builtin_typ ctxt T of
  21.134 -    SOME (_, Int (f, _)) => f T
  21.135 -  | _ => NONE) 
  21.136 -
  21.137 -fun is_builtin_typ_ext ctxt T =
  21.138 -  (case lookup_builtin_typ ctxt T of
  21.139 -    SOME (_, Int (f, _)) => is_some (f T)
  21.140 -  | SOME (_, Ext f) => f T
  21.141 -  | NONE => false)
  21.142 -
  21.143 -
  21.144 -(* built-in numbers *)
  21.145 -
  21.146 -fun dest_builtin_num ctxt t =
  21.147 -  (case try HOLogic.dest_number t of
  21.148 -    NONE => NONE
  21.149 -  | SOME (T, i) =>
  21.150 -      if i < 0 then NONE else
  21.151 -        (case lookup_builtin_typ ctxt T of
  21.152 -          SOME (_, Int (_, g)) => g T i |> Option.map (rpair T)
  21.153 -        | _ => NONE))
  21.154 -
  21.155 -val is_builtin_num = is_some oo dest_builtin_num
  21.156 -
  21.157 -fun is_builtin_num_ext ctxt t =
  21.158 -  (case try HOLogic.dest_number t of
  21.159 -    NONE => false
  21.160 -  | SOME (T, _) => is_builtin_typ_ext ctxt T)
  21.161 -
  21.162 -
  21.163 -(* built-in functions *)
  21.164 -
  21.165 -fun add_builtin_fun cs ((n, T), f) =
  21.166 -  Builtins.map (apsnd (insert_btab cs n T (Int f)))
  21.167 -
  21.168 -fun add_builtin_fun' cs (t, n) =
  21.169 -  let
  21.170 -    val c as (m, T) = Term.dest_Const t
  21.171 -    fun app U ts = Term.list_comb (Const (m, U), ts)
  21.172 -    fun bfun _ U ts = SOME (n, length (Term.binder_types T), ts, app U)
  21.173 -  in add_builtin_fun cs (c, bfun) end
  21.174 -
  21.175 -fun add_builtin_fun_ext ((n, T), f) =
  21.176 -  Builtins.map (apsnd (insert_btab SMT_Utils.basicC n T (Ext f)))
  21.177 -
  21.178 -fun add_builtin_fun_ext' c = add_builtin_fun_ext (c, fn _ => fn _ => I)
  21.179 -
  21.180 -fun add_builtin_fun_ext'' n context =
  21.181 -  let val thy = Context.theory_of context
  21.182 -  in add_builtin_fun_ext' (n, Sign.the_const_type thy n) context end
  21.183 -
  21.184 -fun lookup_builtin_fun ctxt =
  21.185 -  lookup_btab ctxt (snd (Builtins.get (Context.Proof ctxt)))
  21.186 -
  21.187 -fun dest_builtin_fun ctxt (c as (_, T)) ts =
  21.188 -  (case lookup_builtin_fun ctxt c of
  21.189 -    SOME (_, Int f) => f ctxt T ts
  21.190 -  | _ => NONE)
  21.191 -
  21.192 -fun dest_builtin_eq ctxt t u =
  21.193 -  let
  21.194 -    val aT = TFree (Name.aT, @{sort type})
  21.195 -    val c = (@{const_name HOL.eq}, aT --> aT --> @{typ bool})
  21.196 -    fun mk ts = Term.list_comb (HOLogic.eq_const (Term.fastype_of (hd ts)), ts)
  21.197 -  in
  21.198 -    dest_builtin_fun ctxt c []
  21.199 -    |> Option.map (fn (n, i, _, _) => (n, i, [t, u], mk))
  21.200 -  end
  21.201 -
  21.202 -fun special_builtin_fun pred ctxt (c as (_, T)) ts =
  21.203 -  if pred (Term.body_type T, Term.binder_types T) then
  21.204 -    dest_builtin_fun ctxt c ts
  21.205 -  else NONE
  21.206 -
  21.207 -fun dest_builtin_pred ctxt = special_builtin_fun (equal @{typ bool} o fst) ctxt
  21.208 -
  21.209 -fun dest_builtin_conn ctxt =
  21.210 -  special_builtin_fun (forall (equal @{typ bool}) o (op ::)) ctxt
  21.211 -
  21.212 -fun dest_builtin ctxt c ts =
  21.213 -  let val t = Term.list_comb (Const c, ts)
  21.214 -  in
  21.215 -    (case dest_builtin_num ctxt t of
  21.216 -      SOME (n, _) => SOME (n, 0, [], K t)
  21.217 -    | NONE => dest_builtin_fun ctxt c ts)
  21.218 -  end
  21.219 -
  21.220 -fun dest_builtin_fun_ext ctxt (c as (_, T)) ts =    
  21.221 -  (case lookup_builtin_fun ctxt c of
  21.222 -    SOME (_, Int f) => f ctxt T ts |> Option.map (fn (_, _, us, _) => us)
  21.223 -  | SOME (_, Ext f) => SOME (f ctxt T ts)
  21.224 -  | NONE => NONE)
  21.225 -
  21.226 -fun dest_builtin_ext ctxt c ts =
  21.227 -  if is_builtin_num_ext ctxt (Term.list_comb (Const c, ts)) then SOME []
  21.228 -  else dest_builtin_fun_ext ctxt c ts
  21.229 -
  21.230 -fun is_builtin_fun ctxt c ts = is_some (dest_builtin_fun ctxt c ts)
  21.231 -
  21.232 -fun is_builtin_fun_ext ctxt c ts = is_some (dest_builtin_fun_ext ctxt c ts)
  21.233 -
  21.234 -end
    22.1 --- a/src/HOL/Library/Old_SMT/smt_config.ML	Thu Aug 28 00:40:38 2014 +0200
    22.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.3 @@ -1,254 +0,0 @@
    22.4 -(*  Title:      HOL/Library/Old_SMT/smt_config.ML
    22.5 -    Author:     Sascha Boehme, TU Muenchen
    22.6 -
    22.7 -Configuration options and diagnostic tools for SMT.
    22.8 -*)
    22.9 -
   22.10 -signature SMT_CONFIG =
   22.11 -sig
   22.12 -  (*solver*)
   22.13 -  type solver_info = {
   22.14 -    name: string,
   22.15 -    class: Proof.context -> SMT_Utils.class,
   22.16 -    avail: unit -> bool,
   22.17 -    options: Proof.context -> string list }
   22.18 -  val add_solver: solver_info -> Context.generic -> Context.generic
   22.19 -  val set_solver_options: string * string -> Context.generic -> Context.generic
   22.20 -  val is_available: Proof.context -> string -> bool
   22.21 -  val available_solvers_of: Proof.context -> string list
   22.22 -  val select_solver: string -> Context.generic -> Context.generic
   22.23 -  val solver_of: Proof.context -> string
   22.24 -  val solver_class_of: Proof.context -> SMT_Utils.class
   22.25 -  val solver_options_of: Proof.context -> string list
   22.26 -
   22.27 -  (*options*)
   22.28 -  val oracle: bool Config.T
   22.29 -  val datatypes: bool Config.T
   22.30 -  val timeout: real Config.T
   22.31 -  val random_seed: int Config.T
   22.32 -  val read_only_certificates: bool Config.T
   22.33 -  val verbose: bool Config.T
   22.34 -  val trace: bool Config.T
   22.35 -  val trace_used_facts: bool Config.T
   22.36 -  val monomorph_limit: int Config.T
   22.37 -  val monomorph_instances: int Config.T
   22.38 -  val infer_triggers: bool Config.T
   22.39 -  val filter_only_facts: bool Config.T
   22.40 -  val debug_files: string Config.T
   22.41 -
   22.42 -  (*tools*)
   22.43 -  val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
   22.44 -
   22.45 -  (*diagnostics*)
   22.46 -  val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
   22.47 -  val verbose_msg: Proof.context -> ('a -> string) -> 'a -> unit
   22.48 -
   22.49 -  (*certificates*)
   22.50 -  val select_certificates: string -> Context.generic -> Context.generic
   22.51 -  val certificates_of: Proof.context -> Cache_IO.cache option
   22.52 -
   22.53 -  (*setup*)
   22.54 -  val setup: theory -> theory
   22.55 -  val print_setup: Proof.context -> unit
   22.56 -end
   22.57 -
   22.58 -structure SMT_Config: SMT_CONFIG =
   22.59 -struct
   22.60 -
   22.61 -(* solver *)
   22.62 -
   22.63 -type solver_info = {
   22.64 -  name: string,
   22.65 -  class: Proof.context -> SMT_Utils.class,
   22.66 -  avail: unit -> bool,
   22.67 -  options: Proof.context -> string list }
   22.68 -
   22.69 -(* FIXME just one data slot (record) per program unit *)
   22.70 -structure Solvers = Generic_Data
   22.71 -(
   22.72 -  type T = (solver_info * string list) Symtab.table * string option
   22.73 -  val empty = (Symtab.empty, NONE)
   22.74 -  val extend = I
   22.75 -  fun merge ((ss1, s1), (ss2, s2)) =
   22.76 -    (Symtab.merge (K true) (ss1, ss2), merge_options (s1, s2))
   22.77 -)
   22.78 -
   22.79 -fun set_solver_options (name, options) =
   22.80 -  let val opts = String.tokens (Symbol.is_ascii_blank o str) options
   22.81 -  in Solvers.map (apfst (Symtab.map_entry name (apsnd (K opts)))) end
   22.82 -
   22.83 -fun add_solver (info as {name, ...} : solver_info) context =
   22.84 -  if Symtab.defined (fst (Solvers.get context)) name then
   22.85 -    error ("Solver already registered: " ^ quote name)
   22.86 -  else
   22.87 -    context
   22.88 -    |> Solvers.map (apfst (Symtab.update (name, (info, []))))
   22.89 -    |> Context.map_theory (Attrib.setup (Binding.name (name ^ "_options"))
   22.90 -        (Scan.lift (@{keyword "="} |-- Args.name) >>
   22.91 -          (Thm.declaration_attribute o K o set_solver_options o pair name))
   22.92 -        ("Additional command line options for SMT solver " ^ quote name))
   22.93 -
   22.94 -fun all_solvers_of ctxt = Symtab.keys (fst (Solvers.get (Context.Proof ctxt)))
   22.95 -
   22.96 -fun solver_name_of ctxt = snd (Solvers.get (Context.Proof ctxt))
   22.97 -
   22.98 -fun is_available ctxt name =
   22.99 -  (case Symtab.lookup (fst (Solvers.get (Context.Proof ctxt))) name of
  22.100 -    SOME ({avail, ...}, _) => avail ()
  22.101 -  | NONE => false)
  22.102 -
  22.103 -fun available_solvers_of ctxt =
  22.104 -  filter (is_available ctxt) (all_solvers_of ctxt)
  22.105 -
  22.106 -fun warn_solver (Context.Proof ctxt) name =
  22.107 -      if Context_Position.is_visible ctxt then
  22.108 -        warning ("The SMT solver " ^ quote name ^ " is not installed.")
  22.109 -      else ()
  22.110 -  | warn_solver _ _ = ();
  22.111 -
  22.112 -fun select_solver name context =
  22.113 -  let
  22.114 -    val ctxt = Context.proof_of context
  22.115 -    val upd = Solvers.map (apsnd (K (SOME name)))
  22.116 -  in
  22.117 -    if not (member (op =) (all_solvers_of ctxt) name) then
  22.118 -      error ("Trying to select unknown solver: " ^ quote name)
  22.119 -    else if not (is_available ctxt name) then
  22.120 -      (warn_solver context name; upd context)
  22.121 -    else upd context
  22.122 -  end
  22.123 -
  22.124 -fun no_solver_err () = error "No SMT solver selected"
  22.125 -
  22.126 -fun solver_of ctxt =
  22.127 -  (case solver_name_of ctxt of
  22.128 -    SOME name => name
  22.129 -  | NONE => no_solver_err ())
  22.130 -
  22.131 -fun solver_info_of default select ctxt =
  22.132 -  (case Solvers.get (Context.Proof ctxt) of
  22.133 -    (solvers, SOME name) => select (Symtab.lookup solvers name)
  22.134 -  | (_, NONE) => default ())
  22.135 -
  22.136 -fun solver_class_of ctxt =
  22.137 -  let fun class_of ({class, ...}: solver_info, _) = class ctxt
  22.138 -  in solver_info_of no_solver_err (class_of o the) ctxt end
  22.139 -
  22.140 -fun solver_options_of ctxt =
  22.141 -  let
  22.142 -    fun all_options NONE = []
  22.143 -      | all_options (SOME ({options, ...} : solver_info, opts)) =
  22.144 -          opts @ options ctxt
  22.145 -  in solver_info_of (K []) all_options ctxt end
  22.146 -
  22.147 -val setup_solver =
  22.148 -  Attrib.setup @{binding smt_solver}
  22.149 -    (Scan.lift (@{keyword "="} |-- Args.name) >>
  22.150 -      (Thm.declaration_attribute o K o select_solver))
  22.151 -    "SMT solver configuration"
  22.152 -
  22.153 -
  22.154 -(* options *)
  22.155 -
  22.156 -val oracle = Attrib.setup_config_bool @{binding smt_oracle} (K true)
  22.157 -val datatypes = Attrib.setup_config_bool @{binding smt_datatypes} (K false)
  22.158 -val timeout = Attrib.setup_config_real @{binding smt_timeout} (K 30.0)
  22.159 -val random_seed = Attrib.setup_config_int @{binding smt_random_seed} (K 1)
  22.160 -val read_only_certificates = Attrib.setup_config_bool @{binding smt_read_only_certificates} (K false)
  22.161 -val verbose = Attrib.setup_config_bool @{binding smt_verbose} (K true)
  22.162 -val trace = Attrib.setup_config_bool @{binding smt_trace} (K false)
  22.163 -val trace_used_facts = Attrib.setup_config_bool @{binding smt_trace_used_facts} (K false)
  22.164 -val monomorph_limit = Attrib.setup_config_int @{binding smt_monomorph_limit} (K 10)
  22.165 -val monomorph_instances = Attrib.setup_config_int @{binding smt_monomorph_instances} (K 500)
  22.166 -val infer_triggers = Attrib.setup_config_bool @{binding smt_infer_triggers} (K false)
  22.167 -val filter_only_facts = Attrib.setup_config_bool @{binding smt_filter_only_facts} (K false)
  22.168 -val debug_files = Attrib.setup_config_string @{binding smt_debug_files} (K "")
  22.169 -
  22.170 -
  22.171 -(* diagnostics *)
  22.172 -
  22.173 -fun cond_trace flag f x = if flag then tracing ("SMT: " ^ f x) else ()
  22.174 -
  22.175 -fun verbose_msg ctxt = cond_trace (Config.get ctxt verbose)
  22.176 -
  22.177 -fun trace_msg ctxt = cond_trace (Config.get ctxt trace)
  22.178 -
  22.179 -
  22.180 -(* tools *)
  22.181 -
  22.182 -fun with_timeout ctxt f x =
  22.183 -  TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) f x
  22.184 -  handle TimeLimit.TimeOut => raise SMT_Failure.SMT SMT_Failure.Time_Out
  22.185 -
  22.186 -
  22.187 -(* certificates *)
  22.188 -
  22.189 -(* FIXME just one data slot (record) per program unit *)
  22.190 -structure Certificates = Generic_Data
  22.191 -(
  22.192 -  type T = Cache_IO.cache option
  22.193 -  val empty = NONE
  22.194 -  val extend = I
  22.195 -  fun merge (s, _) = s  (* FIXME merge options!? *)
  22.196 -)
  22.197 -
  22.198 -val get_certificates_path =
  22.199 -  Option.map (Cache_IO.cache_path_of) o Certificates.get o Context.Proof
  22.200 -
  22.201 -fun select_certificates name context = context |> Certificates.put (
  22.202 -  if name = "" then NONE
  22.203 -  else
  22.204 -    Path.explode name
  22.205 -    |> Path.append (Resources.master_directory (Context.theory_of context))
  22.206 -    |> SOME o Cache_IO.unsynchronized_init)
  22.207 -
  22.208 -val certificates_of = Certificates.get o Context.Proof
  22.209 -
  22.210 -val setup_certificates =
  22.211 -  Attrib.setup @{binding smt_certificates}
  22.212 -    (Scan.lift (@{keyword "="} |-- Args.name) >>
  22.213 -      (Thm.declaration_attribute o K o select_certificates))
  22.214 -    "SMT certificates configuration"
  22.215 -
  22.216 -
  22.217 -(* setup *)
  22.218 -
  22.219 -val setup =
  22.220 -  setup_solver #>
  22.221 -  setup_certificates
  22.222 -
  22.223 -fun print_setup ctxt =
  22.224 -  let
  22.225 -    fun string_of_bool b = if b then "true" else "false"
  22.226 -
  22.227 -    val names = available_solvers_of ctxt
  22.228 -    val ns = if null names then ["(none)"] else sort_strings names
  22.229 -    val n = the_default "(none)" (solver_name_of ctxt)
  22.230 -    val opts = solver_options_of ctxt
  22.231 -    
  22.232 -    val t = string_of_real (Config.get ctxt timeout)
  22.233 -
  22.234 -    val certs_filename =
  22.235 -      (case get_certificates_path ctxt of
  22.236 -        SOME path => Path.print path
  22.237 -      | NONE => "(disabled)")
  22.238 -  in
  22.239 -    Pretty.writeln (Pretty.big_list "SMT setup:" [
  22.240 -      Pretty.str ("Current SMT solver: " ^ n),
  22.241 -      Pretty.str ("Current SMT solver options: " ^ space_implode " " opts),
  22.242 -      Pretty.str_list "Available SMT solvers: "  "" ns,
  22.243 -      Pretty.str ("Current timeout: " ^ t ^ " seconds"),
  22.244 -      Pretty.str ("With proofs: " ^
  22.245 -        string_of_bool (not (Config.get ctxt oracle))),
  22.246 -      Pretty.str ("Certificates cache: " ^ certs_filename),
  22.247 -      Pretty.str ("Fixed certificates: " ^
  22.248 -        string_of_bool (Config.get ctxt read_only_certificates))])
  22.249 -  end
  22.250 -
  22.251 -val _ =
  22.252 -  Outer_Syntax.improper_command @{command_spec "smt_status"}
  22.253 -    "show the available SMT solvers, the currently selected SMT solver, \
  22.254 -    \and the values of SMT configuration options"
  22.255 -    (Scan.succeed (Toplevel.keep (print_setup o Toplevel.context_of)))
  22.256 -
  22.257 -end
    23.1 --- a/src/HOL/Library/Old_SMT/smt_datatypes.ML	Thu Aug 28 00:40:38 2014 +0200
    23.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.3 @@ -1,94 +0,0 @@
    23.4 -(*  Title:      HOL/Library/Old_SMT/smt_datatypes.ML
    23.5 -    Author:     Sascha Boehme, TU Muenchen
    23.6 -
    23.7 -Collector functions for common type declarations and their representation
    23.8 -as algebraic datatypes.
    23.9 -*)
   23.10 -
   23.11 -signature SMT_DATATYPES =
   23.12 -sig
   23.13 -  val add_decls: typ ->
   23.14 -    (typ * (term * term list) list) list list * Proof.context ->
   23.15 -    (typ * (term * term list) list) list list * Proof.context
   23.16 -end
   23.17 -
   23.18 -structure SMT_Datatypes: SMT_DATATYPES =
   23.19 -struct
   23.20 -
   23.21 -fun mk_selectors T Ts =
   23.22 -  Variable.variant_fixes (replicate (length Ts) "select")
   23.23 -  #>> map2 (fn U => fn n => Free (n, T --> U)) Ts
   23.24 -
   23.25 -
   23.26 -(* free constructor type declarations *)
   23.27 -
   23.28 -fun get_ctr_sugar_decl ({ctrs, ...} : Ctr_Sugar.ctr_sugar) T Ts ctxt =
   23.29 -  let
   23.30 -    fun mk_constr ctr0 =
   23.31 -      let val ctr = Ctr_Sugar.mk_ctr Ts ctr0 in
   23.32 -        mk_selectors T (binder_types (fastype_of ctr)) #>> pair ctr
   23.33 -      end
   23.34 -  in
   23.35 -    fold_map mk_constr ctrs ctxt
   23.36 -    |>> (pair T #> single)
   23.37 -  end
   23.38 -
   23.39 -
   23.40 -(* typedef declarations *)
   23.41 -
   23.42 -fun get_typedef_decl (({Abs_name, Rep_name, abs_type, rep_type, ...}, {Abs_inverse, ...})
   23.43 -    : Typedef.info) T Ts =
   23.44 -  if can (curry (op RS) @{thm UNIV_I}) Abs_inverse then
   23.45 -    let
   23.46 -      val env = snd (Term.dest_Type abs_type) ~~ Ts
   23.47 -      val instT = Term.map_atyps (perhaps (AList.lookup (op =) env))
   23.48 -
   23.49 -      val constr = Const (Abs_name, instT (rep_type --> abs_type))
   23.50 -      val select = Const (Rep_name, instT (abs_type --> rep_type))
   23.51 -    in [(T, [(constr, [select])])] end
   23.52 -  else
   23.53 -    []
   23.54 -
   23.55 -
   23.56 -(* collection of declarations *)
   23.57 -
   23.58 -fun declared declss T = exists (exists (equal T o fst)) declss
   23.59 -fun declared' dss T = exists (exists (equal T o fst) o snd) dss
   23.60 -
   23.61 -fun get_decls T n Ts ctxt =
   23.62 -  (case Ctr_Sugar.ctr_sugar_of ctxt n of
   23.63 -    SOME ctr_sugar => get_ctr_sugar_decl ctr_sugar T Ts ctxt
   23.64 -  | NONE =>
   23.65 -      (case Typedef.get_info ctxt n of
   23.66 -        [] => ([], ctxt)
   23.67 -      | info :: _ => (get_typedef_decl info T Ts, ctxt)))
   23.68 -
   23.69 -fun add_decls T (declss, ctxt) =
   23.70 -  let
   23.71 -    fun depends Ts ds = exists (member (op =) (map fst ds)) Ts
   23.72 -
   23.73 -    fun add (TFree _) = I
   23.74 -      | add (TVar _) = I
   23.75 -      | add (T as Type (@{type_name fun}, _)) =
   23.76 -          fold add (Term.body_type T :: Term.binder_types T)
   23.77 -      | add @{typ bool} = I
   23.78 -      | add (T as Type (n, Ts)) = (fn (dss, ctxt1) =>
   23.79 -          if declared declss T orelse declared' dss T then (dss, ctxt1)
   23.80 -          else if SMT_Builtin.is_builtin_typ_ext ctxt1 T then (dss, ctxt1)
   23.81 -          else
   23.82 -            (case get_decls T n Ts ctxt1 of
   23.83 -              ([], _) => (dss, ctxt1)
   23.84 -            | (ds, ctxt2) =>
   23.85 -                let
   23.86 -                  val constrTs =
   23.87 -                    maps (map (snd o Term.dest_Const o fst) o snd) ds
   23.88 -                  val Us = fold (union (op =) o Term.binder_types) constrTs []
   23.89 -
   23.90 -                  fun ins [] = [(Us, ds)]
   23.91 -                    | ins ((Uds as (Us', _)) :: Udss) =
   23.92 -                        if depends Us' ds then (Us, ds) :: Uds :: Udss
   23.93 -                        else Uds :: ins Udss
   23.94 -            in fold add Us (ins dss, ctxt2) end))
   23.95 -  in add T ([], ctxt) |>> append declss o map snd end
   23.96 -
   23.97 -end
    24.1 --- a/src/HOL/Library/Old_SMT/smt_failure.ML	Thu Aug 28 00:40:38 2014 +0200
    24.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.3 @@ -1,61 +0,0 @@
    24.4 -(*  Title:      HOL/Library/Old_SMT/smt_failure.ML
    24.5 -    Author:     Sascha Boehme, TU Muenchen
    24.6 -
    24.7 -Failures and exception of SMT.
    24.8 -*)
    24.9 -
   24.10 -signature SMT_FAILURE =
   24.11 -sig
   24.12 -  type counterexample = {
   24.13 -    is_real_cex: bool,
   24.14 -    free_constraints: term list,
   24.15 -    const_defs: term list}
   24.16 -  datatype failure =
   24.17 -    Counterexample of counterexample |
   24.18 -    Time_Out |
   24.19 -    Out_Of_Memory |
   24.20 -    Abnormal_Termination of int |
   24.21 -    Other_Failure of string
   24.22 -  val pretty_counterexample: Proof.context -> counterexample -> Pretty.T
   24.23 -  val string_of_failure: Proof.context -> failure -> string
   24.24 -  exception SMT of failure
   24.25 -end
   24.26 -
   24.27 -structure SMT_Failure: SMT_FAILURE =
   24.28 -struct
   24.29 -
   24.30 -type counterexample = {
   24.31 -  is_real_cex: bool,
   24.32 -  free_constraints: term list,
   24.33 -  const_defs: term list}
   24.34 -
   24.35 -datatype failure =
   24.36 -  Counterexample of counterexample |
   24.37 -  Time_Out |
   24.38 -  Out_Of_Memory |
   24.39 -  Abnormal_Termination of int |
   24.40 -  Other_Failure of string
   24.41 -
   24.42 -fun pretty_counterexample ctxt {is_real_cex, free_constraints, const_defs} =
   24.43 -  let
   24.44 -    val msg =
   24.45 -      if is_real_cex then "Counterexample found (possibly spurious)"
   24.46 -      else "Potential counterexample found"
   24.47 -  in
   24.48 -    if null free_constraints andalso null const_defs then Pretty.str msg
   24.49 -    else
   24.50 -      Pretty.big_list (msg ^ ":")
   24.51 -        (map (Syntax.pretty_term ctxt) (free_constraints @ const_defs))
   24.52 -  end
   24.53 -
   24.54 -fun string_of_failure ctxt (Counterexample cex) =
   24.55 -      Pretty.string_of (pretty_counterexample ctxt cex)
   24.56 -  | string_of_failure _ Time_Out = "Timed out"
   24.57 -  | string_of_failure _ Out_Of_Memory = "Ran out of memory"
   24.58 -  | string_of_failure _ (Abnormal_Termination err) =
   24.59 -      "Solver terminated abnormally with error code " ^ string_of_int err
   24.60 -  | string_of_failure _ (Other_Failure msg) = msg
   24.61 -
   24.62 -exception SMT of failure
   24.63 -
   24.64 -end
    25.1 --- a/src/HOL/Library/Old_SMT/smt_normalize.ML	Thu Aug 28 00:40:38 2014 +0200
    25.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.3 @@ -1,652 +0,0 @@
    25.4 -(*  Title:      HOL/Library/Old_SMT/smt_normalize.ML
    25.5 -    Author:     Sascha Boehme, TU Muenchen
    25.6 -
    25.7 -Normalization steps on theorems required by SMT solvers.
    25.8 -*)
    25.9 -
   25.10 -signature SMT_NORMALIZE =
   25.11 -sig
   25.12 -  val drop_fact_warning: Proof.context -> thm -> unit
   25.13 -  val atomize_conv: Proof.context -> conv
   25.14 -  type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
   25.15 -  val add_extra_norm: SMT_Utils.class * extra_norm -> Context.generic ->
   25.16 -    Context.generic
   25.17 -  val normalize: (int * (int option * thm)) list -> Proof.context ->
   25.18 -    (int * thm) list * Proof.context
   25.19 -  val setup: theory -> theory
   25.20 -end
   25.21 -
   25.22 -structure SMT_Normalize: SMT_NORMALIZE =
   25.23 -struct
   25.24 -
   25.25 -fun drop_fact_warning ctxt =
   25.26 -  SMT_Config.verbose_msg ctxt (prefix "Warning: dropping assumption: " o
   25.27 -    Display.string_of_thm ctxt)
   25.28 -
   25.29 -
   25.30 -(* general theorem normalizations *)
   25.31 -
   25.32 -(** instantiate elimination rules **)
   25.33 - 
   25.34 -local
   25.35 -  val (cpfalse, cfalse) =
   25.36 -    `SMT_Utils.mk_cprop (Thm.cterm_of @{theory} @{const False})
   25.37 -
   25.38 -  fun inst f ct thm =
   25.39 -    let val cv = f (Drule.strip_imp_concl (Thm.cprop_of thm))
   25.40 -    in Thm.instantiate ([], [(cv, ct)]) thm end
   25.41 -in
   25.42 -
   25.43 -fun instantiate_elim thm =
   25.44 -  (case Thm.concl_of thm of
   25.45 -    @{const Trueprop} $ Var (_, @{typ bool}) => inst Thm.dest_arg cfalse thm
   25.46 -  | Var _ => inst I cpfalse thm
   25.47 -  | _ => thm)
   25.48 -
   25.49 -end
   25.50 -
   25.51 -
   25.52 -(** normalize definitions **)
   25.53 -
   25.54 -fun norm_def thm =
   25.55 -  (case Thm.prop_of thm of
   25.56 -    @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _ $ Abs _) =>
   25.57 -      norm_def (thm RS @{thm fun_cong})
   25.58 -  | Const (@{const_name Pure.eq}, _) $ _ $ Abs _ =>
   25.59 -      norm_def (thm RS @{thm meta_eq_to_obj_eq})
   25.60 -  | _ => thm)
   25.61 -
   25.62 -
   25.63 -(** atomization **)
   25.64 -
   25.65 -fun atomize_conv ctxt ct =
   25.66 -  (case Thm.term_of ct of
   25.67 -    @{const Pure.imp} $ _ $ _ =>
   25.68 -      Conv.binop_conv (atomize_conv ctxt) then_conv
   25.69 -      Conv.rewr_conv @{thm atomize_imp}
   25.70 -  | Const (@{const_name Pure.eq}, _) $ _ $ _ =>
   25.71 -      Conv.binop_conv (atomize_conv ctxt) then_conv
   25.72 -      Conv.rewr_conv @{thm atomize_eq}
   25.73 -  | Const (@{const_name Pure.all}, _) $ Abs _ =>
   25.74 -      Conv.binder_conv (atomize_conv o snd) ctxt then_conv
   25.75 -      Conv.rewr_conv @{thm atomize_all}
   25.76 -  | _ => Conv.all_conv) ct
   25.77 -
   25.78 -val setup_atomize =
   25.79 -  fold SMT_Builtin.add_builtin_fun_ext'' [@{const_name Pure.imp},
   25.80 -    @{const_name Pure.eq}, @{const_name Pure.all}, @{const_name Trueprop}]
   25.81 -
   25.82 -
   25.83 -(** unfold special quantifiers **)
   25.84 -
   25.85 -local
   25.86 -  val ex1_def = mk_meta_eq @{lemma
   25.87 -    "Ex1 = (%P. EX x. P x & (ALL y. P y --> y = x))"
   25.88 -    by (rule ext) (simp only: Ex1_def)}
   25.89 -
   25.90 -  val ball_def = mk_meta_eq @{lemma "Ball = (%A P. ALL x. x : A --> P x)"
   25.91 -    by (rule ext)+ (rule Ball_def)}
   25.92 -
   25.93 -  val bex_def = mk_meta_eq @{lemma "Bex = (%A P. EX x. x : A & P x)"
   25.94 -    by (rule ext)+ (rule Bex_def)}
   25.95 -
   25.96 -  val special_quants = [(@{const_name Ex1}, ex1_def),
   25.97 -    (@{const_name Ball}, ball_def), (@{const_name Bex}, bex_def)]
   25.98 -  
   25.99 -  fun special_quant (Const (n, _)) = AList.lookup (op =) special_quants n
  25.100 -    | special_quant _ = NONE
  25.101 -
  25.102 -  fun special_quant_conv _ ct =
  25.103 -    (case special_quant (Thm.term_of ct) of
  25.104 -      SOME thm => Conv.rewr_conv thm
  25.105 -    | NONE => Conv.all_conv) ct
  25.106 -in
  25.107 -
  25.108 -fun unfold_special_quants_conv ctxt =
  25.109 -  SMT_Utils.if_exists_conv (is_some o special_quant)
  25.110 -    (Conv.top_conv special_quant_conv ctxt)
  25.111 -
  25.112 -val setup_unfolded_quants =
  25.113 -  fold (SMT_Builtin.add_builtin_fun_ext'' o fst) special_quants
  25.114 -
  25.115 -end
  25.116 -
  25.117 -
  25.118 -(** trigger inference **)
  25.119 -
  25.120 -local
  25.121 -  (*** check trigger syntax ***)
  25.122 -
  25.123 -  fun dest_trigger (Const (@{const_name pat}, _) $ _) = SOME true
  25.124 -    | dest_trigger (Const (@{const_name nopat}, _) $ _) = SOME false
  25.125 -    | dest_trigger _ = NONE
  25.126 -
  25.127 -  fun eq_list [] = false
  25.128 -    | eq_list (b :: bs) = forall (equal b) bs
  25.129 -
  25.130 -  fun proper_trigger t =
  25.131 -    t
  25.132 -    |> these o try HOLogic.dest_list
  25.133 -    |> map (map_filter dest_trigger o these o try HOLogic.dest_list)
  25.134 -    |> (fn [] => false | bss => forall eq_list bss)
  25.135 -
  25.136 -  fun proper_quant inside f t =
  25.137 -    (case t of
  25.138 -      Const (@{const_name All}, _) $ Abs (_, _, u) => proper_quant true f u
  25.139 -    | Const (@{const_name Ex}, _) $ Abs (_, _, u) => proper_quant true f u
  25.140 -    | @{const trigger} $ p $ u =>
  25.141 -        (if inside then f p else false) andalso proper_quant false f u
  25.142 -    | Abs (_, _, u) => proper_quant false f u
  25.143 -    | u1 $ u2 => proper_quant false f u1 andalso proper_quant false f u2
  25.144 -    | _ => true)
  25.145 -
  25.146 -  fun check_trigger_error ctxt t =
  25.147 -    error ("SMT triggers must only occur under quantifier and multipatterns " ^
  25.148 -      "must have the same kind: " ^ Syntax.string_of_term ctxt t)
  25.149 -
  25.150 -  fun check_trigger_conv ctxt ct =
  25.151 -    if proper_quant false proper_trigger (SMT_Utils.term_of ct) then
  25.152 -      Conv.all_conv ct
  25.153 -    else check_trigger_error ctxt (Thm.term_of ct)
  25.154 -
  25.155 -
  25.156 -  (*** infer simple triggers ***)
  25.157 -
  25.158 -  fun dest_cond_eq ct =
  25.159 -    (case Thm.term_of ct of
  25.160 -      Const (@{const_name HOL.eq}, _) $ _ $ _ => Thm.dest_binop ct
  25.161 -    | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct)
  25.162 -    | _ => raise CTERM ("no equation", [ct]))
  25.163 -
  25.164 -  fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n)
  25.165 -    | get_constrs _ _ = []
  25.166 -
  25.167 -  fun is_constr thy (n, T) =
  25.168 -    let fun match (m, U) = m = n andalso Sign.typ_instance thy (T, U)
  25.169 -    in can (the o find_first match o get_constrs thy o Term.body_type) T end
  25.170 -
  25.171 -  fun is_constr_pat thy t =
  25.172 -    (case Term.strip_comb t of
  25.173 -      (Free _, []) => true
  25.174 -    | (Const c, ts) => is_constr thy c andalso forall (is_constr_pat thy) ts
  25.175 -    | _ => false)
  25.176 -
  25.177 -  fun is_simp_lhs ctxt t =
  25.178 -    (case Term.strip_comb t of
  25.179 -      (Const c, ts as _ :: _) =>
  25.180 -        not (SMT_Builtin.is_builtin_fun_ext ctxt c ts) andalso
  25.181 -        forall (is_constr_pat (Proof_Context.theory_of ctxt)) ts
  25.182 -    | _ => false)
  25.183 -
  25.184 -  fun has_all_vars vs t =
  25.185 -    subset (op aconv) (vs, map Free (Term.add_frees t []))
  25.186 -
  25.187 -  fun minimal_pats vs ct =
  25.188 -    if has_all_vars vs (Thm.term_of ct) then
  25.189 -      (case Thm.term_of ct of
  25.190 -        _ $ _ =>
  25.191 -          (case pairself (minimal_pats vs) (Thm.dest_comb ct) of
  25.192 -            ([], []) => [[ct]]
  25.193 -          | (ctss, ctss') => union (eq_set (op aconvc)) ctss ctss')
  25.194 -      | _ => [])
  25.195 -    else []
  25.196 -
  25.197 -  fun proper_mpat _ _ _ [] = false
  25.198 -    | proper_mpat thy gen u cts =
  25.199 -        let
  25.200 -          val tps = (op ~~) (`gen (map Thm.term_of cts))
  25.201 -          fun some_match u = tps |> exists (fn (t', t) =>
  25.202 -            Pattern.matches thy (t', u) andalso not (t aconv u))
  25.203 -        in not (Term.exists_subterm some_match u) end
  25.204 -
  25.205 -  val pat =
  25.206 -    SMT_Utils.mk_const_pat @{theory} @{const_name pat} SMT_Utils.destT1
  25.207 -  fun mk_pat ct = Thm.apply (SMT_Utils.instT' ct pat) ct
  25.208 -
  25.209 -  fun mk_clist T = pairself (Thm.cterm_of @{theory})
  25.210 -    (HOLogic.cons_const T, HOLogic.nil_const T)
  25.211 -  fun mk_list (ccons, cnil) f cts = fold_rev (Thm.mk_binop ccons o f) cts cnil
  25.212 -  val mk_pat_list = mk_list (mk_clist @{typ pattern})
  25.213 -  val mk_mpat_list = mk_list (mk_clist @{typ "pattern list"})  
  25.214 -  fun mk_trigger ctss = mk_mpat_list (mk_pat_list mk_pat) ctss
  25.215 -
  25.216 -  val trigger_eq =
  25.217 -    mk_meta_eq @{lemma "p = trigger t p" by (simp add: trigger_def)}
  25.218 -
  25.219 -  fun insert_trigger_conv [] ct = Conv.all_conv ct
  25.220 -    | insert_trigger_conv ctss ct =
  25.221 -        let val (ctr, cp) = Thm.dest_binop (Thm.rhs_of trigger_eq) ||> rpair ct
  25.222 -        in Thm.instantiate ([], [cp, (ctr, mk_trigger ctss)]) trigger_eq end
  25.223 -
  25.224 -  fun infer_trigger_eq_conv outer_ctxt (ctxt, cvs) ct =
  25.225 -    let
  25.226 -      val (lhs, rhs) = dest_cond_eq ct
  25.227 -
  25.228 -      val vs = map Thm.term_of cvs
  25.229 -      val thy = Proof_Context.theory_of ctxt
  25.230 -
  25.231 -      fun get_mpats ct =
  25.232 -        if is_simp_lhs ctxt (Thm.term_of ct) then minimal_pats vs ct
  25.233 -        else []
  25.234 -      val gen = Variable.export_terms ctxt outer_ctxt
  25.235 -      val filter_mpats = filter (proper_mpat thy gen (Thm.term_of rhs))
  25.236 -
  25.237 -    in insert_trigger_conv (filter_mpats (get_mpats lhs)) ct end
  25.238 -
  25.239 -  fun has_trigger (@{const trigger} $ _ $ _) = true
  25.240 -    | has_trigger _ = false
  25.241 -
  25.242 -  fun try_trigger_conv cv ct =
  25.243 -    if SMT_Utils.under_quant has_trigger (SMT_Utils.term_of ct) then
  25.244 -      Conv.all_conv ct
  25.245 -    else Conv.try_conv cv ct
  25.246 -
  25.247 -  fun infer_trigger_conv ctxt =
  25.248 -    if Config.get ctxt SMT_Config.infer_triggers then
  25.249 -      try_trigger_conv
  25.250 -        (SMT_Utils.under_quant_conv (infer_trigger_eq_conv ctxt) ctxt)
  25.251 -    else Conv.all_conv
  25.252 -in
  25.253 -
  25.254 -fun trigger_conv ctxt =
  25.255 -  SMT_Utils.prop_conv
  25.256 -    (check_trigger_conv ctxt then_conv infer_trigger_conv ctxt)
  25.257 -
  25.258 -val setup_trigger =
  25.259 -  fold SMT_Builtin.add_builtin_fun_ext''
  25.260 -    [@{const_name pat}, @{const_name nopat}, @{const_name trigger}]
  25.261 -
  25.262 -end
  25.263 -
  25.264 -
  25.265 -(** adding quantifier weights **)
  25.266 -
  25.267 -local
  25.268 -  (*** check weight syntax ***)
  25.269 -
  25.270 -  val has_no_weight =
  25.271 -    not o Term.exists_subterm (fn @{const weight} => true | _ => false)
  25.272 -
  25.273 -  fun is_weight (@{const weight} $ w $ t) =
  25.274 -        (case try HOLogic.dest_number w of
  25.275 -          SOME (_, i) => i >= 0 andalso has_no_weight t
  25.276 -        | _ => false)
  25.277 -    | is_weight t = has_no_weight t
  25.278 -
  25.279 -  fun proper_trigger (@{const trigger} $ _ $ t) = is_weight t
  25.280 -    | proper_trigger t = is_weight t 
  25.281 -
  25.282 -  fun check_weight_error ctxt t =
  25.283 -    error ("SMT weight must be a non-negative number and must only occur " ^
  25.284 -      "under the top-most quantifier and an optional trigger: " ^
  25.285 -      Syntax.string_of_term ctxt t)
  25.286 -
  25.287 -  fun check_weight_conv ctxt ct =
  25.288 -    if SMT_Utils.under_quant proper_trigger (SMT_Utils.term_of ct) then
  25.289 -      Conv.all_conv ct
  25.290 -    else check_weight_error ctxt (Thm.term_of ct)
  25.291 -
  25.292 -
  25.293 -  (*** insertion of weights ***)
  25.294 -
  25.295 -  fun under_trigger_conv cv ct =
  25.296 -    (case Thm.term_of ct of
  25.297 -      @{const trigger} $ _ $ _ => Conv.arg_conv cv
  25.298 -    | _ => cv) ct
  25.299 -
  25.300 -  val weight_eq =
  25.301 -    mk_meta_eq @{lemma "p = weight i p" by (simp add: weight_def)}
  25.302 -  fun mk_weight_eq w =
  25.303 -    let val cv = Thm.dest_arg1 (Thm.rhs_of weight_eq)
  25.304 -    in
  25.305 -      Thm.instantiate ([], [(cv, Numeral.mk_cnumber @{ctyp int} w)]) weight_eq
  25.306 -    end
  25.307 -
  25.308 -  fun add_weight_conv NONE _ = Conv.all_conv
  25.309 -    | add_weight_conv (SOME weight) ctxt =
  25.310 -        let val cv = Conv.rewr_conv (mk_weight_eq weight)
  25.311 -        in SMT_Utils.under_quant_conv (K (under_trigger_conv cv)) ctxt end
  25.312 -in
  25.313 -
  25.314 -fun weight_conv weight ctxt = 
  25.315 -  SMT_Utils.prop_conv
  25.316 -    (check_weight_conv ctxt then_conv add_weight_conv weight ctxt)
  25.317 -
  25.318 -val setup_weight = SMT_Builtin.add_builtin_fun_ext'' @{const_name weight}
  25.319 -
  25.320 -end
  25.321 -
  25.322 -
  25.323 -(** combined general normalizations **)
  25.324 -
  25.325 -fun gen_normalize1_conv ctxt weight =
  25.326 -  atomize_conv ctxt then_conv
  25.327 -  unfold_special_quants_conv ctxt then_conv
  25.328 -  Thm.beta_conversion true then_conv
  25.329 -  trigger_conv ctxt then_conv
  25.330 -  weight_conv weight ctxt
  25.331 -
  25.332 -fun gen_normalize1 ctxt weight thm =
  25.333 -  thm
  25.334 -  |> instantiate_elim
  25.335 -  |> norm_def
  25.336 -  |> Conv.fconv_rule (Thm.beta_conversion true then_conv Thm.eta_conversion)
  25.337 -  |> Drule.forall_intr_vars
  25.338 -  |> Conv.fconv_rule (gen_normalize1_conv ctxt weight)
  25.339 -
  25.340 -fun gen_norm1_safe ctxt (i, (weight, thm)) =
  25.341 -  (case try (gen_normalize1 ctxt weight) thm of
  25.342 -    SOME thm' => SOME (i, thm')
  25.343 -  | NONE => (drop_fact_warning ctxt thm; NONE))
  25.344 -
  25.345 -fun gen_normalize ctxt iwthms = map_filter (gen_norm1_safe ctxt) iwthms
  25.346 -
  25.347 -
  25.348 -
  25.349 -(* unfolding of definitions and theory-specific rewritings *)
  25.350 -
  25.351 -fun expand_head_conv cv ct =
  25.352 -  (case Thm.term_of ct of
  25.353 -    _ $ _ =>
  25.354 -      Conv.fun_conv (expand_head_conv cv) then_conv
  25.355 -      Conv.try_conv (Thm.beta_conversion false)
  25.356 -  | _ => cv) ct
  25.357 -
  25.358 -
  25.359 -(** rewrite bool case expressions as if expressions **)
  25.360 -
  25.361 -local
  25.362 -  fun is_case_bool (Const (@{const_name "bool.case_bool"}, _)) = true
  25.363 -    | is_case_bool _ = false
  25.364 -
  25.365 -  val thm = mk_meta_eq @{lemma
  25.366 -    "case_bool = (%x y P. if P then x else y)" by (rule ext)+ simp}
  25.367 -
  25.368 -  fun unfold_conv _ =
  25.369 -    SMT_Utils.if_true_conv (is_case_bool o Term.head_of)
  25.370 -      (expand_head_conv (Conv.rewr_conv thm))
  25.371 -in
  25.372 -
  25.373 -fun rewrite_case_bool_conv ctxt =
  25.374 -  SMT_Utils.if_exists_conv is_case_bool (Conv.top_conv unfold_conv ctxt)
  25.375 -
  25.376 -val setup_case_bool =
  25.377 -  SMT_Builtin.add_builtin_fun_ext'' @{const_name "bool.case_bool"}
  25.378 -
  25.379 -end
  25.380 -
  25.381 -
  25.382 -(** unfold abs, min and max **)
  25.383 -
  25.384 -local
  25.385 -  val abs_def = mk_meta_eq @{lemma
  25.386 -    "abs = (%a::'a::abs_if. if a < 0 then - a else a)"
  25.387 -    by (rule ext) (rule abs_if)}
  25.388 -
  25.389 -  val min_def = mk_meta_eq @{lemma "min = (%a b. if a <= b then a else b)"
  25.390 -    by (rule ext)+ (rule min_def)}
  25.391 -
  25.392 -  val max_def = mk_meta_eq  @{lemma "max = (%a b. if a <= b then b else a)"
  25.393 -    by (rule ext)+ (rule max_def)}
  25.394 -
  25.395 -  val defs = [(@{const_name min}, min_def), (@{const_name max}, max_def),
  25.396 -    (@{const_name abs}, abs_def)]
  25.397 -
  25.398 -  fun is_builtinT ctxt T =
  25.399 -    SMT_Builtin.is_builtin_typ_ext ctxt (Term.domain_type T)
  25.400 -
  25.401 -  fun abs_min_max ctxt (Const (n, T)) =
  25.402 -        (case AList.lookup (op =) defs n of
  25.403 -          NONE => NONE
  25.404 -        | SOME thm => if is_builtinT ctxt T then SOME thm else NONE)
  25.405 -    | abs_min_max _ _ = NONE
  25.406 -
  25.407 -  fun unfold_amm_conv ctxt ct =
  25.408 -    (case abs_min_max ctxt (Term.head_of (Thm.term_of ct)) of
  25.409 -      SOME thm => expand_head_conv (Conv.rewr_conv thm)
  25.410 -    | NONE => Conv.all_conv) ct
  25.411 -in
  25.412 -
  25.413 -fun unfold_abs_min_max_conv ctxt =
  25.414 -  SMT_Utils.if_exists_conv (is_some o abs_min_max ctxt)
  25.415 -    (Conv.top_conv unfold_amm_conv ctxt)
  25.416 -  
  25.417 -val setup_abs_min_max = fold (SMT_Builtin.add_builtin_fun_ext'' o fst) defs
  25.418 -
  25.419 -end
  25.420 -
  25.421 -
  25.422 -(** embedding of standard natural number operations into integer operations **)
  25.423 -
  25.424 -local
  25.425 -  val nat_embedding = @{lemma
  25.426 -    "ALL n. nat (int n) = n"
  25.427 -    "ALL i. i >= 0 --> int (nat i) = i"
  25.428 -    "ALL i. i < 0 --> int (nat i) = 0"
  25.429 -    by simp_all}
  25.430 -
  25.431 -  val simple_nat_ops = [
  25.432 -    @{const less (nat)}, @{const less_eq (nat)},
  25.433 -    @{const Suc}, @{const plus (nat)}, @{const minus (nat)}]
  25.434 -
  25.435 -  val mult_nat_ops =
  25.436 -    [@{const times (nat)}, @{const div (nat)}, @{const mod (nat)}]
  25.437 -
  25.438 -  val nat_ops = simple_nat_ops @ mult_nat_ops
  25.439 -
  25.440 -  val nat_consts = nat_ops @ [@{const numeral (nat)},
  25.441 -    @{const zero_class.zero (nat)}, @{const one_class.one (nat)}]
  25.442 -
  25.443 -  val nat_int_coercions = [@{const of_nat (int)}, @{const nat}]
  25.444 -
  25.445 -  val builtin_nat_ops = nat_int_coercions @ simple_nat_ops
  25.446 -
  25.447 -  val is_nat_const = member (op aconv) nat_consts
  25.448 -
  25.449 -  fun is_nat_const' @{const of_nat (int)} = true
  25.450 -    | is_nat_const' t = is_nat_const t
  25.451 -
  25.452 -  val expands = map mk_meta_eq @{lemma
  25.453 -    "0 = nat 0"
  25.454 -    "1 = nat 1"
  25.455 -    "(numeral :: num => nat) = (%i. nat (numeral i))"
  25.456 -    "op < = (%a b. int a < int b)"
  25.457 -    "op <= = (%a b. int a <= int b)"
  25.458 -    "Suc = (%a. nat (int a + 1))"
  25.459 -    "op + = (%a b. nat (int a + int b))"
  25.460 -    "op - = (%a b. nat (int a - int b))"
  25.461 -    "op * = (%a b. nat (int a * int b))"
  25.462 -    "op div = (%a b. nat (int a div int b))"
  25.463 -    "op mod = (%a b. nat (int a mod int b))"
  25.464 -    by (fastforce simp add: nat_mult_distrib nat_div_distrib nat_mod_distrib)+}
  25.465 -
  25.466 -  val ints = map mk_meta_eq @{lemma
  25.467 -    "int 0 = 0"
  25.468 -    "int 1 = 1"
  25.469 -    "int (Suc n) = int n + 1"
  25.470 -    "int (n + m) = int n + int m"
  25.471 -    "int (n - m) = int (nat (int n - int m))"
  25.472 -    "int (n * m) = int n * int m"
  25.473 -    "int (n div m) = int n div int m"
  25.474 -    "int (n mod m) = int n mod int m"
  25.475 -    by (auto simp add: int_mult zdiv_int zmod_int)}
  25.476 -
  25.477 -  val int_if = mk_meta_eq @{lemma
  25.478 -    "int (if P then n else m) = (if P then int n else int m)"
  25.479 -    by simp}
  25.480 -
  25.481 -  fun mk_number_eq ctxt i lhs =
  25.482 -    let
  25.483 -      val eq = SMT_Utils.mk_cequals lhs (Numeral.mk_cnumber @{ctyp int} i)
  25.484 -      val tac =
  25.485 -        Simplifier.simp_tac (put_simpset HOL_ss ctxt addsimps [@{thm Int.int_numeral}]) 1
  25.486 -    in Goal.norm_result ctxt (Goal.prove_internal ctxt [] eq (K tac)) end
  25.487 -
  25.488 -  fun ite_conv cv1 cv2 =
  25.489 -    Conv.combination_conv (Conv.combination_conv (Conv.arg_conv cv1) cv2) cv2
  25.490 -
  25.491 -  fun int_conv ctxt ct =
  25.492 -    (case Thm.term_of ct of
  25.493 -      @{const of_nat (int)} $ (n as (@{const numeral (nat)} $ _)) =>
  25.494 -        Conv.rewr_conv (mk_number_eq ctxt (snd (HOLogic.dest_number n)) ct)
  25.495 -    | @{const of_nat (int)} $ _ =>
  25.496 -        (Conv.rewrs_conv ints then_conv Conv.sub_conv ints_conv ctxt) else_conv
  25.497 -        (Conv.rewr_conv int_if then_conv
  25.498 -          ite_conv (nat_conv ctxt) (int_conv ctxt)) else_conv
  25.499 -        Conv.sub_conv (Conv.top_sweep_conv nat_conv) ctxt
  25.500 -    | _ => Conv.no_conv) ct
  25.501 -
  25.502 -  and ints_conv ctxt = Conv.top_sweep_conv int_conv ctxt
  25.503 -
  25.504 -  and expand_conv ctxt =
  25.505 -    SMT_Utils.if_conv (is_nat_const o Term.head_of)
  25.506 -      (expand_head_conv (Conv.rewrs_conv expands) then_conv ints_conv ctxt)
  25.507 -      (int_conv ctxt)
  25.508 -
  25.509 -  and nat_conv ctxt = SMT_Utils.if_exists_conv is_nat_const'
  25.510 -    (Conv.top_sweep_conv expand_conv ctxt)
  25.511 -
  25.512 -  val uses_nat_int = Term.exists_subterm (member (op aconv) nat_int_coercions)
  25.513 -in
  25.514 -
  25.515 -val nat_as_int_conv = nat_conv
  25.516 -
  25.517 -fun add_nat_embedding thms =
  25.518 -  if exists (uses_nat_int o Thm.prop_of) thms then (thms, nat_embedding)
  25.519 -  else (thms, [])
  25.520 -
  25.521 -val setup_nat_as_int =
  25.522 -  SMT_Builtin.add_builtin_typ_ext (@{typ nat}, K true) #>
  25.523 -  fold (SMT_Builtin.add_builtin_fun_ext' o Term.dest_Const) builtin_nat_ops
  25.524 -
  25.525 -end
  25.526 -
  25.527 -
  25.528 -(** normalize numerals **)
  25.529 -
  25.530 -local
  25.531 -  (*
  25.532 -    rewrite Numeral1 into 1
  25.533 -    rewrite - 0 into 0
  25.534 -  *)
  25.535 -
  25.536 -  fun is_irregular_number (Const (@{const_name numeral}, _) $ Const (@{const_name num.One}, _)) =
  25.537 -        true
  25.538 -    | is_irregular_number (Const (@{const_name uminus}, _) $ Const (@{const_name Groups.zero}, _)) =
  25.539 -        true
  25.540 -    | is_irregular_number _ =
  25.541 -        false;
  25.542 -
  25.543 -  fun is_strange_number ctxt t = is_irregular_number t andalso SMT_Builtin.is_builtin_num ctxt t;
  25.544 -
  25.545 -  val proper_num_ss =
  25.546 -    simpset_of (put_simpset HOL_ss @{context}
  25.547 -      addsimps @{thms Num.numeral_One minus_zero})
  25.548 -
  25.549 -  fun norm_num_conv ctxt =
  25.550 -    SMT_Utils.if_conv (is_strange_number ctxt)
  25.551 -      (Simplifier.rewrite (put_simpset proper_num_ss ctxt)) Conv.no_conv
  25.552 -in
  25.553 -
  25.554 -fun normalize_numerals_conv ctxt =
  25.555 -  SMT_Utils.if_exists_conv (is_strange_number ctxt)
  25.556 -    (Conv.top_sweep_conv norm_num_conv ctxt)
  25.557 -
  25.558 -end
  25.559 -
  25.560 -
  25.561 -(** combined unfoldings and rewritings **)
  25.562 -
  25.563 -fun unfold_conv ctxt =
  25.564 -  rewrite_case_bool_conv ctxt then_conv
  25.565 -  unfold_abs_min_max_conv ctxt then_conv
  25.566 -  nat_as_int_conv ctxt then_conv
  25.567 -  Thm.beta_conversion true
  25.568 -
  25.569 -fun unfold1 ctxt = map (apsnd (Conv.fconv_rule (unfold_conv ctxt)))
  25.570 -
  25.571 -fun burrow_ids f ithms =
  25.572 -  let
  25.573 -    val (is, thms) = split_list ithms
  25.574 -    val (thms', extra_thms) = f thms
  25.575 -  in (is ~~ thms') @ map (pair ~1) extra_thms end
  25.576 -
  25.577 -fun unfold2 ctxt ithms =
  25.578 -  ithms
  25.579 -  |> map (apsnd (Conv.fconv_rule (normalize_numerals_conv ctxt)))
  25.580 -  |> burrow_ids add_nat_embedding
  25.581 -
  25.582 -
  25.583 -
  25.584 -(* overall normalization *)
  25.585 -
  25.586 -type extra_norm = Proof.context -> thm list * thm list -> thm list * thm list
  25.587 -
  25.588 -structure Extra_Norms = Generic_Data
  25.589 -(
  25.590 -  type T = extra_norm SMT_Utils.dict
  25.591 -  val empty = []
  25.592 -  val extend = I
  25.593 -  fun merge data = SMT_Utils.dict_merge fst data
  25.594 -)
  25.595 -
  25.596 -fun add_extra_norm (cs, norm) =
  25.597 -  Extra_Norms.map (SMT_Utils.dict_update (cs, norm))
  25.598 -
  25.599 -fun apply_extra_norms ctxt ithms =
  25.600 -  let
  25.601 -    val cs = SMT_Config.solver_class_of ctxt
  25.602 -    val es = SMT_Utils.dict_lookup (Extra_Norms.get (Context.Proof ctxt)) cs
  25.603 -  in burrow_ids (fold (fn e => e ctxt) es o rpair []) ithms end
  25.604 -
  25.605 -local
  25.606 -  val ignored = member (op =) [@{const_name All}, @{const_name Ex},
  25.607 -    @{const_name Let}, @{const_name If}, @{const_name HOL.eq}]
  25.608 -
  25.609 -  val schematic_consts_of =
  25.610 -    let
  25.611 -      fun collect (@{const trigger} $ p $ t) =
  25.612 -            collect_trigger p #> collect t
  25.613 -        | collect (t $ u) = collect t #> collect u
  25.614 -        | collect (Abs (_, _, t)) = collect t
  25.615 -        | collect (t as Const (n, _)) = 
  25.616 -            if not (ignored n) then Monomorph.add_schematic_consts_of t else I
  25.617 -        | collect _ = I
  25.618 -      and collect_trigger t =
  25.619 -        let val dest = these o try HOLogic.dest_list 
  25.620 -        in fold (fold collect_pat o dest) (dest t) end
  25.621 -      and collect_pat (Const (@{const_name pat}, _) $ t) = collect t
  25.622 -        | collect_pat (Const (@{const_name nopat}, _) $ t) = collect t
  25.623 -        | collect_pat _ = I
  25.624 -    in (fn t => collect t Symtab.empty) end
  25.625 -in
  25.626 -
  25.627 -fun monomorph ctxt xthms =
  25.628 -  let val (xs, thms) = split_list xthms
  25.629 -  in
  25.630 -    map (pair 1) thms
  25.631 -    |> Monomorph.monomorph schematic_consts_of ctxt
  25.632 -    |> maps (uncurry (map o pair)) o map2 pair xs o map (map snd)
  25.633 -  end
  25.634 -
  25.635 -end
  25.636 -
  25.637 -fun normalize iwthms ctxt =
  25.638 -  iwthms
  25.639 -  |> gen_normalize ctxt
  25.640 -  |> unfold1 ctxt
  25.641 -  |> monomorph ctxt
  25.642 -  |> unfold2 ctxt
  25.643 -  |> apply_extra_norms ctxt
  25.644 -  |> rpair ctxt
  25.645 -
  25.646 -val setup = Context.theory_map (
  25.647 -  setup_atomize #>
  25.648 -  setup_unfolded_quants #>
  25.649 -  setup_trigger #>
  25.650 -  setup_weight #>
  25.651 -  setup_case_bool #>
  25.652 -  setup_abs_min_max #>
  25.653 -  setup_nat_as_int)
  25.654 -
  25.655 -end
    26.1 --- a/src/HOL/Library/Old_SMT/smt_real.ML	Thu Aug 28 00:40:38 2014 +0200
    26.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.3 @@ -1,136 +0,0 @@
    26.4 -(*  Title:      HOL/Library/Old_SMT/smt_real.ML
    26.5 -    Author:     Sascha Boehme, TU Muenchen
    26.6 -
    26.7 -SMT setup for reals.
    26.8 -*)
    26.9 -
   26.10 -signature SMT_REAL =
   26.11 -sig
   26.12 -  val setup: theory -> theory
   26.13 -end
   26.14 -
   26.15 -structure SMT_Real: SMT_REAL =
   26.16 -struct
   26.17 -
   26.18 -
   26.19 -(* SMT-LIB logic *)
   26.20 -
   26.21 -fun smtlib_logic ts =
   26.22 -  if exists (Term.exists_type (Term.exists_subtype (equal @{typ real}))) ts
   26.23 -  then SOME "AUFLIRA"
   26.24 -  else NONE
   26.25 -
   26.26 -
   26.27 -(* SMT-LIB and Z3 built-ins *)
   26.28 -
   26.29 -local
   26.30 -  fun real_num _ i = SOME (string_of_int i ^ ".0")
   26.31 -
   26.32 -  fun is_linear [t] = SMT_Utils.is_number t
   26.33 -    | is_linear [t, u] = SMT_Utils.is_number t orelse SMT_Utils.is_number u
   26.34 -    | is_linear _ = false
   26.35 -
   26.36 -  fun mk_times ts = Term.list_comb (@{const times (real)}, ts)
   26.37 -
   26.38 -  fun times _ _ ts = if is_linear ts then SOME ("*", 2, ts, mk_times) else NONE
   26.39 -in
   26.40 -
   26.41 -val setup_builtins =
   26.42 -  SMT_Builtin.add_builtin_typ SMTLIB_Interface.smtlibC
   26.43 -    (@{typ real}, K (SOME "Real"), real_num) #>
   26.44 -  fold (SMT_Builtin.add_builtin_fun' SMTLIB_Interface.smtlibC) [
   26.45 -    (@{const less (real)}, "<"),
   26.46 -    (@{const less_eq (real)}, "<="),
   26.47 -    (@{const uminus (real)}, "~"),
   26.48 -    (@{const plus (real)}, "+"),
   26.49 -    (@{const minus (real)}, "-") ] #>
   26.50 -  SMT_Builtin.add_builtin_fun SMTLIB_Interface.smtlibC
   26.51 -    (Term.dest_Const @{const times (real)}, times) #>
   26.52 -  SMT_Builtin.add_builtin_fun' Z3_Interface.smtlib_z3C
   26.53 -    (@{const times (real)}, "*") #>
   26.54 -  SMT_Builtin.add_builtin_fun' Z3_Interface.smtlib_z3C
   26.55 -    (@{const divide (real)}, "/")
   26.56 -
   26.57 -end
   26.58 -
   26.59 -
   26.60 -(* Z3 constructors *)
   26.61 -
   26.62 -local
   26.63 -  fun z3_mk_builtin_typ (Z3_Interface.Sym ("Real", _)) = SOME @{typ real}
   26.64 -    | z3_mk_builtin_typ (Z3_Interface.Sym ("real", _)) = SOME @{typ real}
   26.65 -        (*FIXME: delete*)
   26.66 -    | z3_mk_builtin_typ _ = NONE
   26.67 -
   26.68 -  fun z3_mk_builtin_num _ i T =
   26.69 -    if T = @{typ real} then SOME (Numeral.mk_cnumber @{ctyp real} i)
   26.70 -    else NONE
   26.71 -
   26.72 -  fun mk_nary _ cu [] = cu
   26.73 -    | mk_nary ct _ cts = uncurry (fold_rev (Thm.mk_binop ct)) (split_last cts)
   26.74 -
   26.75 -  val mk_uminus = Thm.apply (Thm.cterm_of @{theory} @{const uminus (real)})
   26.76 -  val add = Thm.cterm_of @{theory} @{const plus (real)}
   26.77 -  val real0 = Numeral.mk_cnumber @{ctyp real} 0
   26.78 -  val mk_sub = Thm.mk_binop (Thm.cterm_of @{theory} @{const minus (real)})
   26.79 -  val mk_mul = Thm.mk_binop (Thm.cterm_of @{theory} @{const times (real)})
   26.80 -  val mk_div = Thm.mk_binop (Thm.cterm_of @{theory} @{const divide (real)})
   26.81 -  val mk_lt = Thm.mk_binop (Thm.cterm_of @{theory} @{const less (real)})
   26.82 -  val mk_le = Thm.mk_binop (Thm.cterm_of @{theory} @{const less_eq (real)})
   26.83 -
   26.84 -  fun z3_mk_builtin_fun (Z3_Interface.Sym ("-", _)) [ct] = SOME (mk_uminus ct)
   26.85 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("+", _)) cts =
   26.86 -        SOME (mk_nary add real0 cts)
   26.87 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("-", _)) [ct, cu] =
   26.88 -        SOME (mk_sub ct cu)
   26.89 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("*", _)) [ct, cu] =
   26.90 -        SOME (mk_mul ct cu)
   26.91 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("/", _)) [ct, cu] =
   26.92 -        SOME (mk_div ct cu)
   26.93 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("<", _)) [ct, cu] =
   26.94 -        SOME (mk_lt ct cu)
   26.95 -    | z3_mk_builtin_fun (Z3_Interface.Sym ("<=", _)) [ct, cu] =
   26.96 -        SOME (mk_le ct cu)
   26.97 -    | z3_mk_builtin_fun (Z3_Interface.Sym (">", _)) [ct, cu] =
   26.98 -        SOME (mk_lt cu ct)
   26.99 -    | z3_mk_builtin_fun (Z3_Interface.Sym (">=", _)) [ct, cu] =
  26.100 -        SOME (mk_le cu ct)
  26.101 -    | z3_mk_builtin_fun _ _ = NONE
  26.102 -in
  26.103 -
  26.104 -val z3_mk_builtins = {
  26.105 -  mk_builtin_typ = z3_mk_builtin_typ,
  26.106 -  mk_builtin_num = z3_mk_builtin_num,
  26.107 -  mk_builtin_fun = (fn _ => fn sym => fn cts =>
  26.108 -    (case try (#T o Thm.rep_cterm o hd) cts of
  26.109 -      SOME @{typ real} => z3_mk_builtin_fun sym cts
  26.110 -    | _ => NONE)) }
  26.111 -
  26.112 -end
  26.113 -
  26.114 -
  26.115 -(* Z3 proof reconstruction *)
  26.116 -
  26.117 -val real_rules = @{lemma
  26.118 -  "0 + (x::real) = x"
  26.119 -  "x + 0 = x"
  26.120 -  "0 * x = 0"
  26.121 -  "1 * x = x"
  26.122 -  "x + y = y + x"
  26.123 -  by auto}
  26.124 -
  26.125 -val real_linarith_proc = Simplifier.simproc_global @{theory} "fast_real_arith" [
  26.126 -  "(m::real) < n", "(m::real) <= n", "(m::real) = n"] Lin_Arith.simproc
  26.127 -
  26.128 -
  26.129 -(* setup *)
  26.130 -
  26.131 -val setup =
  26.132 -  Context.theory_map (
  26.133 -    SMTLIB_Interface.add_logic (10, smtlib_logic) #>
  26.134 -    setup_builtins #>
  26.135 -    Z3_Interface.add_mk_builtins z3_mk_builtins #>
  26.136 -    fold Z3_Proof_Reconstruction.add_z3_rule real_rules #>
  26.137 -    Z3_Proof_Tools.add_simproc real_linarith_proc)
  26.138 -
  26.139 -end
    27.1 --- a/src/HOL/Library/Old_SMT/smt_setup_solvers.ML	Thu Aug 28 00:40:38 2014 +0200
    27.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.3 @@ -1,193 +0,0 @@
    27.4 -(*  Title:      HOL/Library/Old_SMT/smt_setup_solvers.ML
    27.5 -    Author:     Sascha Boehme, TU Muenchen
    27.6 -
    27.7 -Setup SMT solvers.
    27.8 -*)
    27.9 -
   27.10 -signature SMT_SETUP_SOLVERS =
   27.11 -sig
   27.12 -  datatype z3_non_commercial =
   27.13 -    Z3_Non_Commercial_Unknown |
   27.14 -    Z3_Non_Commercial_Accepted |
   27.15 -    Z3_Non_Commercial_Declined
   27.16 -  val z3_non_commercial: unit -> z3_non_commercial
   27.17 -  val z3_with_extensions: bool Config.T
   27.18 -  val setup: theory -> theory
   27.19 -end
   27.20 -
   27.21 -structure SMT_Setup_Solvers: SMT_SETUP_SOLVERS =
   27.22 -struct
   27.23 -
   27.24 -(* helper functions *)
   27.25 -
   27.26 -fun make_avail name () = getenv (name ^ "_SOLVER") <> ""
   27.27 -
   27.28 -fun make_command name () = [getenv (name ^ "_SOLVER")]
   27.29 -
   27.30 -fun outcome_of unsat sat unknown solver_name line =
   27.31 -  if String.isPrefix unsat line then SMT_Solver.Unsat
   27.32 -  else if String.isPrefix sat line then SMT_Solver.Sat
   27.33 -  else if String.isPrefix unknown line then SMT_Solver.Unknown
   27.34 -  else raise SMT_Failure.SMT (SMT_Failure.Other_Failure ("Solver " ^
   27.35 -    quote solver_name ^ " failed. Enable SMT tracing by setting the " ^
   27.36 -    "configuration option " ^ quote (Config.name_of SMT_Config.trace) ^ " and " ^
   27.37 -    "see the trace for details."))
   27.38 -
   27.39 -fun on_first_line test_outcome solver_name lines =
   27.40 -  let
   27.41 -    val empty_line = (fn "" => true | _ => false)
   27.42 -    val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
   27.43 -    val (l, ls) = split_first (snd (take_prefix empty_line lines))
   27.44 -  in (test_outcome solver_name l, ls) end
   27.45 -
   27.46 -
   27.47 -(* CVC3 *)
   27.48 -
   27.49 -local
   27.50 -  fun cvc3_options ctxt = [
   27.51 -    "-seed", string_of_int (Config.get ctxt SMT_Config.random_seed),
   27.52 -    "-lang", "smtlib", "-output-lang", "presentation",
   27.53 -    "-timeout", string_of_int (Real.ceil (Config.get ctxt SMT_Config.timeout))]
   27.54 -in
   27.55 -
   27.56 -val cvc3: SMT_Solver.solver_config = {
   27.57 -  name = "cvc3",
   27.58 -  class = K SMTLIB_Interface.smtlibC,
   27.59 -  avail = make_avail "CVC3",
   27.60 -  command = make_command "CVC3",
   27.61 -  options = cvc3_options,
   27.62 -  default_max_relevant = 400 (* FUDGE *),
   27.63 -  supports_filter = false,
   27.64 -  outcome =
   27.65 -    on_first_line (outcome_of "Unsatisfiable." "Satisfiable." "Unknown."),
   27.66 -  cex_parser = NONE,
   27.67 -  reconstruct = NONE }
   27.68 -
   27.69 -end
   27.70 -
   27.71 -
   27.72 -(* Yices *)
   27.73 -
   27.74 -val yices: SMT_Solver.solver_config = {
   27.75 -  name = "yices",
   27.76 -  class = K SMTLIB_Interface.smtlibC,
   27.77 -  avail = make_avail "YICES",
   27.78 -  command = make_command "YICES",
   27.79 -  options = (fn ctxt => [
   27.80 -    "--rand-seed=" ^ string_of_int (Config.get ctxt SMT_Config.random_seed),
   27.81 -    "--timeout=" ^
   27.82 -      string_of_int (Real.ceil (Config.get ctxt SMT_Config.timeout)),
   27.83 -    "--smtlib"]),
   27.84 -  default_max_relevant = 350 (* FUDGE *),
   27.85 -  supports_filter = false,
   27.86 -  outcome = on_first_line (outcome_of "unsat" "sat" "unknown"),
   27.87 -  cex_parser = NONE,
   27.88 -  reconstruct = NONE }
   27.89 -
   27.90 -
   27.91 -(* Z3 *)
   27.92 -
   27.93 -datatype z3_non_commercial =
   27.94 -  Z3_Non_Commercial_Unknown |
   27.95 -  Z3_Non_Commercial_Accepted |
   27.96 -  Z3_Non_Commercial_Declined
   27.97 -
   27.98 -
   27.99 -local
  27.100 -  val accepted = member (op =) ["yes", "Yes", "YES"]
  27.101 -  val declined = member (op =) ["no", "No", "NO"]
  27.102 -in
  27.103 -
  27.104 -fun z3_non_commercial () =
  27.105 -  let
  27.106 -    val flag1 = Options.default_string @{system_option z3_non_commercial}
  27.107 -    val flag2 = getenv "Z3_NON_COMMERCIAL"
  27.108 -  in
  27.109 -    if accepted flag1 then Z3_Non_Commercial_Accepted
  27.110 -    else if declined flag1 then Z3_Non_Commercial_Declined
  27.111 -    else if accepted flag2 then Z3_Non_Commercial_Accepted
  27.112 -    else if declined flag2 then Z3_Non_Commercial_Declined
  27.113 -    else Z3_Non_Commercial_Unknown
  27.114 -  end
  27.115 -
  27.116 -fun if_z3_non_commercial f =
  27.117 -  (case z3_non_commercial () of
  27.118 -    Z3_Non_Commercial_Accepted => f ()
  27.119 -  | Z3_Non_Commercial_Declined =>
  27.120 -      error (Pretty.string_of (Pretty.para
  27.121 -        "The SMT solver Z3 may only be used for non-commercial applications."))
  27.122 -  | Z3_Non_Commercial_Unknown =>
  27.123 -      error
  27.124 -        (Pretty.string_of
  27.125 -          (Pretty.para
  27.126 -            ("The SMT solver Z3 is not activated. To activate it, set the Isabelle \
  27.127 -             \system option \"z3_non_commercial\" to \"yes\" (e.g. via \
  27.128 -             \the Isabelle/jEdit menu Plugin Options / Isabelle / General).")) ^
  27.129 -        "\n\nSee also " ^ Url.print (Url.explode "http://z3.codeplex.com/license")))
  27.130 -
  27.131 -end
  27.132 -
  27.133 -
  27.134 -val z3_with_extensions =
  27.135 -  Attrib.setup_config_bool @{binding z3_with_extensions} (K false)
  27.136 -
  27.137 -local
  27.138 -  fun z3_make_command name () = if_z3_non_commercial (make_command name)
  27.139 -
  27.140 -  fun z3_options ctxt =
  27.141 -    ["-rs:" ^ string_of_int (Config.get ctxt SMT_Config.random_seed),
  27.142 -      "MODEL=true",
  27.143 -      "SOFT_TIMEOUT=" ^
  27.144 -        string_of_int (Real.ceil (1000.0 * Config.get ctxt SMT_Config.timeout)),
  27.145 -      "-smt"]
  27.146 -    |> not (Config.get ctxt SMT_Config.oracle) ?
  27.147 -         append ["DISPLAY_PROOF=true", "PROOF_MODE=2"]
  27.148 -
  27.149 -  fun z3_on_first_or_last_line solver_name lines =
  27.150 -    let
  27.151 -      fun junk l =
  27.152 -        if String.isPrefix "WARNING: Out of allocated virtual memory" l
  27.153 -        then raise SMT_Failure.SMT SMT_Failure.Out_Of_Memory
  27.154 -        else
  27.155 -          String.isPrefix "WARNING" l orelse
  27.156 -          String.isPrefix "ERROR" l orelse
  27.157 -          forall Symbol.is_ascii_blank (Symbol.explode l)
  27.158 -      val lines = filter_out junk lines
  27.159 -      fun outcome split =
  27.160 -        the_default ("", []) (try split lines)
  27.161 -        |>> outcome_of "unsat" "sat" "unknown" solver_name
  27.162 -    in
  27.163 -      (* Starting with version 4.0, Z3 puts the outcome on the first line of the
  27.164 -         output rather than on the last line. *)
  27.165 -      outcome (fn lines => (hd lines, tl lines))
  27.166 -      handle SMT_Failure.SMT _ => outcome (swap o split_last)
  27.167 -    end
  27.168 -
  27.169 -  fun select_class ctxt =
  27.170 -    if Config.get ctxt z3_with_extensions then Z3_Interface.smtlib_z3C
  27.171 -    else SMTLIB_Interface.smtlibC
  27.172 -in
  27.173 -
  27.174 -val z3: SMT_Solver.solver_config = {
  27.175 -  name = "z3",
  27.176 -  class = select_class,
  27.177 -  avail = make_avail "Z3",
  27.178 -  command = z3_make_command "Z3",
  27.179 -  options = z3_options,
  27.180 -  default_max_relevant = 350 (* FUDGE *),
  27.181 -  supports_filter = true,
  27.182 -  outcome = z3_on_first_or_last_line,
  27.183 -  cex_parser = SOME Z3_Model.parse_counterex,
  27.184 -  reconstruct = SOME Z3_Proof_Reconstruction.reconstruct }
  27.185 -
  27.186 -end
  27.187 -
  27.188 -
  27.189 -(* overall setup *)
  27.190 -
  27.191 -val setup =
  27.192 -  SMT_Solver.add_solver cvc3 #>
  27.193 -  SMT_Solver.add_solver yices #>
  27.194 -  SMT_Solver.add_solver z3
  27.195 -
  27.196 -end
    28.1 --- a/src/HOL/Library/Old_SMT/smt_solver.ML	Thu Aug 28 00:40:38 2014 +0200
    28.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.3 @@ -1,373 +0,0 @@
    28.4 -(*  Title:      HOL/Library/Old_SMT/smt_solver.ML
    28.5 -    Author:     Sascha Boehme, TU Muenchen
    28.6 -
    28.7 -SMT solvers registry and SMT tactic.
    28.8 -*)
    28.9 -
   28.10 -signature SMT_SOLVER =
   28.11 -sig
   28.12 -  (*configuration*)
   28.13 -  datatype outcome = Unsat | Sat | Unknown
   28.14 -  type solver_config = {
   28.15 -    name: string,
   28.16 -    class: Proof.context -> SMT_Utils.class,
   28.17 -    avail: unit -> bool,
   28.18 -    command: unit -> string list,
   28.19 -    options: Proof.context -> string list,
   28.20 -    default_max_relevant: int,
   28.21 -    supports_filter: bool,
   28.22 -    outcome: string -> string list -> outcome * string list,
   28.23 -    cex_parser: (Proof.context -> SMT_Translate.recon -> string list ->
   28.24 -      term list * term list) option,
   28.25 -    reconstruct: (Proof.context -> SMT_Translate.recon -> string list ->
   28.26 -      int list * thm) option }
   28.27 -
   28.28 -  (*registry*)
   28.29 -  val add_solver: solver_config -> theory -> theory
   28.30 -  val solver_name_of: Proof.context -> string
   28.31 -  val available_solvers_of: Proof.context -> string list
   28.32 -  val apply_solver: Proof.context -> (int * (int option * thm)) list ->
   28.33 -    int list * thm
   28.34 -  val default_max_relevant: Proof.context -> string -> int
   28.35 -
   28.36 -  (*filter*)
   28.37 -  type 'a smt_filter_data =
   28.38 -    ('a * thm) list * ((int * thm) list * Proof.context)
   28.39 -  val smt_filter_preprocess: Proof.context -> thm list -> thm ->
   28.40 -    ('a * (int option * thm)) list -> int -> 'a smt_filter_data
   28.41 -  val smt_filter_apply: Time.time -> 'a smt_filter_data ->
   28.42 -    {outcome: SMT_Failure.failure option, used_facts: ('a * thm) list}
   28.43 -
   28.44 -  (*tactic*)
   28.45 -  val smt_tac: Proof.context -> thm list -> int -> tactic
   28.46 -  val smt_tac': Proof.context -> thm list -> int -> tactic
   28.47 -end
   28.48 -
   28.49 -structure SMT_Solver: SMT_SOLVER =
   28.50 -struct
   28.51 -
   28.52 -
   28.53 -(* interface to external solvers *)
   28.54 -
   28.55 -local
   28.56 -
   28.57 -fun make_cmd command options problem_path proof_path = space_implode " " (
   28.58 -  "(exec 2>&1;" :: map File.shell_quote (command () @ options) @
   28.59 -  [File.shell_path problem_path, ")", ">", File.shell_path proof_path])
   28.60 -
   28.61 -fun trace_and ctxt msg f x =
   28.62 -  let val _ = SMT_Config.trace_msg ctxt (fn () => msg) ()
   28.63 -  in f x end
   28.64 -
   28.65 -fun run ctxt name mk_cmd input =
   28.66 -  (case SMT_Config.certificates_of ctxt of
   28.67 -    NONE =>
   28.68 -      if not (SMT_Config.is_available ctxt name) then
   28.69 -        error ("The SMT solver " ^ quote name ^ " is not installed.")
   28.70 -      else if Config.get ctxt SMT_Config.debug_files = "" then
   28.71 -        trace_and ctxt ("Invoking SMT solver " ^ quote name ^ " ...")
   28.72 -          (Cache_IO.run mk_cmd) input
   28.73 -      else
   28.74 -        let
   28.75 -          val base_path = Path.explode (Config.get ctxt SMT_Config.debug_files)
   28.76 -          val in_path = Path.ext "smt_in" base_path
   28.77 -          val out_path = Path.ext "smt_out" base_path
   28.78 -        in Cache_IO.raw_run mk_cmd input in_path out_path end
   28.79 -  | SOME certs =>
   28.80 -      (case Cache_IO.lookup certs input of
   28.81 -        (NONE, key) =>
   28.82 -          if Config.get ctxt SMT_Config.read_only_certificates then
   28.83 -            error ("Bad certificate cache: missing certificate")
   28.84 -          else
   28.85 -            Cache_IO.run_and_cache certs key mk_cmd input
   28.86 -      | (SOME output, _) =>
   28.87 -          trace_and ctxt ("Using cached certificate from " ^
   28.88 -            File.shell_path (Cache_IO.cache_path_of certs) ^ " ...")
   28.89 -            I output))
   28.90 -
   28.91 -fun run_solver ctxt name mk_cmd input =
   28.92 -  let
   28.93 -    fun pretty tag ls = Pretty.string_of (Pretty.big_list tag
   28.94 -      (map Pretty.str ls))
   28.95 -
   28.96 -    val _ = SMT_Config.trace_msg ctxt (pretty "Problem:" o split_lines) input
   28.97 -
   28.98 -    val {redirected_output=res, output=err, return_code} =
   28.99 -      SMT_Config.with_timeout ctxt (run ctxt name mk_cmd) input
  28.100 -    val _ = SMT_Config.trace_msg ctxt (pretty "Solver:") err
  28.101 -
  28.102 -    val ls = fst (take_suffix (equal "") res)
  28.103 -    val _ = SMT_Config.trace_msg ctxt (pretty "Result:") ls
  28.104 -
  28.105 -    val _ = return_code <> 0 andalso
  28.106 -      raise SMT_Failure.SMT (SMT_Failure.Abnormal_Termination return_code)
  28.107 -  in ls end
  28.108 -
  28.109 -fun trace_assms ctxt =
  28.110 -  SMT_Config.trace_msg ctxt (Pretty.string_of o
  28.111 -    Pretty.big_list "Assertions:" o map (Display.pretty_thm ctxt o snd))
  28.112 -
  28.113 -fun trace_recon_data ({context=ctxt, typs, terms, ...} : SMT_Translate.recon) =
  28.114 -  let
  28.115 -    fun pretty_eq n p = Pretty.block [Pretty.str n, Pretty.str " = ", p]
  28.116 -    fun p_typ (n, T) = pretty_eq n (Syntax.pretty_typ ctxt T)
  28.117 -    fun p_term (n, t) = pretty_eq n (Syntax.pretty_term ctxt t)
  28.118 -  in
  28.119 -    SMT_Config.trace_msg ctxt (fn () =>
  28.120 -      Pretty.string_of (Pretty.big_list "Names:" [
  28.121 -        Pretty.big_list "sorts:" (map p_typ (Symtab.dest typs)),
  28.122 -        Pretty.big_list "functions:" (map p_term (Symtab.dest terms))])) ()
  28.123 -  end
  28.124 -
  28.125 -in
  28.126 -
  28.127 -fun invoke name command ithms ctxt =
  28.128 -  let
  28.129 -    val options = SMT_Config.solver_options_of ctxt
  28.130 -    val comments = ("solver: " ^ name) ::
  28.131 -      ("timeout: " ^ string_of_real (Config.get ctxt SMT_Config.timeout)) ::
  28.132 -      ("random seed: " ^
  28.133 -        string_of_int (Config.get ctxt SMT_Config.random_seed)) ::
  28.134 -      "arguments:" :: options
  28.135 -
  28.136 -    val (str, recon as {context=ctxt', ...}) =
  28.137 -      ithms
  28.138 -      |> tap (trace_assms ctxt)
  28.139 -      |> SMT_Translate.translate ctxt comments
  28.140 -      ||> tap trace_recon_data
  28.141 -  in (run_solver ctxt' name (make_cmd command options) str, recon) end
  28.142 -
  28.143 -end
  28.144 -
  28.145 -
  28.146 -(* configuration *)
  28.147 -
  28.148 -datatype outcome = Unsat | Sat | Unknown
  28.149 -
  28.150 -type solver_config = {
  28.151 -  name: string,
  28.152 -  class: Proof.context -> SMT_Utils.class,
  28.153 -  avail: unit -> bool,
  28.154 -  command: unit -> string list,
  28.155 -  options: Proof.context -> string list,
  28.156 -  default_max_relevant: int,
  28.157 -  supports_filter: bool,
  28.158 -  outcome: string -> string list -> outcome * string list,
  28.159 -  cex_parser: (Proof.context -> SMT_Translate.recon -> string list ->
  28.160 -    term list * term list) option,
  28.161 -  reconstruct: (Proof.context -> SMT_Translate.recon -> string list ->
  28.162 -    int list * thm) option }
  28.163 -
  28.164 -
  28.165 -(* registry *)
  28.166 -
  28.167 -type solver_info = {
  28.168 -  command: unit -> string list,
  28.169 -  default_max_relevant: int,
  28.170 -  supports_filter: bool,
  28.171 -  reconstruct: Proof.context -> string list * SMT_Translate.recon ->
  28.172 -    int list * thm }
  28.173 -
  28.174 -structure Solvers = Generic_Data
  28.175 -(
  28.176 -  type T = solver_info Symtab.table
  28.177 -  val empty = Symtab.empty
  28.178 -  val extend = I
  28.179 -  fun merge data = Symtab.merge (K true) data