1 (* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- *)
2 (* Title: Provers/eqsubst.ML
3 Author: Lucas Dixon, University of Edinburgh
5 Modified: 18 Feb 2005 - Lucas -
8 (* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- *)
11 A Tactic to perform a substiution using an equation.
14 (* -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- *)
16 (* Logic specific data stub *)
17 signature EQRULE_DATA =
20 (* to make a meta equality theorem in the current logic *)
21 val prep_meta_eq : thm -> thm list
26 (* the signature of an instance of the SQSUBST tactic *)
27 signature EQSUBST_TAC =
31 ((Term.indexname * Term.typ) list (* type instantiations *)
32 * (Term.indexname * Term.term) list) (* term instantiations *)
33 * (string * Term.typ) list (* fake named type abs env *)
34 * (string * Term.typ) list (* type abs env *)
35 * Term.term (* outer term *)
37 val prep_subst_in_asm :
38 (Sign.sg (* sign for matching *)
40 -> 'a (* input object kind *)
41 -> BasicIsaFTerm.FcTerm (* focusterm to search under *)
42 -> 'b) (* result type *)
43 -> int (* subgoal to subst in *)
44 -> Thm.thm (* target theorem with subgoals *)
45 -> int (* premise to subst in *)
46 -> (Thm.cterm list (* certified free var placeholders for vars *)
47 * int (* premice no. to subst *)
48 * int (* number of assumptions of premice *)
49 * Thm.thm) (* premice as a new theorem for forward reasoning *)
50 * ('a -> 'b) (* matchf *)
52 val prep_subst_in_asms :
53 (Sign.sg -> int -> 'a -> BasicIsaFTerm.FcTerm -> 'b)
54 -> int (* subgoal to subst in *)
55 -> Thm.thm (* target theorem with subgoals *)
56 -> ((Thm.cterm list (* certified free var placeholders for vars *)
57 * int (* premice no. to subst *)
58 * int (* number of assumptions of premice *)
59 * Thm.thm) (* premice as a new theorem for forward reasoning *)
60 * ('a -> 'b)) (* matchf *)
63 val apply_subst_in_asm :
65 -> Thm.thm (* overall theorem *)
66 -> (Thm.cterm list (* certified free var placeholders for vars *)
67 * int (* assump no being subst *)
68 * int (* num of premises of asm *)
69 * Thm.thm) (* premthm *)
74 val prep_concl_subst :
75 (Sign.sg -> int -> 'a -> BasicIsaFTerm.FcTerm -> 'b) (* searchf *)
77 -> Thm.thm (* overall goal theorem *)
78 -> (Thm.cterm list * Thm.thm) * ('a -> 'b) (* (cvfs, conclthm), matchf *)
80 val apply_subst_in_concl :
82 -> Thm.thm (* thm with all goals *)
83 -> Thm.cterm list (* certified free var placeholders for vars *)
84 * Thm.thm (* trivial thm of goal concl *)
85 (* possible matches/unifiers *)
88 -> Thm.thm Seq.seq (* substituted goal *)
90 val searchf_tlr_unify_all :
93 BasicIsaFTerm.FcTerm ->
95 val searchf_tlr_unify_valid :
98 BasicIsaFTerm.FcTerm ->
101 val eqsubst_asm_meth : Thm.thm list -> Proof.method
102 val eqsubst_asm_tac : Thm.thm list -> int -> Thm.thm -> Thm.thm Seq.seq
103 val eqsubst_asm_tac' :
106 BasicIsaFTerm.FcTerm ->
107 match Seq.seq) -> Thm.thm -> int -> Thm.thm -> Thm.thm Seq.seq
109 val eqsubst_meth : Thm.thm list -> Proof.method
110 val eqsubst_tac : Thm.thm list -> int -> Thm.thm -> Thm.thm Seq.seq
114 BasicIsaFTerm.FcTerm ->
115 match Seq.seq) -> Thm.thm -> int -> Thm.thm -> Thm.thm Seq.seq
117 val meth : bool * Thm.thm list -> Proof.context -> Proof.method
118 val setup : (Theory.theory -> Theory.theory) list
121 functor EQSubstTacFUN (structure EqRuleData : EQRULE_DATA)
125 (* a type abriviation for match infomration *)
127 ((Term.indexname * Term.typ) list (* type instantiations *)
128 * (Term.indexname * Term.term) list) (* term instantiations *)
129 * (string * Term.typ) list (* fake named type abs env *)
130 * (string * Term.typ) list (* type abs env *)
131 * Term.term (* outer term *)
135 type trace_subst_errT = int (* subgoal *)
136 * Thm.thm (* thm with all goals *)
137 * (Thm.cterm list (* certified free var placeholders for vars *)
138 * Thm.thm) (* trivial thm of goal concl *)
139 (* possible matches/unifiers *)
141 * (((Term.indexname * Term.typ) list (* type instantiations *)
142 * (Term.indexname * Term.term) list ) (* term instantiations *)
143 * (string * Term.typ) list (* Type abs env *)
144 * Term.term) (* outer term *);
146 val trace_subst_err = (ref NONE : trace_subst_errT option ref);
147 val trace_subst_search = ref false;
148 exception trace_subst_exp of trace_subst_errT;
151 (* also defined in /HOL/Tools/inductive_codegen.ML,
152 maybe move this to seq.ML ? *)
154 fun s :-> f = Seq.flat (Seq.map f s);
156 (* search from top, left to right, then down *)
157 fun search_tlr_all_f f ft =
160 let val t' = (IsaFTerm.focus_of_fcterm ft)
162 if !trace_subst_search then
163 (writeln ("Examining: " ^ (TermLib.string_of_term t'));
164 TermLib.writeterm t'; ())
168 (_ $ _) => Seq.append(maux (IsaFTerm.focus_left ft),
170 maux (IsaFTerm.focus_right ft)))
171 | (Abs _) => Seq.append(f ft, maux (IsaFTerm.focus_abs ft))
175 (* search from top, left to right, then down *)
176 fun search_tlr_valid_f f ft =
180 val hereseq = if IsaFTerm.valid_match_start ft then f ft else Seq.empty
182 (case (IsaFTerm.focus_of_fcterm ft) of
183 (_ $ _) => Seq.append(maux (IsaFTerm.focus_left ft),
185 maux (IsaFTerm.focus_right ft)))
186 | (Abs _) => Seq.append(hereseq, maux (IsaFTerm.focus_abs ft))
191 (* search all unifications *)
192 fun searchf_tlr_unify_all sgn maxidx lhs =
193 IsaFTerm.find_fcterm_matches
195 (IsaFTerm.clean_unify_ft sgn maxidx lhs);
197 (* search only for 'valid' unifiers (non abs subterms and non vars) *)
198 fun searchf_tlr_unify_valid sgn maxidx lhs =
199 IsaFTerm.find_fcterm_matches
201 (IsaFTerm.clean_unify_ft sgn maxidx lhs);
204 (* apply a substitution in the conclusion of the theorem th *)
205 (* cfvs are certified free var placeholders for goal params *)
206 (* conclthm is a theorem of for just the conclusion *)
207 (* m is instantiation/match information *)
208 (* rule is the equation for substitution *)
209 fun apply_subst_in_concl i th (cfvs, conclthm) rule m =
210 (RWInst.rw m rule conclthm)
211 |> IsaND.unfix_frees cfvs
212 |> RWInst.beta_eta_contract_tac
213 |> (fn r => Tactic.rtac r i th);
217 |> (fn r => Thm.bicompose false (false, r, Thm.nprems_of r) i th)
221 (* substitute within the conclusion of goal i of gth, using a meta
222 equation rule. Note that we assume rule has var indicies zero'd *)
223 fun prep_concl_subst searchf i gth =
225 val th = Thm.incr_indexes 1 gth;
226 val tgt_term = Thm.prop_of th;
228 val sgn = Thm.sign_of_thm th;
229 val ctermify = Thm.cterm_of sgn;
230 val trivify = Thm.trivial o ctermify;
232 val (fixedbody, fvs) = IsaND.fix_alls_term i tgt_term;
233 val cfvs = rev (map ctermify fvs);
235 val conclterm = Logic.strip_imp_concl fixedbody;
236 val conclthm = trivify conclterm;
237 val maxidx = Term.maxidx_of_term conclterm;
240 (fn lhs => searchf sgn maxidx lhs
241 ((IsaFTerm.focus_right
242 o IsaFTerm.focus_left
243 o IsaFTerm.fcterm_of_term
244 o Thm.prop_of) conclthm)))
248 (* substitute using an object or meta level equality *)
249 fun eqsubst_tac' searchf instepthm i th =
251 val (cvfsconclthm, findmatchf) =
252 prep_concl_subst searchf i th;
255 Seq.map Drule.zero_var_indexes
256 (Seq.of_list (EqRuleData.prep_meta_eq instepthm));
258 fun rewrite_with_thm r =
259 let val (lhs,_) = Logic.dest_equals (Thm.concl_of r);
261 :-> (apply_subst_in_concl i th cvfsconclthm r) end;
263 in (stepthms :-> rewrite_with_thm) end;
266 (* substitute using one of the given theorems *)
267 fun eqsubst_tac instepthms i th =
268 if Thm.nprems_of th < i then Seq.empty else
269 (Seq.of_list instepthms)
270 :-> (fn r => eqsubst_tac' searchf_tlr_unify_valid r i th);
272 (* inthms are the given arguments in Isar, and treated as eqstep with
273 the first one, then the second etc *)
274 fun eqsubst_meth inthms =
277 HEADGOAL ( Method.insert_tac facts THEN' eqsubst_tac inthms ));
280 fun apply_subst_in_asm i th (cfvs, j, nprems, pth) rule m =
281 (RWInst.rw m rule pth)
282 |> Thm.permute_prems 0 ~1
283 |> IsaND.unfix_frees cfvs
284 |> RWInst.beta_eta_contract_tac
285 |> (fn r => Tactic.dtac r i th);
288 ? should I be using bicompose what if we match more than one
289 assumption, even after instantiation ? (back will work, but it would
290 be nice to avoid the redudent search)
293 |> Thm.lift_rule (th, i)
294 |> (fn r => Thm.bicompose false (false, r, Thm.nprems_of r - nprems) i th)
299 (* prepare to substitute within the j'th premise of subgoal i of gth,
300 using a meta-level equation. Note that we assume rule has var indicies
301 zero'd. Note that we also assume that premt is the j'th premice of
302 subgoal i of gth. Note the repetition of work done for each
303 assumption, i.e. this can be made more efficient for search over
304 multiple assumptions. *)
305 fun prep_subst_in_asm searchf i gth j =
307 val th = Thm.incr_indexes 1 gth;
308 val tgt_term = Thm.prop_of th;
310 val sgn = Thm.sign_of_thm th;
311 val ctermify = Thm.cterm_of sgn;
312 val trivify = Thm.trivial o ctermify;
314 val (fixedbody, fvs) = IsaND.fix_alls_term i tgt_term;
315 val cfvs = rev (map ctermify fvs);
317 val asmt = Library.nth_elem(j - 1,(Logic.strip_imp_prems fixedbody));
318 val asm_nprems = length (Logic.strip_imp_prems asmt);
320 val pth = trivify asmt;
321 val maxidx = Term.maxidx_of_term asmt;
324 ((cfvs, j, asm_nprems, pth),
325 (fn lhs => (searchf sgn maxidx lhs
326 ((IsaFTerm.focus_right
327 o IsaFTerm.fcterm_of_term
328 o Thm.prop_of) pth))))
331 (* prepare subst in every possible assumption *)
332 fun prep_subst_in_asms searchf i gth =
334 (prep_subst_in_asm searchf i gth)
335 (Seq.of_list (IsaPLib.mk_num_list
336 (length (Logic.prems_of_goal (Thm.prop_of gth) i))));
339 (* substitute in an assumption using an object or meta level equality *)
340 fun eqsubst_asm_tac' searchf instepthm i th =
342 val asmpreps = prep_subst_in_asms searchf i th;
344 Seq.map Drule.zero_var_indexes
345 (Seq.of_list (EqRuleData.prep_meta_eq instepthm))
347 fun rewrite_with_thm (asminfo, findmatchf) r =
348 let val (lhs,_) = Logic.dest_equals (Thm.concl_of r);
350 :-> (apply_subst_in_asm i th asminfo r) end;
352 (asmpreps :-> (fn a => stepthms :-> rewrite_with_thm a))
355 (* substitute using one of the given theorems *)
356 fun eqsubst_asm_tac instepthms i th =
357 if Thm.nprems_of th < i then Seq.empty else
358 (Seq.of_list instepthms)
359 :-> (fn r => eqsubst_asm_tac' searchf_tlr_unify_valid r i th);
361 (* inthms are the given arguments in Isar, and treated as eqstep with
362 the first one, then the second etc *)
363 fun eqsubst_asm_meth inthms =
366 HEADGOAL (Method.insert_tac facts THEN' eqsubst_asm_tac inthms ));
368 (* combination method that takes a flag (true indicates that subst
369 should be done to an assumption, false = apply to the conclusion of
370 the goal) as well as the theorems to use *)
371 fun meth (asmflag, inthms) ctxt =
372 if asmflag then eqsubst_asm_meth inthms else eqsubst_meth inthms;
374 (* syntax for options, given "(asm)" will give back true, without
377 (Args.parens (Args.$$$ "asm") >> (K true)) ||
378 (Scan.succeed false);
380 (* method syntax, first take options, then theorems *)
381 fun meth_syntax meth src ctxt =
382 meth (snd (Method.syntax ((Scan.lift options_syntax)
383 -- Attrib.local_thms) src ctxt))
386 (* setup function for adding method to theory. *)
388 [Method.add_method ("subst", meth_syntax meth, "Substiution with an equation. Use \"(asm)\" option to substitute in an assumption.")];