6 Extract common terms in balanced expressions: |
6 Extract common terms in balanced expressions: |
7 |
7 |
8 i + u + j ~~ i' + u + j' == u + (i + j) ~~ u + (i' + j') |
8 i + u + j ~~ i' + u + j' == u + (i + j) ~~ u + (i' + j') |
9 i + u ~~ u == u + i ~~ u + 0 |
9 i + u ~~ u == u + i ~~ u + 0 |
10 |
10 |
11 where ~~ is an appropriate balancing operation (e.g. =, <=, <, -) and 0 is a |
11 where ~~ is an appropriate balancing operation (e.g. =, <=, <, -) and 0 is a |
12 suitable identity for +. |
12 suitable identity for +. |
13 |
13 |
14 This massaged formula is then simplified in a user-specified way. |
14 This massaged formula is then simplified in a user-specified way. |
15 *) |
15 *) |
16 |
16 |
21 val dest_sum: term -> term list |
21 val dest_sum: term -> term list |
22 val mk_bal: term * term -> term |
22 val mk_bal: term * term -> term |
23 val dest_bal: term -> term * term |
23 val dest_bal: term -> term * term |
24 val find_first: term -> term list -> term list |
24 val find_first: term -> term list -> term list |
25 (*proof tools*) |
25 (*proof tools*) |
26 val prove_conv: tactic list -> Proof.context -> |
26 val prove_conv: tactic list -> Proof.context -> thm list -> term * term -> thm option |
27 thm list -> string list -> term * term -> thm option |
|
28 val norm_tac: simpset -> tactic (*proves the result*) |
27 val norm_tac: simpset -> tactic (*proves the result*) |
29 val simplify_meta_eq: simpset -> thm -> thm (*simplifies the result*) |
28 val simplify_meta_eq: simpset -> thm -> thm (*simplifies the result*) |
30 end; |
29 end; |
31 |
30 |
32 |
31 |
33 functor ExtractCommonTermFun(Data: EXTRACT_COMMON_TERM_DATA): |
32 functor ExtractCommonTermFun(Data: EXTRACT_COMMON_TERM_DATA): |
34 sig |
33 sig |
35 val proc: simpset -> term -> thm option |
34 val proc: simpset -> term -> thm option |
36 end |
35 end |
37 = |
36 = |
38 struct |
37 struct |
39 |
38 |
40 (*a left-to-right scan of terms1, seeking a term u that is also in terms2*) |
39 (*a left-to-right scan of terms1, seeking a term u that is also in terms2*) |
41 fun find_common (terms1,terms2) = |
40 fun find_common (terms1,terms2) = |
42 let val tab2 = fold (Termtab.update o rpair ()) terms2 Termtab.empty |
41 let val tab2 = fold (Termtab.update o rpair ()) terms2 Termtab.empty |
43 fun seek [] = raise TERM("find_common", []) |
42 fun seek [] = raise TERM("find_common", []) |
44 | seek (u::terms) = |
43 | seek (u::terms) = |
45 if Termtab.defined tab2 u then u |
44 if Termtab.defined tab2 u then u |
46 else seek terms |
45 else seek terms |
47 in seek terms1 end; |
46 in seek terms1 end; |
48 |
47 |
49 (*the simplification procedure*) |
48 (*the simplification procedure*) |
50 fun proc ss t = |
49 fun proc ss t = |
51 let |
50 let |
52 val ctxt = Simplifier.the_context ss; |
51 val ctxt = Simplifier.the_context ss; |
53 val hyps = prems_of_ss ss; |
52 val prems = prems_of_ss ss; |
54 (*first freeze any Vars in the term to prevent flex-flex problems*) |
53 val ([t'], ctxt') = Variable.import_terms true [t] ctxt |
55 val (t', xs) = Term.adhoc_freeze_vars t; |
54 val export = singleton (Variable.export ctxt' ctxt) |
56 val (t1,t2) = Data.dest_bal t' |
55 |
57 val terms1 = Data.dest_sum t1 |
56 val (t1,t2) = Data.dest_bal t' |
58 and terms2 = Data.dest_sum t2 |
57 val terms1 = Data.dest_sum t1 |
59 val u = find_common (terms1,terms2) |
58 and terms2 = Data.dest_sum t2 |
60 val terms1' = Data.find_first u terms1 |
59 |
61 and terms2' = Data.find_first u terms2 |
60 val u = find_common (terms1,terms2) |
62 and T = Term.fastype_of u |
61 val terms1' = Data.find_first u terms1 |
63 val reshape = |
62 and terms2' = Data.find_first u terms2 |
64 Data.prove_conv [Data.norm_tac ss] ctxt hyps xs |
63 and T = Term.fastype_of u |
65 (t', |
64 |
66 Data.mk_bal (Data.mk_sum T (u::terms1'), |
65 val reshape = |
67 Data.mk_sum T (u::terms2'))) |
66 Data.prove_conv [Data.norm_tac ss] ctxt prems |
|
67 (t', Data.mk_bal (Data.mk_sum T (u::terms1'), Data.mk_sum T (u::terms2'))) |
68 in |
68 in |
69 Option.map (Data.simplify_meta_eq ss) reshape |
69 Option.map (export o Data.simplify_meta_eq ss) reshape |
70 end |
70 end |
|
71 (* FIXME avoid handling of generic exceptions *) |
71 handle TERM _ => NONE |
72 handle TERM _ => NONE |
72 | TYPE _ => NONE; (*Typically (if thy doesn't include Numeral) |
73 | TYPE _ => NONE; (*Typically (if thy doesn't include Numeral) |
73 Undeclared type constructor "Numeral.bin"*) |
74 Undeclared type constructor "Numeral.bin"*) |
74 |
75 |
75 end; |
76 end; |