9 setmksimps setmkcong setmksym setmkeqTrue settermless setsubgoaler |
9 setmksimps setmkcong setmksym setmkeqTrue settermless setsubgoaler |
10 setloop' setloop addloop addloop' delloop setSSolver addSSolver setSolver addSolver; |
10 setloop' setloop addloop addloop' delloop setSSolver addSSolver setSolver addSolver; |
11 |
11 |
12 signature BASIC_META_SIMPLIFIER = |
12 signature BASIC_META_SIMPLIFIER = |
13 sig |
13 sig |
14 val debug_simp: bool Unsynchronized.ref |
14 val debug_simp: bool Config.T |
15 val trace_simp: bool Unsynchronized.ref |
15 val debug_simp_value: Config.value Config.T |
|
16 val trace_simp: bool Config.T |
|
17 val trace_simp_value: Config.value Config.T |
16 val trace_simp_depth_limit: int Unsynchronized.ref |
18 val trace_simp_depth_limit: int Unsynchronized.ref |
17 type rrule |
19 type rrule |
18 val eq_rrule: rrule * rrule -> bool |
20 val eq_rrule: rrule * rrule -> bool |
19 type simpset |
21 type simpset |
20 type proc |
22 type proc |
283 val names = Term.declare_term_names t Name.context; |
288 val names = Term.declare_term_names t Name.context; |
284 val xs = rev (#1 (Name.variants (rev (map #2 bs)) names)); |
289 val xs = rev (#1 (Name.variants (rev (map #2 bs)) names)); |
285 fun subst (((b, T), _), x') = (Free (b, T), Syntax.mark_boundT (x', T)); |
290 fun subst (((b, T), _), x') = (Free (b, T), Syntax.mark_boundT (x', T)); |
286 in Term.subst_atomic (ListPair.map subst (bs, xs)) t end; |
291 in Term.subst_atomic (ListPair.map subst (bs, xs)) t end; |
287 |
292 |
|
293 fun print_term ss warn a t ctxt = prnt ss warn (a () ^ "\n" ^ |
|
294 Syntax.string_of_term ctxt |
|
295 (if Config.get ctxt debug_simp then t else show_bounds ss t)); |
|
296 |
288 in |
297 in |
289 |
298 |
290 fun print_term ss warn a thy t = prnt ss warn (a ^ "\n" ^ |
299 fun print_term_global ss warn a thy t = |
291 Syntax.string_of_term_global thy (if ! debug_simp then t else show_bounds ss t)); |
300 print_term ss warn (K a) t (ProofContext.init thy); |
292 |
301 |
293 fun debug warn a ss = if ! debug_simp then prnt ss warn (a ()) else (); |
302 fun if_enabled (Simpset ({context, ...}, _)) flag f = |
294 fun trace warn a ss = if ! trace_simp then prnt ss warn (a ()) else (); |
303 (case context of |
295 |
304 SOME ctxt => if Config.get ctxt flag then f ctxt else () |
296 fun debug_term warn a ss thy t = if ! debug_simp then print_term ss warn (a ()) thy t else (); |
305 | NONE => ()) |
297 fun trace_term warn a ss thy t = if ! trace_simp then print_term ss warn (a ()) thy t else (); |
306 |
|
307 fun debug warn a ss = if_enabled ss debug_simp (fn _ => prnt ss warn (a ())); |
|
308 fun trace warn a ss = if_enabled ss trace_simp (fn _ => prnt ss warn (a ())); |
|
309 |
|
310 fun debug_term warn a ss t = if_enabled ss debug_simp (print_term ss warn a t); |
|
311 fun trace_term warn a ss t = if_enabled ss trace_simp (print_term ss warn a t); |
298 |
312 |
299 fun trace_cterm warn a ss ct = |
313 fun trace_cterm warn a ss ct = |
300 if ! trace_simp then print_term ss warn (a ()) (Thm.theory_of_cterm ct) (Thm.term_of ct) |
314 if_enabled ss trace_simp (print_term ss warn a (Thm.term_of ct)); |
301 else (); |
|
302 |
315 |
303 fun trace_thm a ss th = |
316 fun trace_thm a ss th = |
304 if ! trace_simp then print_term ss false (a ()) (Thm.theory_of_thm th) (Thm.full_prop_of th) |
317 if_enabled ss trace_simp (print_term ss false a (Thm.full_prop_of th)); |
305 else (); |
|
306 |
318 |
307 fun trace_named_thm a ss (th, name) = |
319 fun trace_named_thm a ss (th, name) = |
308 if ! trace_simp then |
320 if_enabled ss trace_simp (print_term ss false |
309 print_term ss false (if name = "" then a () else a () ^ " " ^ quote name ^ ":") |
321 (fn () => if name = "" then a () else a () ^ " " ^ quote name ^ ":") |
310 (Thm.theory_of_thm th) (Thm.full_prop_of th) |
322 (Thm.full_prop_of th)); |
311 else (); |
|
312 |
323 |
313 fun warn_thm a ss th = |
324 fun warn_thm a ss th = |
314 print_term ss true a (Thm.theory_of_thm th) (Thm.full_prop_of th); |
325 print_term_global ss true a (Thm.theory_of_thm th) (Thm.full_prop_of th); |
315 |
326 |
316 fun cond_warn_thm a (ss as Simpset ({context, ...}, _)) th = |
327 fun cond_warn_thm a (ss as Simpset ({context, ...}, _)) th = |
317 if is_some context then () else warn_thm a ss th; |
328 if is_some context then () else warn_thm a ss th; |
318 |
329 |
319 end; |
330 end; |
941 in sort rrs ([],[]) end |
952 in sort rrs ([],[]) end |
942 |
953 |
943 fun proc_rews [] = NONE |
954 fun proc_rews [] = NONE |
944 | proc_rews (Proc {name, proc, lhs, ...} :: ps) = |
955 | proc_rews (Proc {name, proc, lhs, ...} :: ps) = |
945 if Pattern.matches thyt (Thm.term_of lhs, Thm.term_of t) then |
956 if Pattern.matches thyt (Thm.term_of lhs, Thm.term_of t) then |
946 (debug_term false (fn () => "Trying procedure " ^ quote name ^ " on:") ss thyt eta_t; |
957 (debug_term false (fn () => "Trying procedure " ^ quote name ^ " on:") ss eta_t; |
947 case proc ss eta_t' of |
958 case proc ss eta_t' of |
948 NONE => (debug false (fn () => "FAILED") ss; proc_rews ps) |
959 NONE => (debug false (fn () => "FAILED") ss; proc_rews ps) |
949 | SOME raw_thm => |
960 | SOME raw_thm => |
950 (trace_thm (fn () => "Procedure " ^ quote name ^ " produced rewrite rule:") |
961 (trace_thm (fn () => "Procedure " ^ quote name ^ " produced rewrite rule:") |
951 ss raw_thm; |
962 ss raw_thm; |