author | wenzelm |
Mon, 01 Jun 2015 17:44:45 +0200 | |
changeset 60335 | edac62cd7bde |
parent 60334 | 63f25a1adcfc |
child 60363 | 5568b16aa477 |
permissions | -rw-r--r-- |
23150 | 1 |
(* Title: HOL/Tools/TFL/rules.ML |
2 |
Author: Konrad Slind, Cambridge University Computer Laboratory |
|
3 |
||
29265
5b4247055bd7
moved old add_term_vars, add_term_frees etc. to structure OldTerm;
wenzelm
parents:
26928
diff
changeset
|
4 |
Emulation of HOL inference rules for TFL. |
23150 | 5 |
*) |
6 |
||
7 |
signature RULES = |
|
8 |
sig |
|
9 |
val dest_thm: thm -> term list * term |
|
10 |
||
11 |
(* Inference rules *) |
|
12 |
val REFL: cterm -> thm |
|
13 |
val ASSUME: cterm -> thm |
|
14 |
val MP: thm -> thm -> thm |
|
15 |
val MATCH_MP: thm -> thm -> thm |
|
16 |
val CONJUNCT1: thm -> thm |
|
17 |
val CONJUNCT2: thm -> thm |
|
18 |
val CONJUNCTS: thm -> thm list |
|
19 |
val DISCH: cterm -> thm -> thm |
|
20 |
val UNDISCH: thm -> thm |
|
21 |
val SPEC: cterm -> thm -> thm |
|
22 |
val ISPEC: cterm -> thm -> thm |
|
23 |
val ISPECL: cterm list -> thm -> thm |
|
24 |
val GEN: cterm -> thm -> thm |
|
25 |
val GENL: cterm list -> thm -> thm |
|
26 |
val LIST_CONJ: thm list -> thm |
|
27 |
||
28 |
val SYM: thm -> thm |
|
29 |
val DISCH_ALL: thm -> thm |
|
30 |
val FILTER_DISCH_ALL: (term -> bool) -> thm -> thm |
|
31 |
val SPEC_ALL: thm -> thm |
|
32 |
val GEN_ALL: thm -> thm |
|
33 |
val IMP_TRANS: thm -> thm -> thm |
|
34 |
val PROVE_HYP: thm -> thm -> thm |
|
35 |
||
60334 | 36 |
val CHOOSE: Proof.context -> cterm * thm -> thm -> thm |
23150 | 37 |
val EXISTS: cterm * cterm -> thm -> thm |
38 |
val EXISTL: cterm list -> thm -> thm |
|
39 |
val IT_EXISTS: (cterm*cterm) list -> thm -> thm |
|
40 |
||
41 |
val EVEN_ORS: thm list -> thm list |
|
42 |
val DISJ_CASESL: thm -> thm list -> thm |
|
43 |
||
44 |
val list_beta_conv: cterm -> cterm list -> thm |
|
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
45 |
val SUBS: Proof.context -> thm list -> thm -> thm |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
46 |
val simpl_conv: Proof.context -> thm list -> cterm -> thm |
23150 | 47 |
|
48 |
val rbeta: thm -> thm |
|
32740 | 49 |
val tracing: bool Unsynchronized.ref |
23150 | 50 |
val CONTEXT_REWRITE_RULE: term * term list * thm * thm list |
51 |
-> thm -> thm * term list |
|
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
52 |
val RIGHT_ASSOC: Proof.context -> thm -> thm |
23150 | 53 |
|
60335 | 54 |
val prove: Proof.context -> bool -> term * tactic -> thm |
23150 | 55 |
end; |
56 |
||
57 |
structure Rules: RULES = |
|
58 |
struct |
|
59 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
60 |
fun RULES_ERR func mesg = Utils.ERR {module = "Rules", func = func, mesg = mesg}; |
23150 | 61 |
|
62 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
63 |
fun cconcl thm = Dcterm.drop_prop (#prop (Thm.crep_thm thm)); |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
64 |
fun chyps thm = map Dcterm.drop_prop (#hyps (Thm.crep_thm thm)); |
23150 | 65 |
|
66 |
fun dest_thm thm = |
|
67 |
let val {prop,hyps,...} = Thm.rep_thm thm |
|
68 |
in (map HOLogic.dest_Trueprop hyps, HOLogic.dest_Trueprop prop) end |
|
69 |
handle TERM _ => raise RULES_ERR "dest_thm" "missing Trueprop"; |
|
70 |
||
71 |
||
72 |
(* Inference rules *) |
|
73 |
||
74 |
(*--------------------------------------------------------------------------- |
|
75 |
* Equality (one step) |
|
76 |
*---------------------------------------------------------------------------*) |
|
77 |
||
78 |
fun REFL tm = Thm.reflexive tm RS meta_eq_to_obj_eq |
|
79 |
handle THM (msg, _, _) => raise RULES_ERR "REFL" msg; |
|
80 |
||
81 |
fun SYM thm = thm RS sym |
|
82 |
handle THM (msg, _, _) => raise RULES_ERR "SYM" msg; |
|
83 |
||
84 |
fun ALPHA thm ctm1 = |
|
85 |
let |
|
86 |
val ctm2 = Thm.cprop_of thm; |
|
87 |
val ctm2_eq = Thm.reflexive ctm2; |
|
88 |
val ctm1_eq = Thm.reflexive ctm1; |
|
89 |
in Thm.equal_elim (Thm.transitive ctm2_eq ctm1_eq) thm end |
|
90 |
handle THM (msg, _, _) => raise RULES_ERR "ALPHA" msg; |
|
91 |
||
92 |
fun rbeta th = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
93 |
(case Dcterm.strip_comb (cconcl th) of |
23150 | 94 |
(_, [l, r]) => Thm.transitive th (Thm.beta_conversion false r) |
95 |
| _ => raise RULES_ERR "rbeta" ""); |
|
96 |
||
97 |
||
98 |
(*---------------------------------------------------------------------------- |
|
99 |
* Implication and the assumption list |
|
100 |
* |
|
101 |
* Assumptions get stuck on the meta-language assumption list. Implications |
|
102 |
* are in the object language, so discharging an assumption "A" from theorem |
|
103 |
* "B" results in something that looks like "A --> B". |
|
104 |
*---------------------------------------------------------------------------*) |
|
105 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
106 |
fun ASSUME ctm = Thm.assume (Dcterm.mk_prop ctm); |
23150 | 107 |
|
108 |
||
109 |
(*--------------------------------------------------------------------------- |
|
110 |
* Implication in TFL is -->. Meta-language implication (==>) is only used |
|
111 |
* in the implementation of some of the inference rules below. |
|
112 |
*---------------------------------------------------------------------------*) |
|
113 |
fun MP th1 th2 = th2 RS (th1 RS mp) |
|
114 |
handle THM (msg, _, _) => raise RULES_ERR "MP" msg; |
|
115 |
||
116 |
(*forces the first argument to be a proposition if necessary*) |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
117 |
fun DISCH tm thm = Thm.implies_intr (Dcterm.mk_prop tm) thm COMP impI |
23150 | 118 |
handle THM (msg, _, _) => raise RULES_ERR "DISCH" msg; |
119 |
||
120 |
fun DISCH_ALL thm = fold_rev DISCH (#hyps (Thm.crep_thm thm)) thm; |
|
121 |
||
122 |
||
123 |
fun FILTER_DISCH_ALL P thm = |
|
59586 | 124 |
let fun check tm = P (Thm.term_of tm) |
33339 | 125 |
in fold_rev (fn tm => fn th => if check tm then DISCH tm th else th) (chyps thm) thm |
23150 | 126 |
end; |
127 |
||
128 |
fun UNDISCH thm = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
129 |
let val tm = Dcterm.mk_prop (#1 (Dcterm.dest_imp (cconcl thm))) |
23150 | 130 |
in Thm.implies_elim (thm RS mp) (ASSUME tm) end |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
131 |
handle Utils.ERR _ => raise RULES_ERR "UNDISCH" "" |
23150 | 132 |
| THM _ => raise RULES_ERR "UNDISCH" ""; |
133 |
||
134 |
fun PROVE_HYP ath bth = MP (DISCH (cconcl ath) bth) ath; |
|
135 |
||
136 |
fun IMP_TRANS th1 th2 = th2 RS (th1 RS Thms.imp_trans) |
|
137 |
handle THM (msg, _, _) => raise RULES_ERR "IMP_TRANS" msg; |
|
138 |
||
139 |
||
140 |
(*---------------------------------------------------------------------------- |
|
141 |
* Conjunction |
|
142 |
*---------------------------------------------------------------------------*) |
|
143 |
||
144 |
fun CONJUNCT1 thm = thm RS conjunct1 |
|
145 |
handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT1" msg; |
|
146 |
||
147 |
fun CONJUNCT2 thm = thm RS conjunct2 |
|
148 |
handle THM (msg, _, _) => raise RULES_ERR "CONJUNCT2" msg; |
|
149 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
150 |
fun CONJUNCTS th = CONJUNCTS (CONJUNCT1 th) @ CONJUNCTS (CONJUNCT2 th) handle Utils.ERR _ => [th]; |
23150 | 151 |
|
152 |
fun LIST_CONJ [] = raise RULES_ERR "LIST_CONJ" "empty list" |
|
153 |
| LIST_CONJ [th] = th |
|
154 |
| LIST_CONJ (th :: rst) = MP (MP (conjI COMP (impI RS impI)) th) (LIST_CONJ rst) |
|
155 |
handle THM (msg, _, _) => raise RULES_ERR "LIST_CONJ" msg; |
|
156 |
||
157 |
||
158 |
(*---------------------------------------------------------------------------- |
|
159 |
* Disjunction |
|
160 |
*---------------------------------------------------------------------------*) |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
161 |
local val thy = Thm.theory_of_thm disjI1 |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
162 |
val prop = Thm.prop_of disjI1 |
44121 | 163 |
val [P,Q] = Misc_Legacy.term_vars prop |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
164 |
val disj1 = Thm.forall_intr (Thm.global_cterm_of thy Q) disjI1 |
23150 | 165 |
in |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
166 |
fun DISJ1 thm tm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj1) |
23150 | 167 |
handle THM (msg, _, _) => raise RULES_ERR "DISJ1" msg; |
168 |
end; |
|
169 |
||
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
170 |
local val thy = Thm.theory_of_thm disjI2 |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
171 |
val prop = Thm.prop_of disjI2 |
44121 | 172 |
val [P,Q] = Misc_Legacy.term_vars prop |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
173 |
val disj2 = Thm.forall_intr (Thm.global_cterm_of thy P) disjI2 |
23150 | 174 |
in |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
175 |
fun DISJ2 tm thm = thm RS (Thm.forall_elim (Dcterm.drop_prop tm) disj2) |
23150 | 176 |
handle THM (msg, _, _) => raise RULES_ERR "DISJ2" msg; |
177 |
end; |
|
178 |
||
179 |
||
180 |
(*---------------------------------------------------------------------------- |
|
181 |
* |
|
182 |
* A1 |- M1, ..., An |- Mn |
|
183 |
* --------------------------------------------------- |
|
184 |
* [A1 |- M1 \/ ... \/ Mn, ..., An |- M1 \/ ... \/ Mn] |
|
185 |
* |
|
186 |
*---------------------------------------------------------------------------*) |
|
187 |
||
188 |
||
189 |
fun EVEN_ORS thms = |
|
190 |
let fun blue ldisjs [] _ = [] |
|
191 |
| blue ldisjs (th::rst) rdisjs = |
|
192 |
let val tail = tl rdisjs |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
193 |
val rdisj_tl = Dcterm.list_mk_disj tail |
23150 | 194 |
in fold_rev DISJ2 ldisjs (DISJ1 th rdisj_tl) |
195 |
:: blue (ldisjs @ [cconcl th]) rst tail |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
196 |
end handle Utils.ERR _ => [fold_rev DISJ2 ldisjs th] |
23150 | 197 |
in blue [] thms (map cconcl thms) end; |
198 |
||
199 |
||
200 |
(*---------------------------------------------------------------------------- |
|
201 |
* |
|
202 |
* A |- P \/ Q B,P |- R C,Q |- R |
|
203 |
* --------------------------------------------------- |
|
204 |
* A U B U C |- R |
|
205 |
* |
|
206 |
*---------------------------------------------------------------------------*) |
|
207 |
||
208 |
fun DISJ_CASES th1 th2 th3 = |
|
209 |
let |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
210 |
val c = Dcterm.drop_prop (cconcl th1); |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
211 |
val (disj1, disj2) = Dcterm.dest_disj c; |
23150 | 212 |
val th2' = DISCH disj1 th2; |
213 |
val th3' = DISCH disj2 th3; |
|
214 |
in |
|
215 |
th3' RS (th2' RS (th1 RS Thms.tfl_disjE)) |
|
216 |
handle THM (msg, _, _) => raise RULES_ERR "DISJ_CASES" msg |
|
217 |
end; |
|
218 |
||
219 |
||
220 |
(*----------------------------------------------------------------------------- |
|
221 |
* |
|
222 |
* |- A1 \/ ... \/ An [A1 |- M, ..., An |- M] |
|
223 |
* --------------------------------------------------- |
|
224 |
* |- M |
|
225 |
* |
|
226 |
* Note. The list of theorems may be all jumbled up, so we have to |
|
227 |
* first organize it to align with the first argument (the disjunctive |
|
228 |
* theorem). |
|
229 |
*---------------------------------------------------------------------------*) |
|
230 |
||
231 |
fun organize eq = (* a bit slow - analogous to insertion sort *) |
|
232 |
let fun extract a alist = |
|
233 |
let fun ex (_,[]) = raise RULES_ERR "organize" "not a permutation.1" |
|
234 |
| ex(left,h::t) = if (eq h a) then (h,rev left@t) else ex(h::left,t) |
|
235 |
in ex ([],alist) |
|
236 |
end |
|
237 |
fun place [] [] = [] |
|
238 |
| place (a::rst) alist = |
|
239 |
let val (item,next) = extract a alist |
|
240 |
in item::place rst next |
|
241 |
end |
|
242 |
| place _ _ = raise RULES_ERR "organize" "not a permutation.2" |
|
243 |
in place |
|
244 |
end; |
|
36617
ed8083930203
UNDISCH/DISJ_CASESL: eliminated slightly odd Thm.legacy_freezeT -- these rules appear to be applied to thms with fixed types only;
wenzelm
parents:
36615
diff
changeset
|
245 |
|
23150 | 246 |
fun DISJ_CASESL disjth thl = |
247 |
let val c = cconcl disjth |
|
59582 | 248 |
fun eq th atm = |
249 |
exists (fn t => HOLogic.dest_Trueprop t aconv Thm.term_of atm) (Thm.hyps_of th) |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
250 |
val tml = Dcterm.strip_disj c |
23150 | 251 |
fun DL th [] = raise RULES_ERR "DISJ_CASESL" "no cases" |
252 |
| DL th [th1] = PROVE_HYP th th1 |
|
253 |
| DL th [th1,th2] = DISJ_CASES th th1 th2 |
|
254 |
| DL th (th1::rst) = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
255 |
let val tm = #2 (Dcterm.dest_disj (Dcterm.drop_prop(cconcl th))) |
23150 | 256 |
in DISJ_CASES th th1 (DL (ASSUME tm) rst) end |
36617
ed8083930203
UNDISCH/DISJ_CASESL: eliminated slightly odd Thm.legacy_freezeT -- these rules appear to be applied to thms with fixed types only;
wenzelm
parents:
36615
diff
changeset
|
257 |
in DL disjth (organize eq tml thl) |
23150 | 258 |
end; |
259 |
||
260 |
||
261 |
(*---------------------------------------------------------------------------- |
|
262 |
* Universals |
|
263 |
*---------------------------------------------------------------------------*) |
|
264 |
local (* this is fragile *) |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
265 |
val thy = Thm.theory_of_thm spec |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
266 |
val prop = Thm.prop_of spec |
44121 | 267 |
val x = hd (tl (Misc_Legacy.term_vars prop)) |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
268 |
val cTV = Thm.global_ctyp_of thy (type_of x) |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
269 |
val gspec = Thm.forall_intr (Thm.global_cterm_of thy x) spec |
23150 | 270 |
in |
271 |
fun SPEC tm thm = |
|
59586 | 272 |
let val gspec' = Drule.instantiate_normalize ([(cTV, Thm.ctyp_of_cterm tm)], []) gspec |
36945 | 273 |
in thm RS (Thm.forall_elim tm gspec') end |
23150 | 274 |
end; |
275 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
276 |
fun SPEC_ALL thm = fold SPEC (#1 (Dcterm.strip_forall(cconcl thm))) thm; |
23150 | 277 |
|
278 |
val ISPEC = SPEC |
|
279 |
val ISPECL = fold ISPEC; |
|
280 |
||
281 |
(* Not optimized! Too complicated. *) |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
282 |
local val thy = Thm.theory_of_thm allI |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
283 |
val prop = Thm.prop_of allI |
44121 | 284 |
val [P] = Misc_Legacy.add_term_vars (prop, []) |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
285 |
fun cty_theta s = map (fn (i, (S, ty)) => (Thm.global_ctyp_of s (TVar (i, S)), Thm.global_ctyp_of s ty)) |
23150 | 286 |
fun ctm_theta s = map (fn (i, (_, tm2)) => |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
287 |
let val ctm2 = Thm.global_cterm_of s tm2 |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
288 |
in (Thm.global_cterm_of s (Var(i, Thm.typ_of_cterm ctm2)), ctm2) |
23150 | 289 |
end) |
290 |
fun certify s (ty_theta,tm_theta) = |
|
291 |
(cty_theta s (Vartab.dest ty_theta), |
|
292 |
ctm_theta s (Vartab.dest tm_theta)) |
|
293 |
in |
|
294 |
fun GEN v th = |
|
36945 | 295 |
let val gth = Thm.forall_intr v th |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
296 |
val thy = Thm.theory_of_thm gth |
56245 | 297 |
val Const(@{const_name Pure.all},_)$Abs(x,ty,rst) = Thm.prop_of gth |
23150 | 298 |
val P' = Abs(x,ty, HOLogic.dest_Trueprop rst) (* get rid of trueprop *) |
299 |
val theta = Pattern.match thy (P,P') (Vartab.empty, Vartab.empty); |
|
43333
2bdec7f430d3
renamed Drule.instantiate to Drule.instantiate_normalize to emphasize its meaning as opposed to plain Thm.instantiate;
wenzelm
parents:
42361
diff
changeset
|
300 |
val allI2 = Drule.instantiate_normalize (certify thy theta) allI |
23150 | 301 |
val thm = Thm.implies_elim allI2 gth |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
302 |
val tp $ (A $ Abs(_,_,M)) = Thm.prop_of thm |
23150 | 303 |
val prop' = tp $ (A $ Abs(x,ty,M)) |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
304 |
in ALPHA thm (Thm.global_cterm_of thy prop') |
23150 | 305 |
end |
306 |
end; |
|
307 |
||
308 |
val GENL = fold_rev GEN; |
|
309 |
||
310 |
fun GEN_ALL thm = |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
311 |
let val thy = Thm.theory_of_thm thm |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
312 |
val prop = Thm.prop_of thm |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
313 |
val tycheck = Thm.global_cterm_of thy |
44121 | 314 |
val vlist = map tycheck (Misc_Legacy.add_term_vars (prop, [])) |
23150 | 315 |
in GENL vlist thm |
316 |
end; |
|
317 |
||
318 |
||
319 |
fun MATCH_MP th1 th2 = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
320 |
if (Dcterm.is_forall (Dcterm.drop_prop(cconcl th1))) |
23150 | 321 |
then MATCH_MP (th1 RS spec) th2 |
322 |
else MP th1 th2; |
|
323 |
||
324 |
||
325 |
(*---------------------------------------------------------------------------- |
|
326 |
* Existentials |
|
327 |
*---------------------------------------------------------------------------*) |
|
328 |
||
329 |
||
330 |
||
331 |
(*--------------------------------------------------------------------------- |
|
332 |
* Existential elimination |
|
333 |
* |
|
334 |
* A1 |- ?x.t[x] , A2, "t[v]" |- t' |
|
335 |
* ------------------------------------ (variable v occurs nowhere) |
|
336 |
* A1 u A2 |- t' |
|
337 |
* |
|
338 |
*---------------------------------------------------------------------------*) |
|
339 |
||
60334 | 340 |
fun CHOOSE ctxt (fvar, exth) fact = |
23150 | 341 |
let |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
342 |
val lam = #2 (Dcterm.dest_comb (Dcterm.drop_prop (cconcl exth))) |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
343 |
val redex = Dcterm.capply lam fvar |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
344 |
val t$u = Thm.term_of redex |
60334 | 345 |
val residue = Thm.cterm_of ctxt (Term.betapply (t, u)) |
23150 | 346 |
in |
347 |
GEN fvar (DISCH residue fact) RS (exth RS Thms.choose_thm) |
|
348 |
handle THM (msg, _, _) => raise RULES_ERR "CHOOSE" msg |
|
349 |
end; |
|
350 |
||
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
351 |
local val thy = Thm.theory_of_thm exI |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
352 |
val prop = Thm.prop_of exI |
44121 | 353 |
val [P,x] = Misc_Legacy.term_vars prop |
23150 | 354 |
in |
355 |
fun EXISTS (template,witness) thm = |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
356 |
let val thy = Thm.theory_of_thm thm |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
357 |
val prop = Thm.prop_of thm |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
358 |
val P' = Thm.global_cterm_of thy P |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
359 |
val x' = Thm.global_cterm_of thy x |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
360 |
val abstr = #2 (Dcterm.dest_comb template) |
23150 | 361 |
in |
362 |
thm RS (cterm_instantiate[(P',abstr), (x',witness)] exI) |
|
363 |
handle THM (msg, _, _) => raise RULES_ERR "EXISTS" msg |
|
364 |
end |
|
365 |
end; |
|
366 |
||
367 |
(*---------------------------------------------------------------------------- |
|
368 |
* |
|
369 |
* A |- M |
|
370 |
* ------------------- [v_1,...,v_n] |
|
371 |
* A |- ?v1...v_n. M |
|
372 |
* |
|
373 |
*---------------------------------------------------------------------------*) |
|
374 |
||
375 |
fun EXISTL vlist th = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
376 |
fold_rev (fn v => fn thm => EXISTS(Dcterm.mk_exists(v,cconcl thm), v) thm) |
23150 | 377 |
vlist th; |
378 |
||
379 |
||
380 |
(*---------------------------------------------------------------------------- |
|
381 |
* |
|
382 |
* A |- M[x_1,...,x_n] |
|
383 |
* ---------------------------- [(x |-> y)_1,...,(x |-> y)_n] |
|
384 |
* A |- ?y_1...y_n. M |
|
385 |
* |
|
386 |
*---------------------------------------------------------------------------*) |
|
387 |
(* Could be improved, but needs "subst_free" for certified terms *) |
|
388 |
||
389 |
fun IT_EXISTS blist th = |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
390 |
let val thy = Thm.theory_of_thm th |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
391 |
val tych = Thm.global_cterm_of thy |
59058
a78612c67ec0
renamed "pairself" to "apply2", in accordance to @{apply 2};
wenzelm
parents:
56245
diff
changeset
|
392 |
val blist' = map (apply2 Thm.term_of) blist |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
393 |
fun ex v M = Thm.global_cterm_of thy (USyntax.mk_exists{Bvar=v,Body = M}) |
23150 | 394 |
|
395 |
in |
|
396 |
fold_rev (fn (b as (r1,r2)) => fn thm => |
|
397 |
EXISTS(ex r2 (subst_free [b] |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
398 |
(HOLogic.dest_Trueprop(Thm.prop_of thm))), tych r1) |
23150 | 399 |
thm) |
400 |
blist' th |
|
401 |
end; |
|
402 |
||
403 |
(*--------------------------------------------------------------------------- |
|
404 |
* Faster version, that fails for some as yet unknown reason |
|
405 |
* fun IT_EXISTS blist th = |
|
406 |
* let val {thy,...} = rep_thm th |
|
407 |
* val tych = cterm_of thy |
|
408 |
* fun detype (x,y) = ((#t o rep_cterm) x, (#t o rep_cterm) y) |
|
409 |
* in |
|
410 |
* fold (fn (b as (r1,r2), thm) => |
|
411 |
* EXISTS(D.mk_exists(r2, tych(subst_free[detype b](#t(rep_cterm(cconcl thm))))), |
|
412 |
* r1) thm) blist th |
|
413 |
* end; |
|
414 |
*---------------------------------------------------------------------------*) |
|
415 |
||
416 |
(*---------------------------------------------------------------------------- |
|
417 |
* Rewriting |
|
418 |
*---------------------------------------------------------------------------*) |
|
419 |
||
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
420 |
fun SUBS ctxt thl = |
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
421 |
rewrite_rule ctxt (map (fn th => th RS eq_reflection handle THM _ => th) thl); |
23150 | 422 |
|
41228
e1fce873b814
renamed structure MetaSimplifier to raw_Simplifer, to emphasize its meaning;
wenzelm
parents:
41225
diff
changeset
|
423 |
val rew_conv = Raw_Simplifier.rewrite_cterm (true, false, false) (K (K NONE)); |
23150 | 424 |
|
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
425 |
fun simpl_conv ctxt thl ctm = |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
426 |
rew_conv (ctxt addsimps thl) ctm RS meta_eq_to_obj_eq; |
23150 | 427 |
|
428 |
||
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
429 |
fun RIGHT_ASSOC ctxt = rewrite_rule ctxt [Thms.disj_assoc]; |
23150 | 430 |
|
431 |
||
432 |
||
433 |
(*--------------------------------------------------------------------------- |
|
434 |
* TERMINATION CONDITION EXTRACTION |
|
435 |
*---------------------------------------------------------------------------*) |
|
436 |
||
437 |
||
438 |
(* Object language quantifier, i.e., "!" *) |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
439 |
fun Forall v M = USyntax.mk_forall{Bvar=v, Body=M}; |
23150 | 440 |
|
441 |
||
442 |
(* Fragile: it's a cong if it is not "R y x ==> cut f R x y = f y" *) |
|
443 |
fun is_cong thm = |
|
56245 | 444 |
case (Thm.prop_of thm) of |
445 |
(Const(@{const_name Pure.imp},_)$(Const(@{const_name Trueprop},_)$ _) $ |
|
446 |
(Const(@{const_name Pure.eq},_) $ (Const (@{const_name Wfrec.cut},_) $ f $ R $ a $ x) $ _)) => |
|
447 |
false |
|
448 |
| _ => true; |
|
23150 | 449 |
|
450 |
||
56245 | 451 |
fun dest_equal(Const (@{const_name Pure.eq},_) $ |
38554
f8999e19dd49
corrected some long-overseen misperceptions in recdef
haftmann
parents:
38549
diff
changeset
|
452 |
(Const (@{const_name Trueprop},_) $ lhs) |
f8999e19dd49
corrected some long-overseen misperceptions in recdef
haftmann
parents:
38549
diff
changeset
|
453 |
$ (Const (@{const_name Trueprop},_) $ rhs)) = {lhs=lhs, rhs=rhs} |
56245 | 454 |
| dest_equal(Const (@{const_name Pure.eq},_) $ lhs $ rhs) = {lhs=lhs, rhs=rhs} |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
455 |
| dest_equal tm = USyntax.dest_eq tm; |
23150 | 456 |
|
457 |
fun get_lhs tm = #lhs(dest_equal (HOLogic.dest_Trueprop tm)); |
|
458 |
||
56245 | 459 |
fun dest_all used (Const(@{const_name Pure.all},_) $ (a as Abs _)) = USyntax.dest_abs used a |
23150 | 460 |
| dest_all _ _ = raise RULES_ERR "dest_all" "not a !!"; |
461 |
||
462 |
val is_all = can (dest_all []); |
|
463 |
||
464 |
fun strip_all used fm = |
|
465 |
if (is_all fm) |
|
466 |
then let val ({Bvar, Body}, used') = dest_all used fm |
|
467 |
val (bvs, core, used'') = strip_all used' Body |
|
468 |
in ((Bvar::bvs), core, used'') |
|
469 |
end |
|
470 |
else ([], fm, used); |
|
471 |
||
56245 | 472 |
fun break_all(Const(@{const_name Pure.all},_) $ Abs (_,_,body)) = body |
23150 | 473 |
| break_all _ = raise RULES_ERR "break_all" "not a !!"; |
474 |
||
56245 | 475 |
fun list_break_all(Const(@{const_name Pure.all},_) $ Abs (s,ty,body)) = |
23150 | 476 |
let val (L,core) = list_break_all body |
477 |
in ((s,ty)::L, core) |
|
478 |
end |
|
479 |
| list_break_all tm = ([],tm); |
|
480 |
||
481 |
(*--------------------------------------------------------------------------- |
|
482 |
* Rename a term of the form |
|
483 |
* |
|
484 |
* !!x1 ...xn. x1=M1 ==> ... ==> xn=Mn |
|
485 |
* ==> ((%v1...vn. Q) x1 ... xn = g x1 ... xn. |
|
486 |
* to one of |
|
487 |
* |
|
488 |
* !!v1 ... vn. v1=M1 ==> ... ==> vn=Mn |
|
489 |
* ==> ((%v1...vn. Q) v1 ... vn = g v1 ... vn. |
|
490 |
* |
|
491 |
* This prevents name problems in extraction, and helps the result to read |
|
492 |
* better. There is a problem with varstructs, since they can introduce more |
|
493 |
* than n variables, and some extra reasoning needs to be done. |
|
494 |
*---------------------------------------------------------------------------*) |
|
495 |
||
496 |
fun get ([],_,L) = rev L |
|
497 |
| get (ant::rst,n,L) = |
|
498 |
case (list_break_all ant) |
|
499 |
of ([],_) => get (rst, n+1,L) |
|
500 |
| (vlist,body) => |
|
501 |
let val eq = Logic.strip_imp_concl body |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
502 |
val (f,args) = USyntax.strip_comb (get_lhs eq) |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
503 |
val (vstrl,_) = USyntax.strip_abs f |
23150 | 504 |
val names = |
44121 | 505 |
Name.variant_list (Misc_Legacy.add_term_names(body, [])) (map (#1 o dest_Free) vstrl) |
23150 | 506 |
in get (rst, n+1, (names,n)::L) end |
507 |
handle TERM _ => get (rst, n+1, L) |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
508 |
| Utils.ERR _ => get (rst, n+1, L); |
23150 | 509 |
|
31945 | 510 |
(* Note: Thm.rename_params_rule counts from 1, not 0 *) |
23150 | 511 |
fun rename thm = |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
512 |
let val thy = Thm.theory_of_thm thm |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
513 |
val tych = Thm.global_cterm_of thy |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
514 |
val ants = Logic.strip_imp_prems (Thm.prop_of thm) |
23150 | 515 |
val news = get (ants,1,[]) |
516 |
in |
|
31945 | 517 |
fold Thm.rename_params_rule news thm |
23150 | 518 |
end; |
519 |
||
520 |
||
521 |
(*--------------------------------------------------------------------------- |
|
522 |
* Beta-conversion to the rhs of an equation (taken from hol90/drule.sml) |
|
523 |
*---------------------------------------------------------------------------*) |
|
524 |
||
525 |
fun list_beta_conv tm = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
526 |
let fun rbeta th = Thm.transitive th (Thm.beta_conversion false (#2(Dcterm.dest_eq(cconcl th)))) |
23150 | 527 |
fun iter [] = Thm.reflexive tm |
36945 | 528 |
| iter (v::rst) = rbeta (Thm.combination(iter rst) (Thm.reflexive v)) |
23150 | 529 |
in iter end; |
530 |
||
531 |
||
532 |
(*--------------------------------------------------------------------------- |
|
533 |
* Trace information for the rewriter |
|
534 |
*---------------------------------------------------------------------------*) |
|
32740 | 535 |
val tracing = Unsynchronized.ref false; |
23150 | 536 |
|
537 |
fun say s = if !tracing then writeln s else (); |
|
538 |
||
55236 | 539 |
fun print_thms ctxt s L = |
540 |
say (cat_lines (s :: map (Display.string_of_thm ctxt) L)); |
|
23150 | 541 |
|
55236 | 542 |
fun print_cterm ctxt s ct = |
543 |
say (cat_lines [s, Syntax.string_of_term ctxt (Thm.term_of ct)]); |
|
23150 | 544 |
|
545 |
||
546 |
(*--------------------------------------------------------------------------- |
|
547 |
* General abstraction handlers, should probably go in USyntax. |
|
548 |
*---------------------------------------------------------------------------*) |
|
549 |
fun mk_aabs (vstr, body) = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
550 |
USyntax.mk_abs {Bvar = vstr, Body = body} |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
551 |
handle Utils.ERR _ => USyntax.mk_pabs {varstruct = vstr, body = body}; |
23150 | 552 |
|
553 |
fun list_mk_aabs (vstrl,tm) = |
|
554 |
fold_rev (fn vstr => fn tm => mk_aabs(vstr,tm)) vstrl tm; |
|
555 |
||
556 |
fun dest_aabs used tm = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
557 |
let val ({Bvar,Body}, used') = USyntax.dest_abs used tm |
23150 | 558 |
in (Bvar, Body, used') end |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
559 |
handle Utils.ERR _ => |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
560 |
let val {varstruct, body, used} = USyntax.dest_pabs used tm |
23150 | 561 |
in (varstruct, body, used) end; |
562 |
||
563 |
fun strip_aabs used tm = |
|
564 |
let val (vstr, body, used') = dest_aabs used tm |
|
565 |
val (bvs, core, used'') = strip_aabs used' body |
|
566 |
in (vstr::bvs, core, used'') end |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
567 |
handle Utils.ERR _ => ([], tm, used); |
23150 | 568 |
|
569 |
fun dest_combn tm 0 = (tm,[]) |
|
570 |
| dest_combn tm n = |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
571 |
let val {Rator,Rand} = USyntax.dest_comb tm |
23150 | 572 |
val (f,rands) = dest_combn Rator (n-1) |
573 |
in (f,Rand::rands) |
|
574 |
end; |
|
575 |
||
576 |
||
577 |
||
578 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
579 |
local fun dest_pair M = let val {fst,snd} = USyntax.dest_pair M in (fst,snd) end |
23150 | 580 |
fun mk_fst tm = |
37678
0040bafffdef
"prod" and "sum" replace "*" and "+" respectively
haftmann
parents:
37391
diff
changeset
|
581 |
let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm |
55411 | 582 |
in Const (@{const_name Product_Type.fst}, ty --> fty) $ tm end |
23150 | 583 |
fun mk_snd tm = |
37678
0040bafffdef
"prod" and "sum" replace "*" and "+" respectively
haftmann
parents:
37391
diff
changeset
|
584 |
let val ty as Type(@{type_name Product_Type.prod}, [fty,sty]) = type_of tm |
55411 | 585 |
in Const (@{const_name Product_Type.snd}, ty --> sty) $ tm end |
23150 | 586 |
in |
587 |
fun XFILL tych x vstruct = |
|
588 |
let fun traverse p xocc L = |
|
589 |
if (is_Free p) |
|
590 |
then tych xocc::L |
|
591 |
else let val (p1,p2) = dest_pair p |
|
592 |
in traverse p1 (mk_fst xocc) (traverse p2 (mk_snd xocc) L) |
|
593 |
end |
|
594 |
in |
|
595 |
traverse vstruct x [] |
|
596 |
end end; |
|
597 |
||
598 |
(*--------------------------------------------------------------------------- |
|
599 |
* Replace a free tuple (vstr) by a universally quantified variable (a). |
|
600 |
* Note that the notion of "freeness" for a tuple is different than for a |
|
601 |
* variable: if variables in the tuple also occur in any other place than |
|
602 |
* an occurrences of the tuple, they aren't "free" (which is thus probably |
|
603 |
* the wrong word to use). |
|
604 |
*---------------------------------------------------------------------------*) |
|
605 |
||
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
606 |
fun VSTRUCT_ELIM ctxt tych a vstr th = |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
607 |
let val L = USyntax.free_vars_lr vstr |
23150 | 608 |
val bind1 = tych (HOLogic.mk_Trueprop (HOLogic.mk_eq(a,vstr))) |
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
609 |
val thm1 = Thm.implies_intr bind1 (SUBS ctxt [SYM(Thm.assume bind1)] th) |
23150 | 610 |
val thm2 = forall_intr_list (map tych L) thm1 |
611 |
val thm3 = forall_elim_list (XFILL tych a vstr) thm2 |
|
612 |
in refl RS |
|
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
613 |
rewrite_rule ctxt [Thm.symmetric (@{thm surjective_pairing} RS eq_reflection)] thm3 |
23150 | 614 |
end; |
615 |
||
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
616 |
fun PGEN ctxt tych a vstr th = |
23150 | 617 |
let val a1 = tych a |
618 |
val vstr1 = tych vstr |
|
619 |
in |
|
36945 | 620 |
Thm.forall_intr a1 |
23150 | 621 |
(if (is_Free vstr) |
622 |
then cterm_instantiate [(vstr1,a1)] th |
|
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
623 |
else VSTRUCT_ELIM ctxt tych a vstr th) |
23150 | 624 |
end; |
625 |
||
626 |
||
627 |
(*--------------------------------------------------------------------------- |
|
628 |
* Takes apart a paired beta-redex, looking like "(\(x,y).N) vstr", into |
|
629 |
* |
|
630 |
* (([x,y],N),vstr) |
|
631 |
*---------------------------------------------------------------------------*) |
|
632 |
fun dest_pbeta_redex used M n = |
|
633 |
let val (f,args) = dest_combn M n |
|
634 |
val dummy = dest_aabs used f |
|
635 |
in (strip_aabs used f,args) |
|
636 |
end; |
|
637 |
||
60329
e85ed7a36b2f
eliminated odd C combinator -- Isabelle/ML usually has canonical argument order;
wenzelm
parents:
59621
diff
changeset
|
638 |
fun pbeta_redex M n = can (fn t => dest_pbeta_redex [] t n) M; |
23150 | 639 |
|
640 |
fun dest_impl tm = |
|
641 |
let val ants = Logic.strip_imp_prems tm |
|
642 |
val eq = Logic.strip_imp_concl tm |
|
643 |
in (ants,get_lhs eq) |
|
644 |
end; |
|
645 |
||
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
646 |
fun restricted t = is_some (USyntax.find_term |
44014
88bd7d74a2c1
moved recursion combinator to HOL/Library/Wfrec.thy -- it is so fundamental and well-known that it should survive recdef
krauss
parents:
44013
diff
changeset
|
647 |
(fn (Const(@{const_name Wfrec.cut},_)) =>true | _ => false) |
23150 | 648 |
t) |
649 |
||
650 |
fun CONTEXT_REWRITE_RULE (func, G, cut_lemma, congs) th = |
|
651 |
let val globals = func::G |
|
54895 | 652 |
val ctxt0 = empty_simpset (Proof_Context.init_global (Thm.theory_of_thm th)) |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
653 |
val pbeta_reduce = simpl_conv ctxt0 [@{thm split_conv} RS eq_reflection]; |
32740 | 654 |
val tc_list = Unsynchronized.ref []: term list Unsynchronized.ref |
23150 | 655 |
val cut_lemma' = cut_lemma RS eq_reflection |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
656 |
fun prover used ctxt thm = |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
657 |
let fun cong_prover ctxt thm = |
23150 | 658 |
let val dummy = say "cong_prover:" |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
659 |
val cntxt = Simplifier.prems_of ctxt |
55236 | 660 |
val dummy = print_thms ctxt "cntxt:" cntxt |
23150 | 661 |
val dummy = say "cong rule:" |
55236 | 662 |
val dummy = say (Display.string_of_thm ctxt thm) |
23150 | 663 |
(* Unquantified eliminate *) |
664 |
fun uq_eliminate (thm,imp,thy) = |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
665 |
let val tych = Thm.global_cterm_of thy |
55236 | 666 |
val dummy = print_cterm ctxt "To eliminate:" (tych imp) |
23150 | 667 |
val ants = map tych (Logic.strip_imp_prems imp) |
668 |
val eq = Logic.strip_imp_concl imp |
|
669 |
val lhs = tych(get_lhs eq) |
|
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
670 |
val ctxt' = Simplifier.add_prems (map ASSUME ants) ctxt |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
671 |
val lhs_eq_lhs1 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used) ctxt' lhs |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
672 |
handle Utils.ERR _ => Thm.reflexive lhs |
55236 | 673 |
val dummy = print_thms ctxt' "proven:" [lhs_eq_lhs1] |
23150 | 674 |
val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1 |
675 |
val lhs_eeq_lhs2 = lhs_eq_lhs2 RS meta_eq_to_obj_eq |
|
676 |
in |
|
677 |
lhs_eeq_lhs2 COMP thm |
|
678 |
end |
|
679 |
fun pq_eliminate (thm,thy,vlist,imp_body,lhs_eq) = |
|
680 |
let val ((vstrl, _, used'), args) = dest_pbeta_redex used lhs_eq (length vlist) |
|
681 |
val dummy = forall (op aconv) (ListPair.zip (vlist, args)) |
|
682 |
orelse error "assertion failed in CONTEXT_REWRITE_RULE" |
|
683 |
val imp_body1 = subst_free (ListPair.zip (args, vstrl)) |
|
684 |
imp_body |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
685 |
val tych = Thm.global_cterm_of thy |
23150 | 686 |
val ants1 = map tych (Logic.strip_imp_prems imp_body1) |
687 |
val eq1 = Logic.strip_imp_concl imp_body1 |
|
688 |
val Q = get_lhs eq1 |
|
689 |
val QeqQ1 = pbeta_reduce (tych Q) |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
690 |
val Q1 = #2(Dcterm.dest_eq(cconcl QeqQ1)) |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
691 |
val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt |
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
692 |
val Q1eeqQ2 = Raw_Simplifier.rewrite_cterm (false,true,false) (prover used') ctxt' Q1 |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
693 |
handle Utils.ERR _ => Thm.reflexive Q1 |
23150 | 694 |
val Q2 = #2 (Logic.dest_equals (Thm.prop_of Q1eeqQ2)) |
695 |
val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl)) |
|
696 |
val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection) |
|
697 |
val thA = Thm.transitive(QeqQ1 RS eq_reflection) Q1eeqQ2 |
|
698 |
val QeeqQ3 = Thm.transitive thA Q2eeqQ3 handle THM _ => |
|
699 |
((Q2eeqQ3 RS meta_eq_to_obj_eq) |
|
700 |
RS ((thA RS meta_eq_to_obj_eq) RS trans)) |
|
701 |
RS eq_reflection |
|
702 |
val impth = implies_intr_list ants1 QeeqQ3 |
|
703 |
val impth1 = impth RS meta_eq_to_obj_eq |
|
704 |
(* Need to abstract *) |
|
54742
7a86358a3c0b
proper context for basic Simplifier operations: rewrite_rule, rewrite_goals_rule, rewrite_goals_tac etc.;
wenzelm
parents:
51717
diff
changeset
|
705 |
val ant_th = Utils.itlist2 (PGEN ctxt' tych) args vstrl impth1 |
23150 | 706 |
in ant_th COMP thm |
707 |
end |
|
708 |
fun q_eliminate (thm,imp,thy) = |
|
709 |
let val (vlist, imp_body, used') = strip_all used imp |
|
710 |
val (ants,Q) = dest_impl imp_body |
|
711 |
in if (pbeta_redex Q) (length vlist) |
|
712 |
then pq_eliminate (thm,thy,vlist,imp_body,Q) |
|
713 |
else |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
714 |
let val tych = Thm.global_cterm_of thy |
23150 | 715 |
val ants1 = map tych ants |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
716 |
val ctxt' = Simplifier.add_prems (map ASSUME ants1) ctxt |
41228
e1fce873b814
renamed structure MetaSimplifier to raw_Simplifer, to emphasize its meaning;
wenzelm
parents:
41225
diff
changeset
|
717 |
val Q_eeq_Q1 = Raw_Simplifier.rewrite_cterm |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
718 |
(false,true,false) (prover used') ctxt' (tych Q) |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
719 |
handle Utils.ERR _ => Thm.reflexive (tych Q) |
23150 | 720 |
val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1 |
721 |
val lhs_eq_lhs2 = lhs_eeq_lhs2 RS meta_eq_to_obj_eq |
|
722 |
val ant_th = forall_intr_list(map tych vlist)lhs_eq_lhs2 |
|
723 |
in |
|
724 |
ant_th COMP thm |
|
725 |
end end |
|
726 |
||
727 |
fun eliminate thm = |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
728 |
case Thm.prop_of thm |
56245 | 729 |
of Const(@{const_name Pure.imp},_) $ imp $ _ => |
23150 | 730 |
eliminate |
731 |
(if not(is_all imp) |
|
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
732 |
then uq_eliminate (thm, imp, Thm.theory_of_thm thm) |
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
733 |
else q_eliminate (thm, imp, Thm.theory_of_thm thm)) |
23150 | 734 |
(* Assume that the leading constant is ==, *) |
735 |
| _ => thm (* if it is not a ==> *) |
|
736 |
in SOME(eliminate (rename thm)) end |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
737 |
handle Utils.ERR _ => NONE (* FIXME handle THM as well?? *) |
23150 | 738 |
|
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
739 |
fun restrict_prover ctxt thm = |
23150 | 740 |
let val dummy = say "restrict_prover:" |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
741 |
val cntxt = rev (Simplifier.prems_of ctxt) |
55236 | 742 |
val dummy = print_thms ctxt "cntxt:" cntxt |
26626
c6231d64d264
rep_cterm/rep_thm: no longer dereference theory_ref;
wenzelm
parents:
23150
diff
changeset
|
743 |
val thy = Thm.theory_of_thm thm |
56245 | 744 |
val Const(@{const_name Pure.imp},_) $ (Const(@{const_name Trueprop},_) $ A) $ _ = |
745 |
Thm.prop_of thm |
|
23150 | 746 |
fun genl tm = let val vlist = subtract (op aconv) globals |
44121 | 747 |
(Misc_Legacy.add_term_frees(tm,[])) |
23150 | 748 |
in fold_rev Forall vlist tm |
749 |
end |
|
750 |
(*-------------------------------------------------------------- |
|
751 |
* This actually isn't quite right, since it will think that |
|
752 |
* not-fully applied occs. of "f" in the context mean that the |
|
753 |
* current call is nested. The real solution is to pass in a |
|
754 |
* term "f v1..vn" which is a pattern that any full application |
|
755 |
* of "f" will match. |
|
756 |
*-------------------------------------------------------------*) |
|
757 |
val func_name = #1(dest_Const func) |
|
758 |
fun is_func (Const (name,_)) = (name = func_name) |
|
759 |
| is_func _ = false |
|
760 |
val rcontext = rev cntxt |
|
761 |
val cncl = HOLogic.dest_Trueprop o Thm.prop_of |
|
762 |
val antl = case rcontext of [] => [] |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
763 |
| _ => [USyntax.list_mk_conj(map cncl rcontext)] |
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
764 |
val TC = genl(USyntax.list_mk_imp(antl, A)) |
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
765 |
val dummy = print_cterm ctxt "func:" (Thm.global_cterm_of thy func) |
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
766 |
val dummy = print_cterm ctxt "TC:" (Thm.global_cterm_of thy (HOLogic.mk_Trueprop TC)) |
23150 | 767 |
val dummy = tc_list := (TC :: !tc_list) |
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
768 |
val nestedp = is_some (USyntax.find_term is_func TC) |
23150 | 769 |
val dummy = if nestedp then say "nested" else say "not_nested" |
770 |
val th' = if nestedp then raise RULES_ERR "solver" "nested function" |
|
59621
291934bac95e
Thm.cterm_of and Thm.ctyp_of operate on local context;
wenzelm
parents:
59586
diff
changeset
|
771 |
else let val cTC = Thm.global_cterm_of thy |
23150 | 772 |
(HOLogic.mk_Trueprop TC) |
773 |
in case rcontext of |
|
774 |
[] => SPEC_ALL(ASSUME cTC) |
|
775 |
| _ => MP (SPEC_ALL (ASSUME cTC)) |
|
776 |
(LIST_CONJ rcontext) |
|
777 |
end |
|
778 |
val th'' = th' RS thm |
|
779 |
in SOME (th'') |
|
41164
6854e9a40edc
avoid ML structure aliases (especially single-letter abbreviations);
wenzelm
parents:
38801
diff
changeset
|
780 |
end handle Utils.ERR _ => NONE (* FIXME handle THM as well?? *) |
23150 | 781 |
in |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
782 |
(if (is_cong thm) then cong_prover else restrict_prover) ctxt thm |
23150 | 783 |
end |
59582 | 784 |
val ctm = Thm.cprop_of th |
785 |
val names = Misc_Legacy.add_term_names (Thm.term_of ctm, []) |
|
45620
f2a587696afb
modernized some old-style infix operations, which were left over from the time of ML proof scripts;
wenzelm
parents:
44121
diff
changeset
|
786 |
val th1 = |
f2a587696afb
modernized some old-style infix operations, which were left over from the time of ML proof scripts;
wenzelm
parents:
44121
diff
changeset
|
787 |
Raw_Simplifier.rewrite_cterm (false, true, false) |
51717
9e7d1c139569
simplifier uses proper Proof.context instead of historic type simpset;
wenzelm
parents:
45620
diff
changeset
|
788 |
(prover names) (ctxt0 addsimps [cut_lemma'] |> fold Simplifier.add_eqcong congs) ctm |
36945 | 789 |
val th2 = Thm.equal_elim th1 th |
23150 | 790 |
in |
33317 | 791 |
(th2, filter_out restricted (!tc_list)) |
23150 | 792 |
end; |
793 |
||
794 |
||
60335 | 795 |
fun prove ctxt strict (t, tac) = |
23150 | 796 |
let |
60335 | 797 |
val ctxt' = Variable.auto_fixes t ctxt; |
23150 | 798 |
in |
60335 | 799 |
if strict |
800 |
then Goal.prove ctxt' [] [] t (K tac) |
|
801 |
else Goal.prove ctxt' [] [] t (K tac) |
|
23150 | 802 |
handle ERROR msg => (warning msg; raise RULES_ERR "prove" msg) |
803 |
end; |
|
804 |
||
805 |
end; |