|
1 (* Title: Provers/Arith/cancel.ML |
|
2 Author: Mathias Fleury, MPII |
|
3 Copyright 2017 |
|
4 |
|
5 Based on: |
|
6 |
|
7 Title: Provers/Arith/cancel_numerals.ML |
|
8 Author: Lawrence C Paulson, Cambridge University Computer Laboratory |
|
9 Copyright 2000 University of Cambridge |
|
10 |
|
11 |
|
12 This simproc allows handling of types with constructors (e.g., add_mset for multisets) and iteration |
|
13 of the addition (e.g., repeat_mset for multisets). |
|
14 |
|
15 Beware that this simproc should not compete with any more specialised especially: |
|
16 - nat: the handling for Suc is more complicated than what can be done here |
|
17 - int: some normalisation is done (after the cancelation) and linarith relies on these. |
|
18 |
|
19 Instead of "*", we have "iterate_add". |
|
20 |
|
21 |
|
22 To quote Provers/Arith/cancel_numerals.ML: |
|
23 |
|
24 Cancel common coefficients in balanced expressions: |
|
25 |
|
26 i + #m*u + j ~~ i' + #m'*u + j' == #(m-m')*u + i + j ~~ i' + j' |
|
27 |
|
28 where ~~ is an appropriate balancing operation (e.g. =, <=, <, -). |
|
29 |
|
30 It works by (a) massaging both sides to bring the selected term to the front: |
|
31 |
|
32 #m*u + (i + j) ~~ #m'*u + (i' + j') |
|
33 |
|
34 (b) then using bal_add1 or bal_add2 to reach |
|
35 |
|
36 #(m-m')*u + i + j ~~ i' + j' (if m'<=m) |
|
37 |
|
38 or |
|
39 |
|
40 i + j ~~ #(m'-m)*u + i' + j' (otherwise) |
|
41 *) |
|
42 |
|
43 signature CANCEL = |
|
44 sig |
|
45 val proc: Proof.context -> cterm -> thm option |
|
46 end; |
|
47 |
|
48 functor Cancel_Fun(Data: CANCEL_NUMERALS_DATA): CANCEL = |
|
49 struct |
|
50 |
|
51 structure Cancel_Numerals_Fun = CancelNumeralsFun(open Data) |
|
52 exception SORT_NOT_GENERAL_ENOUGH of string * typ * term |
|
53 (*the simplification procedure*) |
|
54 fun proc ctxt ct = |
|
55 let |
|
56 val t = Thm.term_of ct |
|
57 val ([t'], ctxt') = Variable.import_terms true [t] ctxt |
|
58 val pre_simplified_ct = Simplifier.full_rewrite (clear_simpset ctxt addsimps |
|
59 Named_Theorems.get ctxt @{named_theorems cancelation_simproc_pre} addsimprocs |
|
60 [@{simproc NO_MATCH}]) (Thm.cterm_of ctxt t'); |
|
61 val t' = Thm.term_of (Thm.rhs_of pre_simplified_ct) |
|
62 val export = singleton (Variable.export ctxt' ctxt) |
|
63 |
|
64 val (t1,_) = Data.dest_bal t' |
|
65 val sort_not_general_enough = ((fastype_of t1) = @{typ nat}) orelse |
|
66 Sorts.of_sort (Sign.classes_of (Proof_Context.theory_of ctxt)) |
|
67 (fastype_of t1, @{sort "comm_ring_1"}) |
|
68 val _ = |
|
69 if sort_not_general_enough |
|
70 then raise SORT_NOT_GENERAL_ENOUGH("type too precise, another simproc should do the job", |
|
71 fastype_of t1, t1) |
|
72 else () |
|
73 val canceled_thm = Cancel_Numerals_Fun.proc ctxt (Thm.rhs_of pre_simplified_ct) |
|
74 fun add_pre_simplification thm = @{thm Pure.transitive} OF [pre_simplified_ct, thm] |
|
75 fun add_post_simplification thm = |
|
76 (let val post_simplified_ct = Simplifier.full_rewrite (clear_simpset ctxt addsimps |
|
77 Named_Theorems.get ctxt @{named_theorems cancelation_simproc_post} addsimprocs |
|
78 [@{simproc NO_MATCH}]) |
|
79 (Thm.rhs_of thm) |
|
80 in @{thm Pure.transitive} OF [thm, post_simplified_ct] end) |
|
81 in |
|
82 Option.map (export o add_post_simplification o add_pre_simplification) canceled_thm |
|
83 end |
|
84 (* FIXME avoid handling of generic exceptions *) |
|
85 handle TERM _ => NONE |
|
86 | TYPE _ => NONE |
|
87 | SORT_NOT_GENERAL_ENOUGH _ => NONE |
|
88 |
|
89 end; |