7 *) |
7 *) |
8 |
8 |
9 signature BASIC_SIMPLIFIER = |
9 signature BASIC_SIMPLIFIER = |
10 sig |
10 sig |
11 include BASIC_META_SIMPLIFIER |
11 include BASIC_META_SIMPLIFIER |
12 val print_simpset: theory -> unit |
|
13 val change_simpset_of: theory -> (simpset -> simpset) -> unit |
|
14 val change_simpset: (simpset -> simpset) -> unit |
12 val change_simpset: (simpset -> simpset) -> unit |
15 val simpset_of: theory -> simpset |
13 val simpset_of: theory -> simpset |
16 val simpset: unit -> simpset |
14 val simpset: unit -> simpset |
17 val SIMPSET: (simpset -> tactic) -> tactic |
15 val SIMPSET: (simpset -> tactic) -> tactic |
18 val SIMPSET': (simpset -> 'a -> tactic) -> 'a -> tactic |
16 val SIMPSET': (simpset -> 'a -> tactic) -> 'a -> tactic |
58 val rewrite: simpset -> conv |
56 val rewrite: simpset -> conv |
59 val asm_rewrite: simpset -> conv |
57 val asm_rewrite: simpset -> conv |
60 val full_rewrite: simpset -> conv |
58 val full_rewrite: simpset -> conv |
61 val asm_lr_rewrite: simpset -> conv |
59 val asm_lr_rewrite: simpset -> conv |
62 val asm_full_rewrite: simpset -> conv |
60 val asm_full_rewrite: simpset -> conv |
63 val get_simpset: theory -> simpset |
|
64 val print_local_simpset: Proof.context -> unit |
|
65 val get_local_simpset: Proof.context -> simpset |
|
66 val put_local_simpset: simpset -> Proof.context -> Proof.context |
|
67 val get_ss: Context.generic -> simpset |
61 val get_ss: Context.generic -> simpset |
68 val map_ss: (simpset -> simpset) -> Context.generic -> Context.generic |
62 val map_ss: (simpset -> simpset) -> Context.generic -> Context.generic |
69 val attrib: (simpset * thm list -> simpset) -> attribute |
63 val attrib: (simpset * thm list -> simpset) -> attribute |
70 val simp_add: attribute |
64 val simp_add: attribute |
71 val simp_del: attribute |
65 val simp_del: attribute |
72 val cong_add: attribute |
66 val cong_add: attribute |
73 val cong_del: attribute |
67 val cong_del: attribute |
|
68 val map_simpset: (simpset -> simpset) -> theory -> theory |
74 val get_simproc: Context.generic -> xstring -> simproc |
69 val get_simproc: Context.generic -> xstring -> simproc |
75 val def_simproc: {name: string, lhss: string list, |
70 val def_simproc: {name: string, lhss: string list, |
76 proc: morphism -> simpset -> cterm -> thm option, identifier: thm list} -> |
71 proc: morphism -> simpset -> cterm -> thm option, identifier: thm list} -> |
77 local_theory -> local_theory |
72 local_theory -> local_theory |
78 val def_simproc_i: {name: string, lhss: term list, |
73 val def_simproc_i: {name: string, lhss: term list, |
92 open MetaSimplifier; |
87 open MetaSimplifier; |
93 |
88 |
94 |
89 |
95 (** simpset data **) |
90 (** simpset data **) |
96 |
91 |
97 (* global simpsets *) |
92 structure SimpsetData = GenericDataFun |
98 |
|
99 structure GlobalSimpset = TheoryDataFun |
|
100 ( |
93 ( |
101 type T = simpset ref; |
94 type T = simpset; |
102 val empty = ref empty_ss; |
95 val empty = empty_ss; |
103 fun copy (ref ss) = ref ss: T; |
96 fun extend ss = MetaSimplifier.inherit_context empty_ss ss; |
104 fun extend (ref ss) = ref (MetaSimplifier.inherit_context empty_ss ss); |
97 fun merge _ = merge_ss; |
105 fun merge _ (ref ss1, ref ss2) = ref (merge_ss (ss1, ss2)); |
|
106 ); |
98 ); |
107 |
99 |
108 val _ = Context.>> (Context.map_theory GlobalSimpset.init); |
100 val get_ss = SimpsetData.get; |
109 fun print_simpset thy = print_ss (! (GlobalSimpset.get thy)); |
101 val map_ss = SimpsetData.map; |
110 val get_simpset = ! o GlobalSimpset.get; |
102 |
111 |
103 |
112 fun change_simpset_of thy f = CRITICAL (fn () => change (GlobalSimpset.get thy) f); |
104 (* attributes *) |
113 fun change_simpset f = CRITICAL (fn () => change_simpset_of (ML_Context.the_global_context ()) f); |
105 |
114 |
106 fun attrib f = Thm.declaration_attribute (fn th => map_ss (fn ss => f (ss, [th]))); |
115 fun simpset_of thy = MetaSimplifier.context (ProofContext.init thy) (get_simpset thy); |
107 |
|
108 val simp_add = attrib (op addsimps); |
|
109 val simp_del = attrib (op delsimps); |
|
110 val cong_add = attrib (op addcongs); |
|
111 val cong_del = attrib (op delcongs); |
|
112 |
|
113 |
|
114 (* global simpset *) |
|
115 |
|
116 fun map_simpset f = Context.theory_map (map_ss f); |
|
117 fun change_simpset f = Context.>> (Context.map_theory (map_simpset f)); |
|
118 fun simpset_of thy = MetaSimplifier.context (ProofContext.init thy) (get_ss (Context.Theory thy)); |
116 val simpset = simpset_of o ML_Context.the_global_context; |
119 val simpset = simpset_of o ML_Context.the_global_context; |
117 |
|
118 |
120 |
119 fun SIMPSET tacf st = tacf (simpset_of (Thm.theory_of_thm st)) st; |
121 fun SIMPSET tacf st = tacf (simpset_of (Thm.theory_of_thm st)) st; |
120 fun SIMPSET' tacf i st = tacf (simpset_of (Thm.theory_of_thm st)) i st; |
122 fun SIMPSET' tacf i st = tacf (simpset_of (Thm.theory_of_thm st)) i st; |
121 |
123 |
122 fun Addsimps args = change_simpset (fn ss => ss addsimps args); |
124 fun Addsimps args = change_simpset (fn ss => ss addsimps args); |
125 fun Delsimprocs args = change_simpset (fn ss => ss delsimprocs args); |
127 fun Delsimprocs args = change_simpset (fn ss => ss delsimprocs args); |
126 fun Addcongs args = change_simpset (fn ss => ss addcongs args); |
128 fun Addcongs args = change_simpset (fn ss => ss addcongs args); |
127 fun Delcongs args = change_simpset (fn ss => ss delcongs args); |
129 fun Delcongs args = change_simpset (fn ss => ss delcongs args); |
128 |
130 |
129 |
131 |
130 (* local simpsets *) |
132 (* local simpset *) |
131 |
133 |
132 structure LocalSimpset = ProofDataFun |
134 fun local_simpset_of ctxt = MetaSimplifier.context ctxt (get_ss (Context.Proof ctxt)); |
133 ( |
|
134 type T = simpset; |
|
135 val init = get_simpset; |
|
136 ); |
|
137 |
|
138 val print_local_simpset = print_ss o LocalSimpset.get; |
|
139 val get_local_simpset = LocalSimpset.get; |
|
140 val put_local_simpset = LocalSimpset.put; |
|
141 |
|
142 fun local_simpset_of ctxt = MetaSimplifier.context ctxt (get_local_simpset ctxt); |
|
143 |
135 |
144 val _ = ML_Context.value_antiq "simpset" |
136 val _ = ML_Context.value_antiq "simpset" |
145 (Scan.succeed ("simpset", "Simplifier.local_simpset_of (ML_Context.the_local_context ())")); |
137 (Scan.succeed ("simpset", "Simplifier.local_simpset_of (ML_Context.the_local_context ())")); |
146 |
|
147 |
|
148 (* generic simpsets *) |
|
149 |
|
150 fun get_ss (Context.Theory thy) = simpset_of thy |
|
151 | get_ss (Context.Proof ctxt) = local_simpset_of ctxt; |
|
152 |
|
153 fun map_ss f (Context.Theory thy) = (change_simpset_of thy f; Context.Theory thy) |
|
154 | map_ss f (Context.Proof ctxt) = Context.Proof (LocalSimpset.map f ctxt); |
|
155 |
|
156 |
|
157 (* attributes *) |
|
158 |
|
159 fun attrib f = Thm.declaration_attribute (fn th => map_ss (fn ss => f (ss, [th]))); |
|
160 |
|
161 val simp_add = attrib (op addsimps); |
|
162 val simp_del = attrib (op delsimps); |
|
163 val cong_add = attrib (op addcongs); |
|
164 val cong_del = attrib (op delcongs); |
|
165 |
138 |
166 |
139 |
167 |
140 |
168 (** named simprocs **) |
141 (** named simprocs **) |
169 |
142 |
397 val simp_modifiers = |
370 val simp_modifiers = |
398 [Args.$$$ simpN -- Args.colon >> K (I, simp_add), |
371 [Args.$$$ simpN -- Args.colon >> K (I, simp_add), |
399 Args.$$$ simpN -- Args.add -- Args.colon >> K (I, simp_add), |
372 Args.$$$ simpN -- Args.add -- Args.colon >> K (I, simp_add), |
400 Args.$$$ simpN -- Args.del -- Args.colon >> K (I, simp_del), |
373 Args.$$$ simpN -- Args.del -- Args.colon >> K (I, simp_del), |
401 Args.$$$ simpN -- Args.$$$ onlyN -- Args.colon |
374 Args.$$$ simpN -- Args.$$$ onlyN -- Args.colon |
402 >> K (LocalSimpset.map MetaSimplifier.clear_ss, simp_add)] |
375 >> K (Context.proof_map (map_ss MetaSimplifier.clear_ss), simp_add)] |
403 @ cong_modifiers; |
376 @ cong_modifiers; |
404 |
377 |
405 val simp_modifiers' = |
378 val simp_modifiers' = |
406 [Args.add -- Args.colon >> K (I, simp_add), |
379 [Args.add -- Args.colon >> K (I, simp_add), |
407 Args.del -- Args.colon >> K (I, simp_del), |
380 Args.del -- Args.colon >> K (I, simp_del), |
408 Args.$$$ onlyN -- Args.colon |
381 Args.$$$ onlyN -- Args.colon |
409 >> K (LocalSimpset.map MetaSimplifier.clear_ss, simp_add)] |
382 >> K (Context.proof_map (map_ss MetaSimplifier.clear_ss), simp_add)] |
410 @ cong_modifiers; |
383 @ cong_modifiers; |
411 |
384 |
412 fun simp_args more_mods = |
385 fun simp_args more_mods = |
413 Method.sectioned_args (Args.bang_facts -- Scan.lift simp_options) |
386 Method.sectioned_args (Args.bang_facts -- Scan.lift simp_options) |
414 (more_mods @ simp_modifiers'); |
387 (more_mods @ simp_modifiers'); |
427 |
400 |
428 fun method_setup more_mods = Method.add_methods |
401 fun method_setup more_mods = Method.add_methods |
429 [(simpN, simp_args more_mods simp_method', "simplification"), |
402 [(simpN, simp_args more_mods simp_method', "simplification"), |
430 ("simp_all", simp_args more_mods simp_method, "simplification (all goals)")]; |
403 ("simp_all", simp_args more_mods simp_method, "simplification (all goals)")]; |
431 |
404 |
432 fun easy_setup reflect trivs = method_setup [] #> (fn thy => |
405 fun easy_setup reflect trivs = method_setup [] #> Context.theory_map (map_ss (fn _ => |
433 let |
406 let |
434 val trivialities = Drule.reflexive_thm :: trivs; |
407 val trivialities = Drule.reflexive_thm :: trivs; |
435 |
408 |
436 fun unsafe_solver_tac prems = FIRST' [resolve_tac (trivialities @ prems), assume_tac]; |
409 fun unsafe_solver_tac prems = FIRST' [resolve_tac (trivialities @ prems), assume_tac]; |
437 val unsafe_solver = mk_solver "easy unsafe" unsafe_solver_tac; |
410 val unsafe_solver = mk_solver "easy unsafe" unsafe_solver_tac; |
443 fun mk_eq thm = |
416 fun mk_eq thm = |
444 if can Logic.dest_equals (Thm.concl_of thm) then [thm] |
417 if can Logic.dest_equals (Thm.concl_of thm) then [thm] |
445 else [thm RS reflect] handle THM _ => []; |
418 else [thm RS reflect] handle THM _ => []; |
446 |
419 |
447 fun mksimps thm = mk_eq (Drule.forall_elim_vars (#maxidx (Thm.rep_thm thm) + 1) thm); |
420 fun mksimps thm = mk_eq (Drule.forall_elim_vars (#maxidx (Thm.rep_thm thm) + 1) thm); |
448 val _ = CRITICAL (fn () => |
421 in |
449 GlobalSimpset.get thy := |
422 empty_ss setsubgoaler asm_simp_tac |
450 empty_ss setsubgoaler asm_simp_tac |
423 setSSolver safe_solver |
451 setSSolver safe_solver |
424 setSolver unsafe_solver |
452 setSolver unsafe_solver |
425 setmksimps mksimps |
453 setmksimps mksimps); |
426 end)); |
454 in thy end); |
|
455 |
427 |
456 end; |
428 end; |
457 |
429 |
458 structure BasicSimplifier: BASIC_SIMPLIFIER = Simplifier; |
430 structure BasicSimplifier: BASIC_SIMPLIFIER = Simplifier; |
459 open BasicSimplifier; |
431 open BasicSimplifier; |