author | paulson |
Fri, 25 Sep 1998 14:05:34 +0200 | |
changeset 5566 | d176d9d17181 |
parent 5143 | b94cd208f073 |
permissions | -rw-r--r-- |
3807 | 1 |
(* Title: ~/projects/isabelle/TLA/hypsubst.ML |
2 |
Authors: Martin D Coen, Tobias Nipkow and Lawrence C Paulson |
|
3 |
Copyright 1995 University of Cambridge |
|
4 |
||
5 |
Tactic to substitute using the assumption x=t in the rest of the subgoal, |
|
6 |
and to delete that assumption. Original version due to Martin Coen. |
|
7 |
||
8 |
This version uses the simplifier, and requires it to be already present. |
|
9 |
||
10 |
Local changes for TLA (Stephan Merz): |
|
11 |
Simplify equations like f(x) = g(y) if x,y are bound variables. |
|
12 |
This is useful for TLA if f and g are state variables. f and g may be |
|
13 |
free or bound variables, or even constants. (This may be unsafe, but |
|
14 |
we do some type checking to restrict this to state variables!) |
|
15 |
||
16 |
||
17 |
||
18 |
Test data: |
|
19 |
||
5143
b94cd208f073
Removal of leading "\!\!..." from most Goal commands
paulson
parents:
5069
diff
changeset
|
20 |
Goal "[| Q(x,y,z); y=x; a=x; z=y; P(y) |] ==> P(z)"; |
b94cd208f073
Removal of leading "\!\!..." from most Goal commands
paulson
parents:
5069
diff
changeset
|
21 |
Goal "[| Q(x,y,z); z=f(x); x=z |] ==> P(z)"; |
b94cd208f073
Removal of leading "\!\!..." from most Goal commands
paulson
parents:
5069
diff
changeset
|
22 |
Goal "[| ?x=y; P(?x) |] ==> y = a"; |
b94cd208f073
Removal of leading "\!\!..." from most Goal commands
paulson
parents:
5069
diff
changeset
|
23 |
Goal "[| ?x=y; P(?x) |] ==> y = a"; |
3807 | 24 |
|
25 |
by (hyp_subst_tac 1); |
|
26 |
by (bound_hyp_subst_tac 1); |
|
27 |
||
28 |
Here hyp_subst_tac goes wrong; harder still to prove P(f(f(a))) & P(f(a)) |
|
5069 | 29 |
Goal "P(a) --> (EX y. a=y --> P(f(a)))"; |
3807 | 30 |
*) |
31 |
||
32 |
(*** Signatures unchanged (but renamed) from the original hypsubst.ML ***) |
|
33 |
||
34 |
signature ACTHYPSUBST_DATA = |
|
35 |
sig |
|
36 |
structure Simplifier : SIMPLIFIER |
|
37 |
val dest_eq : term -> term*term |
|
38 |
val eq_reflection : thm (* a=b ==> a==b *) |
|
39 |
val imp_intr : thm (* (P ==> Q) ==> P-->Q *) |
|
40 |
val rev_mp : thm (* [| P; P-->Q |] ==> Q *) |
|
41 |
val subst : thm (* [| a=b; P(a) |] ==> P(b) *) |
|
42 |
val sym : thm (* a=b ==> b=a *) |
|
43 |
end; |
|
44 |
||
45 |
||
46 |
signature ACTHYPSUBST = |
|
47 |
sig |
|
48 |
val action_bound_hyp_subst_tac : int -> tactic |
|
49 |
val action_hyp_subst_tac : int -> tactic |
|
50 |
(*exported purely for debugging purposes*) |
|
51 |
val gen_hyp_subst_tac : bool -> int -> tactic |
|
52 |
val vars_gen_hyp_subst_tac : bool -> int -> tactic |
|
53 |
val eq_var : bool -> bool -> term -> int * bool |
|
54 |
val inspect_pair : bool -> bool -> term * term -> bool |
|
55 |
val mk_eqs : thm -> thm list |
|
56 |
val thin_leading_eqs_tac : bool -> int -> int -> tactic |
|
57 |
end; |
|
58 |
||
59 |
||
60 |
functor ActHypsubstFun(Data: ACTHYPSUBST_DATA): ACTHYPSUBST = |
|
61 |
struct |
|
62 |
||
63 |
fun STATE tacfun st = tacfun st st; |
|
64 |
||
65 |
||
5566 | 66 |
local open Data |
67 |
BasisLibrary (*for Int, List, ...*) |
|
68 |
in |
|
3807 | 69 |
|
70 |
exception EQ_VAR; |
|
71 |
||
72 |
fun loose (i,t) = 0 mem add_loose_bnos(t,i,[]); |
|
73 |
||
74 |
local val odot = ord"." |
|
75 |
in |
|
76 |
(*Simplifier turns Bound variables to dotted Free variables: |
|
77 |
change it back (any Bound variable will do) |
|
78 |
*) |
|
79 |
fun contract t = |
|
80 |
case Pattern.eta_contract t of |
|
81 |
Free(a,T) => if (ord a = odot) then Bound 0 else Free(a,T) |
|
82 |
| Free at $ Free(b,T) => Free at $ |
|
83 |
(if ord b = odot then Bound 0 else Free(b,T)) |
|
84 |
| t' => t' |
|
85 |
end; |
|
86 |
||
87 |
fun has_vars t = maxidx_of_term t <> ~1; |
|
88 |
||
89 |
(* Added for TLA version. |
|
90 |
Is type ty the type of a state variable? Only then do we substitute |
|
91 |
in applications. This function either returns true or raises Match. |
|
92 |
*) |
|
3945 | 93 |
fun is_stvar (Type("fun", Type("Stfun.state",[])::_)) = true; |
3807 | 94 |
|
95 |
||
96 |
(*If novars then we forbid Vars in the equality. |
|
97 |
If bnd then we only look for Bound (or dotted Free) variables to eliminate. |
|
98 |
When can we safely delete the equality? |
|
99 |
Not if it equates two constants; consider 0=1. |
|
100 |
Not if it resembles x=t[x], since substitution does not eliminate x. |
|
101 |
Not if it resembles ?x=0; another goal could instantiate ?x to Suc(i) |
|
102 |
Not if it involves a variable free in the premises, |
|
103 |
but we can't check for this -- hence bnd and bound_hyp_subst_tac |
|
104 |
Prefer to eliminate Bound variables if possible. |
|
105 |
Result: true = use as is, false = reorient first *) |
|
106 |
fun inspect_pair bnd novars (t,u) = |
|
107 |
case (contract t, contract u) of |
|
108 |
(Bound i, _) => if loose(i,u) orelse novars andalso has_vars u |
|
109 |
then raise Match |
|
110 |
else true (*eliminates t*) |
|
111 |
| (_, Bound i) => if loose(i,t) orelse novars andalso has_vars t |
|
112 |
then raise Match |
|
113 |
else false (*eliminates u*) |
|
114 |
| (Free _, _) => if bnd orelse Logic.occs(t,u) orelse |
|
115 |
novars andalso has_vars u |
|
116 |
then raise Match |
|
117 |
else true (*eliminates t*) |
|
118 |
| (_, Free _) => if bnd orelse Logic.occs(u,t) orelse |
|
119 |
novars andalso has_vars t |
|
120 |
then raise Match |
|
121 |
else false (*eliminates u*) |
|
122 |
| (Free(_,ty) $ (Bound _), _) => |
|
123 |
if bnd orelse |
|
124 |
novars andalso has_vars u |
|
125 |
then raise Match |
|
126 |
else is_stvar(ty) (* changed for TLA *) |
|
127 |
| (_, Free(_,ty) $ (Bound _)) => |
|
128 |
if bnd orelse |
|
129 |
novars andalso has_vars t |
|
130 |
then raise Match |
|
131 |
else not(is_stvar(ty)) (* changed for TLA *) |
|
132 |
| ((Bound _) $ (Bound _), _) => (* can't check for types here *) |
|
133 |
if bnd orelse |
|
134 |
novars andalso has_vars u |
|
135 |
then raise Match |
|
136 |
else true |
|
137 |
| (_, (Bound _) $ (Bound _)) => (* can't check for types here *) |
|
138 |
if bnd orelse |
|
139 |
novars andalso has_vars t |
|
140 |
then raise Match |
|
141 |
else false |
|
142 |
| (Const(_,ty) $ (Bound _), _) => |
|
143 |
if bnd orelse |
|
144 |
novars andalso has_vars u |
|
145 |
then raise Match |
|
146 |
else is_stvar(ty) (* changed for TLA *) |
|
147 |
| (_, Const(_,ty) $ (Bound _)) => |
|
148 |
if bnd orelse |
|
149 |
novars andalso has_vars t |
|
150 |
then raise Match |
|
151 |
else not(is_stvar(ty)) (* changed for TLA *) |
|
152 |
| _ => raise Match; |
|
153 |
||
154 |
(*Locates a substitutable variable on the left (resp. right) of an equality |
|
155 |
assumption. Returns the number of intervening assumptions. *) |
|
156 |
fun eq_var bnd novars = |
|
157 |
let fun eq_var_aux k (Const("all",_) $ Abs(_,_,t)) = eq_var_aux k t |
|
158 |
| eq_var_aux k (Const("==>",_) $ A $ B) = |
|
159 |
((k, inspect_pair bnd novars (dest_eq A)) |
|
160 |
(*Exception comes from inspect_pair or dest_eq*) |
|
161 |
handle Match => eq_var_aux (k+1) B) |
|
162 |
| eq_var_aux k _ = raise EQ_VAR |
|
163 |
in eq_var_aux 0 end; |
|
164 |
||
165 |
(*We do not try to delete ALL equality assumptions at once. But |
|
166 |
it is easy to handle several consecutive equality assumptions in a row. |
|
167 |
Note that we have to inspect the proof state after doing the rewriting, |
|
168 |
since e.g. z=f(x); x=z changes to z=f(x); x=f(x) and the second equality |
|
169 |
must NOT be deleted. Tactic must rotate or delete m assumptions. |
|
170 |
*) |
|
171 |
fun thin_leading_eqs_tac bnd m i = STATE(fn state => |
|
172 |
let fun count [] = 0 |
|
173 |
| count (A::Bs) = ((inspect_pair bnd true (dest_eq A); |
|
174 |
1 + count Bs) |
|
175 |
handle Match => 0) |
|
176 |
val (_,_,Bi,_) = dest_state(state,i) |
|
177 |
val j = Int.min (m, count (Logic.strip_assums_hyp Bi)) |
|
178 |
in REPEAT_DETERM_N j (etac thin_rl i) THEN |
|
179 |
REPEAT_DETERM_N (m-j) (etac revcut_rl i) |
|
180 |
end); |
|
181 |
||
182 |
(*For the simpset. Adds ALL suitable equalities, even if not first! |
|
183 |
No vars are allowed here, as simpsets are built from meta-assumptions*) |
|
184 |
fun mk_eqs th = |
|
185 |
[ if inspect_pair false false (Data.dest_eq (#prop (rep_thm th))) |
|
186 |
then th RS Data.eq_reflection |
|
187 |
else symmetric(th RS Data.eq_reflection) (*reorient*) ] |
|
188 |
handle Match => []; (*Exception comes from inspect_pair or dest_eq*) |
|
189 |
||
190 |
local open Simplifier |
|
191 |
in |
|
192 |
||
193 |
val hyp_subst_ss = empty_ss setmksimps mk_eqs |
|
194 |
||
195 |
(*Select a suitable equality assumption and substitute throughout the subgoal |
|
196 |
Replaces only Bound variables if bnd is true*) |
|
197 |
fun gen_hyp_subst_tac bnd i = DETERM (STATE(fn state => |
|
198 |
let val (_,_,Bi,_) = dest_state(state,i) |
|
199 |
val n = length(Logic.strip_assums_hyp Bi) - 1 |
|
200 |
val (k,_) = eq_var bnd true Bi |
|
201 |
in |
|
202 |
EVERY [REPEAT_DETERM_N k (etac revcut_rl i), |
|
203 |
asm_full_simp_tac hyp_subst_ss i, |
|
204 |
etac thin_rl i, |
|
205 |
thin_leading_eqs_tac bnd (n-k) i] |
|
206 |
end |
|
207 |
handle THM _ => no_tac | EQ_VAR => no_tac)); |
|
208 |
||
209 |
end; |
|
210 |
||
211 |
val ssubst = standard (sym RS subst); |
|
212 |
||
213 |
(*Old version of the tactic above -- slower but the only way |
|
214 |
to handle equalities containing Vars.*) |
|
215 |
fun vars_gen_hyp_subst_tac bnd i = DETERM (STATE(fn state => |
|
216 |
let val (_,_,Bi,_) = dest_state(state,i) |
|
217 |
val n = length(Logic.strip_assums_hyp Bi) - 1 |
|
218 |
val (k,symopt) = eq_var bnd false Bi |
|
219 |
in |
|
220 |
EVERY [REPEAT_DETERM_N k (etac rev_mp i), |
|
221 |
etac revcut_rl i, |
|
222 |
REPEAT_DETERM_N (n-k) (etac rev_mp i), |
|
223 |
etac (if symopt then ssubst else subst) i, |
|
224 |
REPEAT_DETERM_N n (rtac imp_intr i)] |
|
225 |
end |
|
226 |
handle THM _ => no_tac | EQ_VAR => no_tac)); |
|
227 |
||
228 |
(*Substitutes for Free or Bound variables*) |
|
229 |
val action_hyp_subst_tac = |
|
230 |
(* gen_hyp_subst_tac false ORELSE' *) vars_gen_hyp_subst_tac false; |
|
231 |
||
232 |
(*Substitutes for Bound variables only -- this is always safe*) |
|
233 |
val action_bound_hyp_subst_tac = |
|
234 |
(* gen_hyp_subst_tac true ORELSE' *) vars_gen_hyp_subst_tac true; |
|
235 |
||
236 |
end |
|
237 |
end; |
|
238 |