2 (c) Walther Neuper 2000
8 val calculate_: Proof.context -> string * Eval_Def.eval_fn -> term -> (term * (string * thm)) option
9 val eval__true: Proof.context -> int -> term list -> Subst.T -> Rule_Set.T -> term list * bool
10 val eval_prog_expr: Proof.context -> Rule_Set.T -> term -> term
11 val eval_true_: Proof.context -> Rule_Set.T -> term -> bool
12 val eval_true: Proof.context -> term list -> Rule_Set.T -> bool
13 val rew_sub: Proof.context -> int -> Subst.T -> Rewrite_Ord.function
14 -> Rule_Set.T -> bool -> TermC.path -> term -> term -> term * term list * TermC.path * bool
15 val rewrite_: Proof.context -> Rewrite_Ord.function -> Rule_Set.T -> bool -> thm ->
16 term -> (term * term list) option
17 val rewrite_inst_: Proof.context -> Rewrite_Ord.function -> Rule_Set.T -> bool
18 -> Subst.T -> thm -> term -> (term * term list) option
19 val rewrite_set_: Proof.context -> bool -> Rule_Set.T -> term -> (term * term list) option
20 val rewrite_set_inst_: Proof.context -> bool -> Subst.T -> Rule_Set.T -> term -> (term * term list) option
21 val rewrite_terms_: Proof.context -> Rewrite_Ord.function -> Rule_Set.T -> term list
22 -> term -> (term * term list) option
25 val rewrite__: Proof.context -> int -> Subst.T -> Rewrite_Ord.function ->
26 Rule_Set.T -> bool -> thm -> term -> (term * term list) option
27 val rewrite__set_: Proof.context -> int -> bool -> Subst.T -> Rule_Set.T -> term -> (term * term list) option
28 val app_rev: Proof.context -> int -> Rule_Set.T -> term -> term * term list * bool
29 val app_sub: Proof.context -> int -> Rule_Set.T -> term -> term * term list * bool
30 val trace1: Proof.context -> int -> string -> unit
31 val trace_eq1 : Proof.context -> int -> string -> Rule_Def.rule_set -> term -> unit;
32 val trace_eq2 : Proof.context -> int -> string -> term -> term -> unit;
33 val trace_in1 : Proof.context -> int -> string -> string -> unit;
34 val trace_in2 : Proof.context -> int -> string -> term -> unit;
35 val trace_in3 : Proof.context -> int -> string -> (term * 'a) option -> unit;
36 val trace_in4 : Proof.context -> int -> string -> term list -> term list -> unit;
37 val trace_in5 : Proof.context -> int -> string -> term list -> unit;
41 (* must be global for re-use in other structs *)
42 val rewrite_trace = Attrib.setup_config_bool \<^binding>\<open>rewrite_trace\<close> (K false);
43 (* no of rewrites exceeding this int -> NO_REWRITE *)
44 val rewrite_limit = Attrib.setup_config_int \<^binding>\<open>rewrite_limit\<close> (K 100);
47 structure Rewrite(**): REWRITE(**) =
53 (* depth of recursion in traces of the rewriter, if trace_on = true *)
54 val rewrite_trace_depth = Attrib.setup_config_int \<^binding>\<open>rewrite_trace_depth\<close> (K 99999);
56 fun trace ctxt i str =
57 if Config.get ctxt rewrite_trace andalso i < Config.get ctxt rewrite_trace_depth
58 then tracing (idt "#" i ^ str) else ()
59 fun trace_eq1 ctxt i str rrls t =
60 trace ctxt i (" " ^ str ^ ": " ^ Rule_Set.id rrls ^ " on: " ^ UnparseC.term_in_ctxt ctxt t)
61 fun trace_eq2 ctxt i str t t' =
62 trace ctxt i (" " ^ str ^ ": \"" ^
63 UnparseC.term_in_ctxt ctxt t ^ "\" > \"" ^ UnparseC.term_in_ctxt ctxt t' ^ "\"");
64 fun trace1 ctxt i str =
65 if Config.get ctxt rewrite_trace andalso i < Config.get ctxt rewrite_trace_depth
66 then tracing (idt "#" (i + 1) ^ str) else ()
67 fun trace_in1 ctxt i str thmid =
68 trace1 ctxt i (" " ^ str ^ ": \"" ^ thmid ^ "\"")
69 fun trace_in2 ctxt i str t =
70 trace1 ctxt i (" " ^ str ^ ": \"" ^ UnparseC.term_in_ctxt ctxt t ^ "\"");
71 fun trace_in3 ctxt i str pairopt =
72 trace1 ctxt i (" " ^ str ^ ": " ^ UnparseC.term_in_ctxt ctxt ((fst o the) pairopt));
73 fun trace_in4 ctxt i str ts ts' =
74 if Config.get ctxt rewrite_trace andalso i < Config.get ctxt rewrite_trace_depth andalso ts <> []
75 then tracing (idt "#" (i + 1) ^ " " ^ str ^ ": " ^ UnparseC.terms_in_ctxt ctxt ts ^
76 " stored: " ^ UnparseC.terms_in_ctxt ctxt ts')
78 fun trace_in5 ctxt i str p' =
79 if Config.get ctxt rewrite_trace andalso i < Config.get ctxt rewrite_trace_depth
80 then tracing (idt "#" (i + 1) ^ " " ^ str ^ ": " ^ UnparseC.terms_in_ctxt ctxt p')
82 fun msg call ctxt op_ thmC t =
84 "Eval.get_pair for " ^ quote op_ ^ " \<longrightarrow> SOME (_, " ^ quote (ThmC.string_of_thm thmC) ^ ")\n" ^
85 "but rewrite__ on " ^ quote (UnparseC.term_in_ctxt ctxt t) ^ " \<longrightarrow> NONE";
87 fun rewrite__ ctxt i bdv tless rls put_asm thm ct =
89 val (t', asms, _(*lrd*), rew) = rew_sub ctxt i bdv tless rls put_asm ([(*root of the term*)]: TermC.path)
90 (TermC.inst_bdv bdv (Eval.norm (Thm.prop_of thm))) ct
91 in if rew then SOME (t', distinct op = asms) else NONE end
92 (* one rewrite (possibly conditional, ordered) EXOR exn EXOR go into subterms *)
93 and rew_sub ctxt i bdv tless rls put_asm lrd r t =
95 val (lhs, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r
96 val r' = (Envir.subst_term (Pattern.match (Proof_Context.theory_of ctxt)
97 (lhs, t) (Vartab.empty, Vartab.empty)) r)
98 handle Pattern.MATCH => raise NO_REWRITE
99 val p' = map HOLogic.dest_Trueprop ((fst o Logic.strip_prems) (Logic.count_prems r', [], r'))
100 val t' = (snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o Logic.strip_imp_concl) r'
101 val _ = trace_in2 ctxt i "eval asms" r';
102 val (t'', p'') = (*conditional rewriting*)
103 let val (simpl_p', nofalse) = eval__true ctxt (i + 1) p' bdv rls
106 then (trace_in4 ctxt i "asms accepted" p' simpl_p'; (t', simpl_p'))(*uncond.rew.from above*)
107 else (trace_in5 ctxt i "asms false" p'; raise NO_REWRITE) (* don't go into subtm.of cond*)
110 if TermC.perm lhs rhs andalso not (tless bdv (t', t)) (*ordered rewriting*)
111 then (trace_eq2 ctxt i "not >" t t'; raise NO_REWRITE)
112 else (t'', p'', [], true)
114 ) handle NO_REWRITE =>
116 Const(s, T) => (Const(s, T), [], lrd, false)
117 | Free(s, T) => (Free(s, T), [], lrd, false)
118 | Var(n, T) => (Var(n, T), [], lrd, false)
119 | Bound i => (Bound i, [], lrd, false)
121 let val (t', asms, _ (*lrd*), rew) = rew_sub ctxt i bdv tless rls put_asm (lrd @ [TermC.D]) r body
122 in (Abs(s, T, t'), asms, [], rew) end
124 let val (t2', asm2, lrd, rew2) = rew_sub ctxt i bdv tless rls put_asm (lrd @ [TermC.R]) r t2
126 if rew2 then (t1 $ t2', asm2, lrd, true)
128 let val (t1', asm1, lrd, rew1) = rew_sub ctxt i bdv tless rls put_asm (lrd @ [TermC.L]) r t1
129 in if rew1 then (t1' $ t2, asm1, lrd, true) else (t1 $ t2,[], lrd, false) end
131 and eval__true ctxt i asms bdv rls = (* rewrite asumptions until one evaluates to false*)
132 if asms = [@{term True}] orelse asms = [] then ([], true)
133 else (* this allows to check Rrls with prepat = ([@{term True}], pat) *)
134 if asms = [@{term False}] then ([], false)
137 fun chk indets [] = (indets, true) (*return asms<>True until false*)
138 | chk indets (a :: asms) =
139 (case rewrite__set_ ctxt (i + 1) false bdv rls a of
140 NONE => (chk (indets @ [a]) asms)
142 if t = @{term True} then (chk (indets @ a') asms)
143 else if t = @{term False} then ([], false)
144 (*asm false .. thm not applied ^^^; continue until False vvv*)
145 else chk (indets @ [t] @ a') asms);
147 and rewrite__set_ ctxt (*1*)_ _ _ Rule_Set.Empty t = (* rewrite with a rule set*)
148 raise ERROR ("rewrite__set_ called with 'Erls' for '" ^ UnparseC.term_in_ctxt ctxt t ^ "'")
149 | rewrite__set_ (*2*)ctxt i _ _ (rrls as Rule_Set.Rrls _) t = (* rewrite with a 'reverse rule set'*)
151 val _= trace_eq1 ctxt i "rls" rrls t;
152 val (t', asm, rew) = app_rev ctxt (i + 1) rrls t
153 in if rew then SOME (t', distinct op = asm) else NONE end
154 | rewrite__set_ (*3*)ctxt i put_asm bdv rls ct = (* Rls, Seq containing Thms or Eval, Cal1 *)
156 (* attention with cp to test/..: unbound ctxt, i, bdv, rls; TODO1803? pull out to rewrite__*)
157 datatype switch = Appl | Noap;
158 fun rew_once (*1*)_ asm ct Noap [] = (ct, asm) (* ?TODO unify with Prog_Expr.rew_once? *)
159 | rew_once (*2*)ruls asm ct Appl [] =
160 (case rls of Rule_Def.Repeat _ => rew_once ruls asm ct Noap ruls
161 | Rule_Set.Sequence _ => (ct, asm)
162 | rls => raise ERROR ("rew_once not appl. to \"" ^ Rule_Set.id rls ^ "\""))
163 | rew_once (*3*)ruls asm ct apno (rul :: thms) =
165 Rule.Thm (thmid, thm) =>
166 (trace_in1 ctxt i "try thm" thmid;
167 case rewrite__ ctxt (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)
168 ((#erls o Rule_Set.rep) rls) put_asm thm ct of
169 NONE => rew_once ruls asm ct apno thms
170 | SOME (ct', asm') =>
171 (trace_in2 ctxt i "rewrites to" ct';
172 rew_once ruls (union (op =) asm asm') ct' Appl (rul :: thms)))
173 (* once again try the same rule, e.g. associativity against "()"*)
174 | Rule.Eval (cc as (op_, _)) =>
175 let val _ = trace_in1 ctxt i "try calc" op_;
176 in case Eval.adhoc_thm (Proof_Context.theory_of ctxt) cc ct of
177 NONE => rew_once ruls asm ct apno thms
180 val pairopt = rewrite__ ctxt (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)
181 ((#erls o Rule_Set.rep) rls) put_asm thm' ct;
182 val _ = if pairopt <> NONE then () else raise ERROR (msg "rew_once" ctxt op_ thm' ct)
183 val _ = trace_in3 ctxt i "calc. to" pairopt;
184 in rew_once ruls asm ((fst o the) pairopt) Appl (rul :: thms) end
186 | Rule.Cal1 (cc as (op_, _)) =>
187 let val _ = trace_in1 ctxt i "try cal1" op_;
188 in case Eval.adhoc_thm1_ (Proof_Context.theory_of ctxt) cc ct of
192 val pairopt = rewrite__ ctxt (i + 1) bdv ((snd o #rew_ord o Rule_Set.rep) rls)
193 ((#erls o Rule_Set.rep) rls) put_asm thm' ct;
194 val _ = if pairopt <> NONE then () else raise ERROR ("rewrite_set_, rewrite_ \"" ^
195 ThmC.string_of_thm thm' ^ "\" " ^ UnparseC.term_in_ctxt ctxt ct ^ " = NONE")
196 val _ = trace_in3 ctxt i "cal1. to" pairopt;
200 (case rewrite__set_ ctxt (i + 1) put_asm bdv rls' ct of
201 SOME (t', asm') => rew_once ruls (union (op =) asm asm') t' Appl thms
202 | NONE => rew_once ruls asm ct apno thms)
203 | r => raise ERROR ("rew_once not appl. to \"" ^ Rule.to_string r ^ "\"");
204 val ruls = (#rules o Rule_Set.rep) rls;
205 val _ = trace_eq1 ctxt i "rls" rls ct
206 val (ct', asm') = rew_once ruls [] ct Noap ruls;
207 in if ct = ct' then NONE else SOME (ct', distinct op = asm') end
208 (*--vvv and app_sub are type correct-----------------------------------------------------------*)
209 and app_rev ctxt i rrls t = (* apply an Rrls; if not applicable proceed with subterms*)
210 let (* check a (precond, pattern) of a rev-set; stops with 1st true *)
211 fun chk_prepat _ _ [] _ = true
212 | chk_prepat ctxt erls prepat t =
214 fun chk (pres, pat) =
216 val subst: Type.tyenv * Envir.tenv =
217 Pattern.match (Proof_Context.theory_of ctxt) (pat, t) (Vartab.empty, Vartab.empty)
219 snd (eval__true ctxt (i + 1) (map (Envir.subst_term subst) pres) [] erls)
220 end) handle Pattern.MATCH => false
221 fun scan_ _ [] = false
222 | scan_ f (pp :: pps) =
223 if f pp then true else scan_ f pps;
224 in scan_ chk prepat end;
225 (* apply the normal_form of a rev-set *)
226 fun app_rev' ctxt (Rule_Set.Rrls {erls, prepat, scr = Rule.Rfuns {normal_form, ...}, ...}) t =
227 if chk_prepat ctxt erls prepat t then normal_form t else NONE
228 | app_rev' _ r _ = raise ERROR ("app_rev' not appl. to \"" ^ Rule_Set.id r ^ "\"");
229 val opt = app_rev' ctxt rrls t
232 SOME (t', asm) => (t', asm, true)
233 | NONE => app_sub ctxt i rrls t
235 and app_sub ctxt i rrls t = (* apply an Rrls to subterms*)
237 Const (s, T) => (Const(s, T), [], false)
238 | Free (s, T) => (Free(s, T), [], false)
239 | Var (n, T) => (Var(n, T), [], false)
240 | Bound i => (Bound i, [], false)
241 | Abs (s, T, body) =>
242 let val (t', asm, rew) = app_rev ctxt i rrls body
243 in (Abs(s, T, t'), asm, rew) end
245 let val (t2', asm2, rew2) = app_rev ctxt i rrls t2
247 if rew2 then (t1 $ t2', asm2, true)
249 let val (t1', asm1, rew1) = app_rev ctxt i rrls t1
250 in if rew1 then (t1' $ t2, asm1, true)
251 else (t1 $ t2, [], false)
255 (* rewriting without argument [] for rew_ord *)
256 fun eval_true thy terms rls = (snd o (eval__true thy 1 terms [])) rls;
258 (* rewriting without internal arguments 1, [] *)
259 fun rewrite_ thy rew_ord erls bool thm term = rewrite__ thy 1 [] rew_ord erls bool thm term;
260 fun rewrite_set_ thy bool rls term = rewrite__set_ thy 1 bool [] rls term;
262 (* variants of rewrite; TODO del. put_asm *)
263 fun rewrite_inst_ thy rew_ord rls put_asm subst thm ct =
264 rewrite__ thy 1 subst rew_ord rls put_asm thm ct;
265 fun rewrite_set_inst_ thy put_asm subst rls ct = rewrite__set_ thy 1 put_asm subst rls ct;
267 (* given a list of equalities (lhs = rhs) and a term,
268 replace all occurrences of lhs in the term with rhs;
269 thus the order or equalities matters: put variables in lhs first. *)
270 fun rewrite_terms_ thy ord erls equs t =
272 fun rew_ (t', asm') [] _ = (t', asm')
273 | rew_ (t', asm') (rules as r::rs) t =
275 val (t'', asm'', _(*lrd*), rew) = rew_sub thy 1 [] ord erls false [] (HOLogic.Trueprop $ r) t
278 then rew_ (t'', asm' @ asm'') rules t''
279 else rew_ (t', asm') rs t'
281 val (t'', asm'') = rew_ (TermC.empty, []) equs t
282 in if t'' = TermC.empty then NONE else SOME (t'', asm'')
285 (* search ct for adjacent numerals and calculate them by operator isa_fn *)
286 fun calculate_ ctxt (isa_fn as (id, eval_fn)) t =
287 case Eval.adhoc_thm (Proof_Context.theory_of ctxt) isa_fn t of
289 | SOME (thmID, thm) =>
290 (let val rew = case rewrite_ ctxt Rewrite_Ord.function_empty Rule_Set.empty false thm t of
292 | NONE => raise ERROR (msg "calculate_" ctxt id thm t)
293 in SOME (rew, (thmID, thm)) end)
294 handle NO_REWRITE => raise ERROR ("calculate_: " ^ thmID ^ " does not rewrite");
296 fun eval_prog_expr thy srls t =
297 let val rew = rewrite_set_ thy false srls t;
298 in case rew of SOME (res,_) => res | NONE => t end;
300 fun eval_true_ _ _ (Const (\<^const_name>\<open>True\<close>,_)) = true
301 | eval_true_ thy rls t =
302 case rewrite_set_ thy false rls t of
303 SOME (Const (\<^const_name>\<open>True\<close>,_),_) => true