99 |
99 |
100 val default_congs = |
100 val default_congs = |
101 map (fn c => c RS eq_reflection) [@{thm "cong"}, @{thm "ext"}] |
101 map (fn c => c RS eq_reflection) [@{thm "cong"}, @{thm "ext"}] |
102 |
102 |
103 (* Called on the INSTANTIATED branches of the congruence rule *) |
103 (* Called on the INSTANTIATED branches of the congruence rule *) |
104 fun mk_branch ctx t = |
104 fun mk_branch ctxt t = |
105 let |
105 let |
106 val ((fixes, impl), ctx') = Function_Lib.focus_term t ctx |
106 val ((fixes, impl), ctxt') = Function_Lib.focus_term t ctxt |
107 val (assms, concl) = Logic.strip_horn impl |
107 val (assms, concl) = Logic.strip_horn impl |
108 in |
108 in |
109 (ctx', fixes, assms, rhs_of concl) |
109 (ctxt', fixes, assms, rhs_of concl) |
110 end |
110 end |
111 |
111 |
112 fun find_cong_rule ctx fvar h ((r,dep)::rs) t = |
112 fun find_cong_rule ctxt fvar h ((r,dep)::rs) t = |
113 (let |
113 (let |
114 val thy = Proof_Context.theory_of ctx |
114 val thy = Proof_Context.theory_of ctxt |
115 |
115 |
116 val tt' = Logic.mk_equals (Pattern.rewrite_term thy [(Free fvar, h)] [] t, t) |
116 val tt' = Logic.mk_equals (Pattern.rewrite_term thy [(Free fvar, h)] [] t, t) |
117 val (c, subs) = (concl_of r, prems_of r) |
117 val (c, subs) = (concl_of r, prems_of r) |
118 |
118 |
119 val subst = Pattern.match (Proof_Context.theory_of ctx) (c, tt') (Vartab.empty, Vartab.empty) |
119 val subst = |
120 val branches = map (mk_branch ctx o Envir.beta_norm o Envir.subst_term subst) subs |
120 Pattern.match (Proof_Context.theory_of ctxt) (c, tt') (Vartab.empty, Vartab.empty) |
121 val inst = map (fn v => |
121 val branches = map (mk_branch ctxt o Envir.beta_norm o Envir.subst_term subst) subs |
122 (cterm_of thy (Var v), cterm_of thy (Envir.subst_term subst (Var v)))) (Term.add_vars c []) |
122 val inst = map (fn v => |
123 in |
123 (cterm_of thy (Var v), cterm_of thy (Envir.subst_term subst (Var v)))) |
124 (cterm_instantiate inst r, dep, branches) |
124 (Term.add_vars c []) |
125 end |
125 in |
126 handle Pattern.MATCH => find_cong_rule ctx fvar h rs t) |
126 (cterm_instantiate inst r, dep, branches) |
|
127 end |
|
128 handle Pattern.MATCH => find_cong_rule ctxt fvar h rs t) |
127 | find_cong_rule _ _ _ [] _ = raise General.Fail "No cong rule found!" |
129 | find_cong_rule _ _ _ [] _ = raise General.Fail "No cong rule found!" |
128 |
130 |
129 |
131 |
130 fun mk_tree fvar h ctxt t = |
132 fun mk_tree fvar h ctxt t = |
131 let |
133 let |
135 val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs) |
137 val congs_deps = map (fn c => (c, cong_deps c)) (congs @ default_congs) |
136 |
138 |
137 fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE |
139 fun matchcall (a $ b) = if a = Free fvar then SOME b else NONE |
138 | matchcall _ = NONE |
140 | matchcall _ = NONE |
139 |
141 |
140 fun mk_tree' ctx t = |
142 fun mk_tree' ctxt t = |
141 case matchcall t of |
143 case matchcall t of |
142 SOME arg => RCall (t, mk_tree' ctx arg) |
144 SOME arg => RCall (t, mk_tree' ctxt arg) |
143 | NONE => |
145 | NONE => |
144 if not (exists_subterm (fn Free v => v = fvar | _ => false) t) then Leaf t |
146 if not (exists_subterm (fn Free v => v = fvar | _ => false) t) then Leaf t |
145 else |
147 else |
146 let |
148 let |
147 val (r, dep, branches) = find_cong_rule ctx fvar h congs_deps t |
149 val (r, dep, branches) = find_cong_rule ctxt fvar h congs_deps t |
148 fun subtree (ctx', fixes, assumes, st) = |
150 fun subtree (ctxt', fixes, assumes, st) = |
149 ((fixes, |
151 ((fixes, |
150 map (Thm.assume o cterm_of (Proof_Context.theory_of ctx)) assumes), |
152 map (Thm.assume o cterm_of (Proof_Context.theory_of ctxt)) assumes), |
151 mk_tree' ctx' st) |
153 mk_tree' ctxt' st) |
152 in |
154 in |
153 Cong (r, dep, map subtree branches) |
155 Cong (r, dep, map subtree branches) |
154 end |
156 end |
155 in |
157 in |
156 mk_tree' ctxt t |
158 mk_tree' ctxt t |
214 (Inttab.fold (cons o snd) T [], x) |
216 (Inttab.fold (cons o snd) T [], x) |
215 end |
217 end |
216 |
218 |
217 fun traverse_tree rcOp tr = |
219 fun traverse_tree rcOp tr = |
218 let |
220 let |
219 fun traverse_help ctx (Leaf _) _ x = ([], x) |
221 fun traverse_help ctxt (Leaf _) _ x = ([], x) |
220 | traverse_help ctx (RCall (t, st)) u x = |
222 | traverse_help ctxt (RCall (t, st)) u x = |
221 rcOp ctx t u (traverse_help ctx st u x) |
223 rcOp ctxt t u (traverse_help ctxt st u x) |
222 | traverse_help ctx (Cong (_, deps, branches)) u x = |
224 | traverse_help ctxt (Cong (_, deps, branches)) u x = |
223 let |
|
224 fun sub_step lu i x = |
|
225 let |
225 let |
226 val (ctx', subtree) = nth branches i |
226 fun sub_step lu i x = |
227 val used = fold_rev (append o lu) (Int_Graph.imm_succs deps i) u |
227 let |
228 val (subs, x') = traverse_help (compose ctx ctx') subtree used x |
228 val (ctxt', subtree) = nth branches i |
229 val exported_subs = map (apfst (compose ctx')) subs (* FIXME: Right order of composition? *) |
229 val used = fold_rev (append o lu) (Int_Graph.imm_succs deps i) u |
|
230 val (subs, x') = traverse_help (compose ctxt ctxt') subtree used x |
|
231 val exported_subs = map (apfst (compose ctxt')) subs (* FIXME: Right order of composition? *) |
|
232 in |
|
233 (exported_subs, x') |
|
234 end |
230 in |
235 in |
231 (exported_subs, x') |
236 fold_deps deps sub_step x |
|
237 |> apfst flat |
232 end |
238 end |
233 in |
|
234 fold_deps deps sub_step x |
|
235 |> apfst flat |
|
236 end |
|
237 in |
239 in |
238 snd o traverse_help ([], []) tr [] |
240 snd o traverse_help ([], []) tr [] |
239 end |
241 end |
240 |
242 |
241 fun rewrite_by_tree thy h ih x tr = |
243 fun rewrite_by_tree thy h ih x tr = |