120 |
120 |
121 fun cong_name (Const (a, _)) = SOME (true, a) |
121 fun cong_name (Const (a, _)) = SOME (true, a) |
122 | cong_name (Free (a, _)) = SOME (false, a) |
122 | cong_name (Free (a, _)) = SOME (false, a) |
123 | cong_name _ = NONE; |
123 | cong_name _ = NONE; |
124 |
124 |
|
125 structure Congtab = Table(type key = cong_name val ord = prod_ord bool_ord fast_string_ord); |
|
126 |
125 |
127 |
126 (* rewrite rules *) |
128 (* rewrite rules *) |
127 |
129 |
128 type rrule = |
130 type rrule = |
129 {thm: thm, (*the rewrite rule*) |
131 {thm: thm, (*the rewrite rule*) |
248 datatype simpset = |
250 datatype simpset = |
249 Simpset of |
251 Simpset of |
250 {rules: rrule Net.net, |
252 {rules: rrule Net.net, |
251 prems: thm list, |
253 prems: thm list, |
252 depth: int * bool Unsynchronized.ref} * |
254 depth: int * bool Unsynchronized.ref} * |
253 {congs: (cong_name * thm) list * cong_name list, |
255 {congs: thm Congtab.table * cong_name list, |
254 procs: proc Net.net, |
256 procs: proc Net.net, |
255 mk_rews: |
257 mk_rews: |
256 {mk: Proof.context -> thm -> thm list, |
258 {mk: Proof.context -> thm -> thm list, |
257 mk_cong: Proof.context -> thm -> thm, |
259 mk_cong: Proof.context -> thm -> thm, |
258 mk_sym: Proof.context -> thm -> thm option, |
260 mk_sym: Proof.context -> thm -> thm option, |
283 |> map (fn {name, thm, ...} => (name, thm)), |
285 |> map (fn {name, thm, ...} => (name, thm)), |
284 procs = Net.entries procs |
286 procs = Net.entries procs |
285 |> map (fn Proc {name, lhs, stamp, ...} => ((name, lhs), stamp)) |
287 |> map (fn Proc {name, lhs, stamp, ...} => ((name, lhs), stamp)) |
286 |> partition_eq (eq_snd op =) |
288 |> partition_eq (eq_snd op =) |
287 |> map (fn ps => (fst (fst (hd ps)), map (snd o fst) ps)), |
289 |> map (fn ps => (fst (fst (hd ps)), map (snd o fst) ps)), |
288 congs = #1 congs, |
290 congs = congs |> fst |> Congtab.dest, |
289 weak_congs = #2 congs, |
291 weak_congs = congs |> snd, |
290 loopers = map fst loop_tacs, |
292 loopers = map fst loop_tacs, |
291 unsafe_solvers = map solver_name (#1 solvers), |
293 unsafe_solvers = map solver_name (#1 solvers), |
292 safe_solvers = map solver_name (#2 solvers)}; |
294 safe_solvers = map solver_name (#2 solvers)}; |
293 |
295 |
294 |
296 |
295 (* empty *) |
297 (* empty *) |
296 |
298 |
297 fun init_ss depth mk_rews term_ord subgoal_tac solvers = |
299 fun init_ss depth mk_rews term_ord subgoal_tac solvers = |
298 make_simpset ((Net.empty, [], depth), |
300 make_simpset ((Net.empty, [], depth), |
299 (([], []), Net.empty, mk_rews, term_ord, subgoal_tac, [], solvers)); |
301 ((Congtab.empty, []), Net.empty, mk_rews, term_ord, subgoal_tac, [], solvers)); |
300 |
302 |
301 fun default_mk_sym _ th = SOME (th RS Drule.symmetric_thm); |
303 fun default_mk_sym _ th = SOME (th RS Drule.symmetric_thm); |
302 |
304 |
303 val empty_ss = |
305 val empty_ss = |
304 init_ss (0, Unsynchronized.ref false) |
306 init_ss (0, Unsynchronized.ref false) |
324 loop_tacs = loop_tacs2, solvers = (unsafe_solvers2, solvers2)}) = ss2; |
326 loop_tacs = loop_tacs2, solvers = (unsafe_solvers2, solvers2)}) = ss2; |
325 |
327 |
326 val rules' = Net.merge eq_rrule (rules1, rules2); |
328 val rules' = Net.merge eq_rrule (rules1, rules2); |
327 val prems' = Thm.merge_thms (prems1, prems2); |
329 val prems' = Thm.merge_thms (prems1, prems2); |
328 val depth' = if #1 depth1 < #1 depth2 then depth2 else depth1; |
330 val depth' = if #1 depth1 < #1 depth2 then depth2 else depth1; |
329 val congs' = AList.merge (op =) (K true) (congs1, congs2); |
331 val congs' = Congtab.merge (K true) (congs1, congs2); |
330 val weak' = merge (op =) (weak1, weak2); |
332 val weak' = merge (op =) (weak1, weak2); |
331 val procs' = Net.merge eq_proc (procs1, procs2); |
333 val procs' = Net.merge eq_proc (procs1, procs2); |
332 val loop_tacs' = AList.merge (op =) (K true) (loop_tacs1, loop_tacs2); |
334 val loop_tacs' = AList.merge (op =) (K true) (loop_tacs1, loop_tacs2); |
333 val unsafe_solvers' = merge eq_solver (unsafe_solvers1, unsafe_solvers2); |
335 val unsafe_solvers' = merge eq_solver (unsafe_solvers1, unsafe_solvers2); |
334 val solvers' = merge eq_solver (solvers1, solvers2); |
336 val solvers' = merge eq_solver (solvers1, solvers2); |
676 handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); |
678 handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); |
677 (*val lhs = Envir.eta_contract lhs;*) |
679 (*val lhs = Envir.eta_contract lhs;*) |
678 val a = the (cong_name (head_of lhs)) handle Option.Option => |
680 val a = the (cong_name (head_of lhs)) handle Option.Option => |
679 raise SIMPLIFIER ("Congruence must start with a constant or free variable", [thm]); |
681 raise SIMPLIFIER ("Congruence must start with a constant or free variable", [thm]); |
680 val (xs, weak) = congs; |
682 val (xs, weak) = congs; |
681 val xs' = AList.update (op =) (a, Thm.trim_context thm) xs; |
683 val xs' = Congtab.update (a, Thm.trim_context thm) xs; |
682 val weak' = if is_full_cong thm then weak else a :: weak; |
684 val weak' = if is_full_cong thm then weak else a :: weak; |
683 in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); |
685 in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); |
684 |
686 |
685 fun del_eqcong thm ctxt = ctxt |> map_simpset2 |
687 fun del_eqcong thm ctxt = ctxt |> map_simpset2 |
686 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => |
688 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) => |
689 handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); |
691 handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]); |
690 (*val lhs = Envir.eta_contract lhs;*) |
692 (*val lhs = Envir.eta_contract lhs;*) |
691 val a = the (cong_name (head_of lhs)) handle Option.Option => |
693 val a = the (cong_name (head_of lhs)) handle Option.Option => |
692 raise SIMPLIFIER ("Congruence must start with a constant", [thm]); |
694 raise SIMPLIFIER ("Congruence must start with a constant", [thm]); |
693 val (xs, _) = congs; |
695 val (xs, _) = congs; |
694 val xs' = filter_out (fn (x : cong_name, _) => x = a) xs; |
696 val xs' = Congtab.delete_safe a xs; |
695 val weak' = xs' |> map_filter (fn (a, th) => if is_full_cong th then NONE else SOME a); |
697 val weak' = Congtab.fold (fn (a, th) => if is_full_cong th then I else insert (op =) a) xs' []; |
696 in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); |
698 in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end); |
697 |
699 |
698 fun add_cong thm ctxt = add_eqcong (mk_cong ctxt thm) ctxt; |
700 fun add_cong thm ctxt = add_eqcong (mk_cong ctxt thm) ctxt; |
699 fun del_cong thm ctxt = del_eqcong (mk_cong ctxt thm) ctxt; |
701 fun del_cong thm ctxt = del_eqcong (mk_cong ctxt thm) ctxt; |
700 |
702 |
1176 end; |
1178 end; |
1177 val (h, ts) = strip_comb t; |
1179 val (h, ts) = strip_comb t; |
1178 in |
1180 in |
1179 (case cong_name h of |
1181 (case cong_name h of |
1180 SOME a => |
1182 SOME a => |
1181 (case AList.lookup (op =) (fst congs) a of |
1183 (case Congtab.lookup (fst congs) a of |
1182 NONE => appc () |
1184 NONE => appc () |
1183 | SOME cong => |
1185 | SOME cong => |
1184 (*post processing: some partial applications h t1 ... tj, j <= length ts, |
1186 (*post processing: some partial applications h t1 ... tj, j <= length ts, |
1185 may be a redex. Example: map (\<lambda>x. x) = (\<lambda>xs. xs) wrt map_cong*) |
1187 may be a redex. Example: map (\<lambda>x. x) = (\<lambda>xs. xs) wrt map_cong*) |
1186 (let |
1188 (let |