identified "evil" theories for MaSh -- this is rather ad hoc, but so is MaSh anyway
1 (* Title: HOL/Tools/Sledgehammer/sledgehammer_fact.ML
2 Author: Jia Meng, Cambridge University Computer Laboratory and NICTA
3 Author: Jasmin Blanchette, TU Muenchen
5 Sledgehammer fact handling.
8 signature SLEDGEHAMMER_FACT =
10 type status = ATP_Problem_Generate.status
11 type stature = ATP_Problem_Generate.stature
13 type fact = ((unit -> string) * stature) * thm
16 {add : (Facts.ref * Attrib.src list) list,
17 del : (Facts.ref * Attrib.src list) list,
20 val ignore_no_atp : bool Config.T
21 val instantiate_inducts : bool Config.T
22 val no_fact_override : fact_override
24 Proof.context -> unit Symtab.table -> thm list -> status Termtab.table
25 -> Facts.ref * Attrib.src list -> ((string * stature) * thm) list
26 val backquote_thm : thm -> string
27 val clasimpset_rule_table_of : Proof.context -> status Termtab.table
28 val maybe_instantiate_inducts :
29 Proof.context -> term list -> term -> (((unit -> string) * 'a) * thm) list
30 -> (((unit -> string) * 'a) * thm) list
31 val maybe_filter_no_atps : Proof.context -> ('a * thm) list -> ('a * thm) list
32 val all_facts_of : Proof.context -> status Termtab.table -> fact list
33 val nearly_all_facts :
34 Proof.context -> bool -> fact_override -> unit Symtab.table
35 -> status Termtab.table -> thm list -> term list -> term -> fact list
38 structure Sledgehammer_Fact : SLEDGEHAMMER_FACT =
41 open ATP_Problem_Generate
43 open Sledgehammer_Util
45 type fact = ((unit -> string) * stature) * thm
48 {add : (Facts.ref * Attrib.src list) list,
49 del : (Facts.ref * Attrib.src list) list,
52 (* experimental features *)
54 Attrib.setup_config_bool @{binding sledgehammer_ignore_no_atp} (K false)
55 val instantiate_inducts =
56 Attrib.setup_config_bool @{binding sledgehammer_instantiate_inducts} (K false)
58 val no_fact_override = {add = [], del = [], only = false}
60 fun needs_quoting reserved s =
61 Symtab.defined reserved s orelse
62 exists (not o Lexicon.is_identifier) (Long_Name.explode s)
64 fun make_name reserved multi j name =
65 (name |> needs_quoting reserved name ? quote) ^
66 (if multi then "(" ^ string_of_int j ^ ")" else "")
68 fun explode_interval _ (Facts.FromTo (i, j)) = i upto j
69 | explode_interval max (Facts.From i) = i upto i + max - 1
70 | explode_interval _ (Facts.Single i) = [i]
73 raw_explode #> map (fn "`" => "\\`" | s => s) #> implode #> enclose "`" "`"
75 (* unfolding these can yield really huge terms *)
76 val risky_defs = @{thms Bit0_def Bit1_def}
78 fun is_rec_eq lhs = Term.exists_subterm (curry (op =) (head_of lhs))
79 fun is_rec_def (@{const Trueprop} $ t) = is_rec_def t
80 | is_rec_def (@{const ==>} $ _ $ t2) = is_rec_def t2
81 | is_rec_def (Const (@{const_name "=="}, _) $ t1 $ t2) = is_rec_eq t1 t2
82 | is_rec_def (Const (@{const_name HOL.eq}, _) $ t1 $ t2) = is_rec_eq t1 t2
83 | is_rec_def _ = false
85 fun is_assum assms th = exists (fn ct => prop_of th aconv term_of ct) assms
86 fun is_chained chained = member Thm.eq_thm_prop chained
88 fun scope_of_thm global assms chained th =
89 if is_chained chained th then Chained
90 else if global then Global
91 else if is_assum assms th then Assum
94 val may_be_induction =
95 exists_subterm (fn Var (_, Type (@{type_name fun}, [_, T])) =>
96 body_type T = @{typ bool}
99 fun status_of_thm css name th =
100 (* FIXME: use structured name *)
101 if (String.isSubstring ".induct" name orelse
102 String.isSubstring ".inducts" name) andalso
103 may_be_induction (prop_of th) then
105 else case Termtab.lookup css (prop_of th) of
106 SOME status => status
109 fun stature_of_thm global assms chained css name th =
110 (scope_of_thm global assms chained th, status_of_thm css name th)
112 fun fact_from_ref ctxt reserved chained css (xthm as (xref, args)) =
114 val ths = Attrib.eval_thms ctxt [xthm]
116 map (enclose "[" "]" o Pretty.str_of o Args.pretty_src ctxt) args
120 Facts.Fact s => backquote s ^ bracket
121 | Facts.Named (("", _), _) => "[" ^ bracket ^ "]"
122 | Facts.Named ((name, _), NONE) =>
123 make_name reserved (length ths > 1) (j + 1) name ^ bracket
124 | Facts.Named ((name, _), SOME intervals) =>
125 make_name reserved true
126 (nth (maps (explode_interval (length ths)) intervals) j) name ^
128 fun add_nth th (j, rest) =
129 let val name = nth_name j in
130 (j + 1, ((name, stature_of_thm false [] chained css name th), th)
133 in (0, []) |> fold add_nth ths |> snd end
135 (* Reject theorems with names like "List.filter.filter_list_def" or
136 "Accessible_Part.acc.defs", as these are definitions arising from packages. *)
137 fun is_package_def a =
138 let val names = Long_Name.explode a in
139 (length names > 2 andalso not (hd names = "local") andalso
140 String.isSuffix "_def" a) orelse String.isSuffix "_defs" a
143 (* FIXME: put other record thms here, or declare as "no_atp" *)
144 fun multi_base_blacklist ctxt ho_atp =
145 ["defs", "select_defs", "update_defs", "split", "splits", "split_asm",
146 "cases", "ext_cases", "eq.simps", "eq.refl", "nchotomy", "case_cong",
147 "weak_case_cong", "nibble_pair_of_char_simps", "nibble.simps",
149 |> not (ho_atp orelse (Config.get ctxt instantiate_inducts)) ?
150 append ["induct", "inducts"]
151 |> map (prefix Long_Name.separator)
153 val max_lambda_nesting = 3 (*only applies if not ho_atp*)
155 fun term_has_too_many_lambdas max (t1 $ t2) =
156 exists (term_has_too_many_lambdas max) [t1, t2]
157 | term_has_too_many_lambdas max (Abs (_, _, t)) =
158 max = 0 orelse term_has_too_many_lambdas (max - 1) t
159 | term_has_too_many_lambdas _ _ = false
161 (* Don't count nested lambdas at the level of formulas, since they are
163 fun formula_has_too_many_lambdas Ts (Abs (_, T, t)) =
164 formula_has_too_many_lambdas (T :: Ts) t
165 | formula_has_too_many_lambdas Ts t =
166 if member (op =) [HOLogic.boolT, propT] (fastype_of1 (Ts, t)) then
167 exists (formula_has_too_many_lambdas Ts) (#2 (strip_comb t))
169 term_has_too_many_lambdas max_lambda_nesting t
171 (* The max apply depth of any "metis" call in "Metis_Examples" (on 2007-10-31)
173 val max_apply_depth = 15
175 fun apply_depth (f $ t) = Int.max (apply_depth f, apply_depth t + 1)
176 | apply_depth (Abs (_, _, t)) = apply_depth t
179 fun is_formula_too_complex ho_atp t =
180 apply_depth t > max_apply_depth orelse
181 (not ho_atp andalso formula_has_too_many_lambdas [] t)
183 (* These theories contain auxiliary facts that could positively confuse
184 Sledgehammer if they were included. *)
185 val sledgehammer_prefixes =
186 ["ATP", "Meson", "Metis", "Sledgehammer"] |> map (suffix Long_Name.separator)
188 val exists_sledgehammer_const =
189 exists_Const (fn (s, _) =>
190 exists (fn pref => String.isPrefix pref s) sledgehammer_prefixes)
192 (* FIXME: make more reliable *)
193 val exists_low_level_class_const =
194 exists_Const (fn (s, _) =>
195 s = @{const_name equal_class.equal} orelse
196 String.isSubstring (Long_Name.separator ^ "class" ^ Long_Name.separator) s)
198 fun is_that_fact th =
199 String.isSuffix (Long_Name.separator ^ Obtain.thatN) (Thm.get_name_hint th)
200 andalso exists_subterm (fn Free (s, _) => s = Name.skolem Auto_Bind.thesisN
201 | _ => false) (prop_of th)
203 fun is_likely_tautology_or_too_meta th =
205 val is_boring_const = member (op =) atp_widely_irrelevant_consts
206 fun is_boring_bool t =
207 not (exists_Const (not o is_boring_const o fst) t) orelse
208 exists_type (exists_subtype (curry (op =) @{typ prop})) t
209 fun is_boring_prop (@{const Trueprop} $ t) = is_boring_bool t
210 | is_boring_prop (@{const "==>"} $ t $ u) =
211 is_boring_prop t andalso is_boring_prop u
212 | is_boring_prop (Const (@{const_name all}, _) $ (Abs (_, _, t)) $ u) =
213 is_boring_prop t andalso is_boring_prop u
214 | is_boring_prop (Const (@{const_name "=="}, _) $ t $ u) =
215 is_boring_bool t andalso is_boring_bool u
216 | is_boring_prop _ = true
218 is_boring_prop (prop_of th) andalso not (Thm.eq_thm_prop (@{thm ext}, th))
221 fun is_theorem_bad_for_atps ho_atp th =
222 is_likely_tautology_or_too_meta th orelse
223 let val t = prop_of th in
224 is_formula_too_complex ho_atp t orelse
225 exists_type type_has_top_sort t orelse
226 exists_sledgehammer_const t orelse exists_low_level_class_const t orelse
230 fun hackish_string_for_term thy t =
231 Print_Mode.setmp (filter (curry (op =) Symbol.xsymbolsN)
232 (print_mode_value ())) (Syntax.string_of_term_global thy) t
233 |> String.translate (fn c => if Char.isPrint c then str c else "")
236 (* This is a terrible hack. Free variables are sometimes coded as "M__" when
237 they are displayed as "M" and we want to avoid clashes with these. But
238 sometimes it's even worse: "Ma__" encodes "M". So we simply reserve all
239 prefixes of all free variables. In the worse case scenario, where the fact
240 won't be resolved correctly, the user can fix it manually, e.g., by naming
241 the fact in question. Ideally we would need nothing of it, but backticks
242 simply don't work with schematic variables. *)
243 fun all_prefixes_of s =
244 map (fn i => String.extract (s, 0, SOME i)) (1 upto size s - 1)
247 (t, [] |> Term.add_free_names t |> maps all_prefixes_of)
248 |> fold (fn ((s, i), T) => fn (t', taken) =>
249 let val s' = singleton (Name.variant_list taken) s in
250 ((if fastype_of t' = HOLogic.boolT then HOLogic.all_const
251 else Logic.all_const) T
252 $ Abs (s', T, abstract_over (Var ((s, i), T), t')),
255 (Term.add_vars t [] |> sort_wrt (fst o fst))
258 fun backquote_term thy t =
260 |> hackish_string_for_term thy
263 fun backquote_thm th = backquote_term (theory_of_thm th) (prop_of th)
265 fun clasimpset_rule_table_of ctxt =
267 val thy = Proof_Context.theory_of ctxt
268 val atomize = HOLogic.mk_Trueprop o Object_Logic.atomize_term thy
269 fun add stature normalizers get_th =
272 val th = rule |> get_th
274 th |> Thm.maxidx_of th > 0 ? zero_var_indexes |> prop_of
276 fold (fn normalize => Termtab.update (normalize t, stature))
279 val {safeIs, (* safeEs, *) hazIs, (* hazEs, *) ...} =
280 ctxt |> claset_of |> Classical.rep_cs
281 val intros = Item_Net.content safeIs @ Item_Net.content hazIs
282 (* Add once it is used:
284 Item_Net.content safeEs @ Item_Net.content hazEs
285 |> map Classical.classical_rule
287 val simps = ctxt |> simpset_of |> dest_ss |> #simps
288 val specs = ctxt |> Spec_Rules.get
289 val (rec_defs, nonrec_defs) =
290 specs |> filter (curry (op =) Spec_Rules.Equational o fst)
292 |> filter_out (member Thm.eq_thm_prop risky_defs)
293 |> List.partition (is_rec_def o prop_of)
295 specs |> filter (member (op =) [Spec_Rules.Inductive,
296 Spec_Rules.Co_Inductive] o fst)
299 Termtab.empty |> add Simp [atomize] snd simps
300 |> add Rec_Def [] I rec_defs
301 |> add Non_Rec_Def [] I nonrec_defs
302 (* Add once it is used:
303 |> add Elim [] I elims
305 |> add Intro [] I intros
306 |> add Inductive [] I spec_intros
310 Termtab.fold (cons o snd)
311 (fold (Termtab.update o `(prop_of o snd)) xs Termtab.empty) []
313 fun struct_induct_rule_on th =
314 case Logic.strip_horn (prop_of th) of
315 (prems, @{const Trueprop}
316 $ ((p as Var ((p_name, 0), _)) $ (a as Var (_, ind_T)))) =>
317 if not (is_TVar ind_T) andalso length prems > 1 andalso
318 exists (exists_subterm (curry (op aconv) p)) prems andalso
319 not (exists (exists_subterm (curry (op aconv) a)) prems) then
325 fun instantiate_induct_rule ctxt concl_prop p_name ((name, stature), th) ind_x =
327 val thy = Proof_Context.theory_of ctxt
328 fun varify_noninducts (t as Free (s, T)) =
329 if (s, T) = ind_x orelse can dest_funT T then t else Var ((s, 0), T)
330 | varify_noninducts t = t
332 concl_prop |> map_aterms varify_noninducts |> close_form
333 |> lambda (Free ind_x)
334 |> hackish_string_for_term thy
336 ((fn () => name () ^ "[where " ^ p_name ^ " = " ^ quote p_inst ^ "]",
337 stature), th |> read_instantiate ctxt [((p_name, 0), p_inst)])
340 fun type_match thy (T1, T2) =
341 (Sign.typ_match thy (T2, T1) Vartab.empty; true)
342 handle Type.TYPE_MATCH => false
344 fun instantiate_if_induct_rule ctxt stmt stmt_xs (ax as (_, th)) =
345 case struct_induct_rule_on th of
346 SOME (p_name, ind_T) =>
347 let val thy = Proof_Context.theory_of ctxt in
348 stmt_xs |> filter (fn (_, T) => type_match thy (T, ind_T))
349 |> map_filter (try (instantiate_induct_rule ctxt stmt p_name ax))
353 fun external_frees t =
354 [] |> Term.add_frees t |> filter_out (can Name.dest_internal o fst)
356 fun maybe_instantiate_inducts ctxt hyp_ts concl_t =
357 if Config.get ctxt instantiate_inducts then
359 val thy = Proof_Context.theory_of ctxt
361 (hyp_ts |> filter_out (null o external_frees), concl_t)
362 |> Logic.list_implies |> Object_Logic.atomize_term thy
363 val ind_stmt_xs = external_frees ind_stmt
364 in maps (instantiate_if_induct_rule ctxt ind_stmt ind_stmt_xs) end
368 fun maybe_filter_no_atps ctxt =
369 not (Config.get ctxt ignore_no_atp) ? filter_out (No_ATPs.member ctxt o snd)
371 fun all_facts ctxt ho_atp reserved add_ths chained css =
373 val thy = Proof_Context.theory_of ctxt
374 val global_facts = Global_Theory.facts_of thy
375 val local_facts = Proof_Context.facts_of ctxt
376 val named_locals = local_facts |> Facts.dest_static []
377 val assms = Assumption.all_assms_of ctxt
378 fun is_good_unnamed_local th =
379 not (Thm.has_name_hint th) andalso
380 forall (fn (_, ths) => not (member Thm.eq_thm_prop ths th)) named_locals
382 union Thm.eq_thm_prop (Facts.props local_facts) chained
383 |> filter is_good_unnamed_local |> map (pair "" o single)
385 Name_Space.merge (Facts.space_of global_facts, Facts.space_of local_facts)
386 fun add_facts global foldx facts =
387 foldx (fn (name0, ths) =>
388 if name0 <> "" andalso
389 forall (not o member Thm.eq_thm_prop add_ths) ths andalso
390 (Facts.is_concealed facts name0 orelse
391 not (can (Proof_Context.get_thms ctxt) name0) orelse
392 (not (Config.get ctxt ignore_no_atp) andalso
393 is_package_def name0) orelse
394 exists (fn s => String.isSuffix s name0)
395 (multi_base_blacklist ctxt ho_atp)) then
399 val multi = length ths > 1
401 case try (Proof_Context.get_thms ctxt) a of
403 | SOME ths' => eq_list Thm.eq_thm_prop (ths, ths')
406 #> fold (fn th => fn (j, (multis, unis)) =>
408 if not (member Thm.eq_thm_prop add_ths th) andalso
409 is_theorem_bad_for_atps ho_atp th then
418 [Facts.extern ctxt facts name0,
419 Name_Space.extern ctxt full_space name0]
420 |> find_first check_thms
422 |> make_name reserved multi j),
423 stature_of_thm global assms chained css name0
426 if multi then (new :: multis, unis)
427 else (multis, new :: unis)
432 (* The single-name theorems go after the multiple-name ones, so that single
433 names are preferred when both are available. *)
434 ([], []) |> add_facts false fold local_facts (unnamed_locals @ named_locals)
435 |> add_facts true Facts.fold_static global_facts global_facts
439 fun all_facts_of ctxt css =
440 all_facts ctxt false Symtab.empty [] [] css
441 |> rev (* partly restore the original order of facts, for MaSh *)
443 fun nearly_all_facts ctxt ho_atp {add, del, only} reserved css chained hyp_ts
445 if only andalso null add then
451 |> maps (fn th => insert Thm.eq_thm_prop (zero_var_indexes th) [th])
454 maps (map (fn ((name, stature), th) => ((K name, stature), th))
455 o fact_from_ref ctxt reserved chained css) add
457 let val (add, del) = pairself (Attrib.eval_thms ctxt) (add, del) in
458 all_facts ctxt ho_atp reserved add chained css
459 |> filter_out (member Thm.eq_thm_prop del o snd)
460 |> maybe_filter_no_atps ctxt
463 |> maybe_instantiate_inducts ctxt hyp_ts concl_t