| author | haftmann | 
| Wed, 20 May 2009 15:35:13 +0200 | |
| changeset 31213 | 800787c3210f | 
| parent 31068 | f591144b0f17 | 
| child 31368 | 763f4b0fd579 | 
| permissions | -rw-r--r-- | 
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 1 | (* Author: Lawrence C Paulson, Cambridge University Computer Laboratory | 
| 23164 | 2 | |
| 3 | Simprocs for nat numerals. | |
| 4 | *) | |
| 5 | ||
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 6 | signature NAT_NUMERAL_SIMPROCS = | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 7 | sig | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 8 | val combine_numerals: simproc | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 9 | val cancel_numerals: simproc list | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 10 | val cancel_factors: simproc list | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 11 | val cancel_numeral_factors: simproc list | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 12 | end; | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 13 | |
| 23164 | 14 | structure Nat_Numeral_Simprocs = | 
| 15 | struct | |
| 16 | ||
| 17 | (*Maps n to #n for n = 0, 1, 2*) | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 18 | val numeral_syms = [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym, @{thm numeral_2_eq_2} RS sym];
 | 
| 23164 | 19 | val numeral_sym_ss = HOL_ss addsimps numeral_syms; | 
| 20 | ||
| 21 | fun rename_numerals th = | |
| 22 | simplify numeral_sym_ss (Thm.transfer (the_context ()) th); | |
| 23 | ||
| 24 | (*Utilities*) | |
| 25 | ||
| 26 | fun mk_number n = HOLogic.number_of_const HOLogic.natT $ HOLogic.mk_numeral n; | |
| 24630 
351a308ab58d
simplified type int (eliminated IntInf.int, integer);
 wenzelm parents: 
24431diff
changeset | 27 | fun dest_number t = Int.max (0, snd (HOLogic.dest_number t)); | 
| 23164 | 28 | |
| 29 | fun find_first_numeral past (t::terms) = | |
| 30 | ((dest_number t, t, rev past @ terms) | |
| 31 | handle TERM _ => find_first_numeral (t::past) terms) | |
| 32 |   | find_first_numeral past [] = raise TERM("find_first_numeral", []);
 | |
| 33 | ||
| 34 | val zero = mk_number 0; | |
| 35 | val mk_plus = HOLogic.mk_binop @{const_name HOL.plus};
 | |
| 36 | ||
| 37 | (*Thus mk_sum[t] yields t+0; longer sums don't have a trailing zero*) | |
| 38 | fun mk_sum [] = zero | |
| 39 | | mk_sum [t,u] = mk_plus (t, u) | |
| 40 | | mk_sum (t :: ts) = mk_plus (t, mk_sum ts); | |
| 41 | ||
| 42 | (*this version ALWAYS includes a trailing zero*) | |
| 43 | fun long_mk_sum [] = HOLogic.zero | |
| 44 | | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts); | |
| 45 | ||
| 46 | val dest_plus = HOLogic.dest_bin @{const_name HOL.plus} HOLogic.natT;
 | |
| 47 | ||
| 48 | ||
| 49 | (** Other simproc items **) | |
| 50 | ||
| 51 | val bin_simps = | |
| 23471 | 52 |      [@{thm nat_numeral_0_eq_0} RS sym, @{thm nat_numeral_1_eq_1} RS sym,
 | 
| 53 |       @{thm add_nat_number_of}, @{thm nat_number_of_add_left}, 
 | |
| 54 |       @{thm diff_nat_number_of}, @{thm le_number_of_eq_not_less},
 | |
| 55 |       @{thm mult_nat_number_of}, @{thm nat_number_of_mult_left}, 
 | |
| 56 |       @{thm less_nat_number_of}, 
 | |
| 57 |       @{thm Let_number_of}, @{thm nat_number_of}] @
 | |
| 29039 | 58 |      @{thms arith_simps} @ @{thms rel_simps} @ @{thms neg_simps};
 | 
| 23164 | 59 | |
| 60 | ||
| 61 | (*** CancelNumerals simprocs ***) | |
| 62 | ||
| 63 | val one = mk_number 1; | |
| 64 | val mk_times = HOLogic.mk_binop @{const_name HOL.times};
 | |
| 65 | ||
| 66 | fun mk_prod [] = one | |
| 67 | | mk_prod [t] = t | |
| 68 | | mk_prod (t :: ts) = if t = one then mk_prod ts | |
| 69 | else mk_times (t, mk_prod ts); | |
| 70 | ||
| 71 | val dest_times = HOLogic.dest_bin @{const_name HOL.times} HOLogic.natT;
 | |
| 72 | ||
| 73 | fun dest_prod t = | |
| 74 | let val (t,u) = dest_times t | |
| 75 | in dest_prod t @ dest_prod u end | |
| 76 | handle TERM _ => [t]; | |
| 77 | ||
| 78 | (*DON'T do the obvious simplifications; that would create special cases*) | |
| 79 | fun mk_coeff (k,t) = mk_times (mk_number k, t); | |
| 80 | ||
| 81 | (*Express t as a product of (possibly) a numeral with other factors, sorted*) | |
| 82 | fun dest_coeff t = | |
| 29269 
5c25a2012975
moved term order operations to structure TermOrd (cf. Pure/term_ord.ML);
 wenzelm parents: 
29039diff
changeset | 83 | let val ts = sort TermOrd.term_ord (dest_prod t) | 
| 23164 | 84 | val (n, _, ts') = find_first_numeral [] ts | 
| 85 | handle TERM _ => (1, one, ts) | |
| 86 | in (n, mk_prod ts') end; | |
| 87 | ||
| 88 | (*Find first coefficient-term THAT MATCHES u*) | |
| 89 | fun find_first_coeff past u [] = raise TERM("find_first_coeff", [])
 | |
| 90 | | find_first_coeff past u (t::terms) = | |
| 91 | let val (n,u') = dest_coeff t | |
| 92 | in if u aconv u' then (n, rev past @ terms) | |
| 93 | else find_first_coeff (t::past) u terms | |
| 94 | end | |
| 95 | handle TERM _ => find_first_coeff (t::past) u terms; | |
| 96 | ||
| 97 | ||
| 98 | (*Split up a sum into the list of its constituent terms, on the way removing any | |
| 99 | Sucs and counting them.*) | |
| 100 | fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts))
 | |
| 101 | | dest_Suc_sum (t, (k,ts)) = | |
| 102 | let val (t1,t2) = dest_plus t | |
| 103 | in dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts))) end | |
| 104 | handle TERM _ => (k, t::ts); | |
| 105 | ||
| 106 | (*Code for testing whether numerals are already used in the goal*) | |
| 25919 
8b1c0d434824
joined theories IntDef, Numeral, IntArith to theory Int
 haftmann parents: 
25481diff
changeset | 107 | fun is_numeral (Const(@{const_name Int.number_of}, _) $ w) = true
 | 
| 23164 | 108 | | is_numeral _ = false; | 
| 109 | ||
| 110 | fun prod_has_numeral t = exists is_numeral (dest_prod t); | |
| 111 | ||
| 112 | (*The Sucs found in the term are converted to a binary numeral. If relaxed is false, | |
| 113 | an exception is raised unless the original expression contains at least one | |
| 114 | numeral in a coefficient position. This prevents nat_combine_numerals from | |
| 115 | introducing numerals to goals.*) | |
| 116 | fun dest_Sucs_sum relaxed t = | |
| 117 | let val (k,ts) = dest_Suc_sum (t,(0,[])) | |
| 118 | in | |
| 119 | if relaxed orelse exists prod_has_numeral ts then | |
| 120 | if k=0 then ts | |
| 24630 
351a308ab58d
simplified type int (eliminated IntInf.int, integer);
 wenzelm parents: 
24431diff
changeset | 121 | else mk_number k :: ts | 
| 23164 | 122 |      else raise TERM("Nat_Numeral_Simprocs.dest_Sucs_sum", [t])
 | 
| 123 | end; | |
| 124 | ||
| 125 | ||
| 126 | (*Simplify 1*n and n*1 to n*) | |
| 23881 | 127 | val add_0s  = map rename_numerals [@{thm add_0}, @{thm add_0_right}];
 | 
| 23164 | 128 | val mult_1s = map rename_numerals [@{thm nat_mult_1}, @{thm nat_mult_1_right}];
 | 
| 129 | ||
| 130 | (*Final simplification: cancel + and *; replace Numeral0 by 0 and Numeral1 by 1*) | |
| 131 | ||
| 132 | (*And these help the simproc return False when appropriate, which helps | |
| 133 | the arith prover.*) | |
| 23881 | 134 | val contra_rules = [@{thm add_Suc}, @{thm add_Suc_right}, @{thm Zero_not_Suc},
 | 
| 135 |   @{thm Suc_not_Zero}, @{thm le_0_eq}];
 | |
| 23164 | 136 | |
| 137 | val simplify_meta_eq = | |
| 30518 | 138 | Arith_Data.simplify_meta_eq | 
| 23471 | 139 |         ([@{thm nat_numeral_0_eq_0}, @{thm numeral_1_eq_Suc_0}, @{thm add_0}, @{thm add_0_right},
 | 
| 140 |           @{thm mult_0}, @{thm mult_0_right}, @{thm mult_1}, @{thm mult_1_right}] @ contra_rules);
 | |
| 23164 | 141 | |
| 142 | ||
| 143 | (*** Applying CancelNumeralsFun ***) | |
| 144 | ||
| 145 | structure CancelNumeralsCommon = | |
| 146 | struct | |
| 147 | val mk_sum = (fn T:typ => mk_sum) | |
| 148 | val dest_sum = dest_Sucs_sum true | |
| 149 | val mk_coeff = mk_coeff | |
| 150 | val dest_coeff = dest_coeff | |
| 151 | val find_first_coeff = find_first_coeff [] | |
| 30518 | 152 | val trans_tac = K Arith_Data.trans_tac | 
| 23164 | 153 | |
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 154 | val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ | 
| 23881 | 155 |     [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
 | 
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 156 |   val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
 | 
| 23164 | 157 | fun norm_tac ss = | 
| 158 | ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1)) | |
| 159 | THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2)) | |
| 160 | ||
| 161 | val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps; | |
| 162 | fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss)); | |
| 163 | val simplify_meta_eq = simplify_meta_eq | |
| 164 | end; | |
| 165 | ||
| 166 | ||
| 167 | structure EqCancelNumerals = CancelNumeralsFun | |
| 168 | (open CancelNumeralsCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 169 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 170 | val mk_bal = HOLogic.mk_eq | 
| 171 | val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT | |
| 23471 | 172 |   val bal_add1 = @{thm nat_eq_add_iff1} RS trans
 | 
| 173 |   val bal_add2 = @{thm nat_eq_add_iff2} RS trans
 | |
| 23164 | 174 | ); | 
| 175 | ||
| 176 | structure LessCancelNumerals = CancelNumeralsFun | |
| 177 | (open CancelNumeralsCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 178 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 179 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
 | 
| 180 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
 | |
| 23471 | 181 |   val bal_add1 = @{thm nat_less_add_iff1} RS trans
 | 
| 182 |   val bal_add2 = @{thm nat_less_add_iff2} RS trans
 | |
| 23164 | 183 | ); | 
| 184 | ||
| 185 | structure LeCancelNumerals = CancelNumeralsFun | |
| 186 | (open CancelNumeralsCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 187 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 188 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
 | 
| 189 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
 | |
| 23471 | 190 |   val bal_add1 = @{thm nat_le_add_iff1} RS trans
 | 
| 191 |   val bal_add2 = @{thm nat_le_add_iff2} RS trans
 | |
| 23164 | 192 | ); | 
| 193 | ||
| 194 | structure DiffCancelNumerals = CancelNumeralsFun | |
| 195 | (open CancelNumeralsCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 196 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 197 |   val mk_bal   = HOLogic.mk_binop @{const_name HOL.minus}
 | 
| 198 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.minus} HOLogic.natT
 | |
| 23471 | 199 |   val bal_add1 = @{thm nat_diff_add_eq1} RS trans
 | 
| 200 |   val bal_add2 = @{thm nat_diff_add_eq2} RS trans
 | |
| 23164 | 201 | ); | 
| 202 | ||
| 203 | ||
| 204 | val cancel_numerals = | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 205 | map Arith_Data.prep_simproc | 
| 23164 | 206 |    [("nateq_cancel_numerals",
 | 
| 207 | ["(l::nat) + m = n", "(l::nat) = m + n", | |
| 208 | "(l::nat) * m = n", "(l::nat) = m * n", | |
| 209 | "Suc m = n", "m = Suc n"], | |
| 210 | K EqCancelNumerals.proc), | |
| 211 |     ("natless_cancel_numerals",
 | |
| 212 | ["(l::nat) + m < n", "(l::nat) < m + n", | |
| 213 | "(l::nat) * m < n", "(l::nat) < m * n", | |
| 214 | "Suc m < n", "m < Suc n"], | |
| 215 | K LessCancelNumerals.proc), | |
| 216 |     ("natle_cancel_numerals",
 | |
| 217 | ["(l::nat) + m <= n", "(l::nat) <= m + n", | |
| 218 | "(l::nat) * m <= n", "(l::nat) <= m * n", | |
| 219 | "Suc m <= n", "m <= Suc n"], | |
| 220 | K LeCancelNumerals.proc), | |
| 221 |     ("natdiff_cancel_numerals",
 | |
| 222 | ["((l::nat) + m) - n", "(l::nat) - (m + n)", | |
| 223 | "(l::nat) * m - n", "(l::nat) - m * n", | |
| 224 | "Suc m - n", "m - Suc n"], | |
| 225 | K DiffCancelNumerals.proc)]; | |
| 226 | ||
| 227 | ||
| 228 | (*** Applying CombineNumeralsFun ***) | |
| 229 | ||
| 230 | structure CombineNumeralsData = | |
| 231 | struct | |
| 24630 
351a308ab58d
simplified type int (eliminated IntInf.int, integer);
 wenzelm parents: 
24431diff
changeset | 232 | type coeff = int | 
| 
351a308ab58d
simplified type int (eliminated IntInf.int, integer);
 wenzelm parents: 
24431diff
changeset | 233 | val iszero = (fn x => x = 0) | 
| 
351a308ab58d
simplified type int (eliminated IntInf.int, integer);
 wenzelm parents: 
24431diff
changeset | 234 | val add = op + | 
| 23164 | 235 | val mk_sum = (fn T:typ => long_mk_sum) (*to work for 2*x + 3*x *) | 
| 236 | val dest_sum = dest_Sucs_sum false | |
| 237 | val mk_coeff = mk_coeff | |
| 238 | val dest_coeff = dest_coeff | |
| 23471 | 239 |   val left_distrib      = @{thm left_add_mult_distrib} RS trans
 | 
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 240 | val prove_conv = Arith_Data.prove_conv_nohyps | 
| 30518 | 241 | val trans_tac = K Arith_Data.trans_tac | 
| 23164 | 242 | |
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 243 |   val norm_ss1 = Numeral_Simprocs.num_ss addsimps numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1}] @ @{thms add_ac}
 | 
| 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 244 |   val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
 | 
| 23164 | 245 | fun norm_tac ss = | 
| 246 | ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1)) | |
| 247 | THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2)) | |
| 248 | ||
| 249 | val numeral_simp_ss = HOL_ss addsimps add_0s @ bin_simps; | |
| 250 | fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss)) | |
| 251 | val simplify_meta_eq = simplify_meta_eq | |
| 252 | end; | |
| 253 | ||
| 254 | structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData); | |
| 255 | ||
| 256 | val combine_numerals = | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 257 |   Arith_Data.prep_simproc ("nat_combine_numerals", ["(i::nat) + j", "Suc (i + j)"], K CombineNumerals.proc);
 | 
| 23164 | 258 | |
| 259 | ||
| 260 | (*** Applying CancelNumeralFactorFun ***) | |
| 261 | ||
| 262 | structure CancelNumeralFactorCommon = | |
| 263 | struct | |
| 264 | val mk_coeff = mk_coeff | |
| 265 | val dest_coeff = dest_coeff | |
| 30518 | 266 | val trans_tac = K Arith_Data.trans_tac | 
| 23164 | 267 | |
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 268 | val norm_ss1 = Numeral_Simprocs.num_ss addsimps | 
| 23881 | 269 |     numeral_syms @ add_0s @ mult_1s @ [@{thm Suc_eq_add_numeral_1_left}] @ @{thms add_ac}
 | 
| 31068 
f591144b0f17
modules numeral_simprocs, nat_numeral_simprocs; proper structures for numeral simprocs
 haftmann parents: 
30685diff
changeset | 270 |   val norm_ss2 = Numeral_Simprocs.num_ss addsimps bin_simps @ @{thms add_ac} @ @{thms mult_ac}
 | 
| 23164 | 271 | fun norm_tac ss = | 
| 272 | ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss1)) | |
| 273 | THEN ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss2)) | |
| 274 | ||
| 275 | val numeral_simp_ss = HOL_ss addsimps bin_simps | |
| 276 | fun numeral_simp_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss numeral_simp_ss)) | |
| 277 | val simplify_meta_eq = simplify_meta_eq | |
| 278 | end | |
| 279 | ||
| 280 | structure DivCancelNumeralFactor = CancelNumeralFactorFun | |
| 281 | (open CancelNumeralFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 282 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 283 |   val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
 | 
| 284 |   val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
 | |
| 23471 | 285 |   val cancel = @{thm nat_mult_div_cancel1} RS trans
 | 
| 23164 | 286 | val neg_exchanges = false | 
| 287 | ) | |
| 288 | ||
| 23969 | 289 | structure DvdCancelNumeralFactor = CancelNumeralFactorFun | 
| 290 | (open CancelNumeralFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 291 | val prove_conv = Arith_Data.prove_conv | 
| 27651 
16a26996c30e
moved op dvd to theory Ring_and_Field; generalized a couple of lemmas
 haftmann parents: 
25919diff
changeset | 292 |   val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
 | 
| 
16a26996c30e
moved op dvd to theory Ring_and_Field; generalized a couple of lemmas
 haftmann parents: 
25919diff
changeset | 293 |   val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
 | 
| 23969 | 294 |   val cancel = @{thm nat_mult_dvd_cancel1} RS trans
 | 
| 295 | val neg_exchanges = false | |
| 296 | ) | |
| 297 | ||
| 23164 | 298 | structure EqCancelNumeralFactor = CancelNumeralFactorFun | 
| 299 | (open CancelNumeralFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 300 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 301 | val mk_bal = HOLogic.mk_eq | 
| 302 | val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT | |
| 23471 | 303 |   val cancel = @{thm nat_mult_eq_cancel1} RS trans
 | 
| 23164 | 304 | val neg_exchanges = false | 
| 305 | ) | |
| 306 | ||
| 307 | structure LessCancelNumeralFactor = CancelNumeralFactorFun | |
| 308 | (open CancelNumeralFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 309 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 310 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
 | 
| 311 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
 | |
| 23471 | 312 |   val cancel = @{thm nat_mult_less_cancel1} RS trans
 | 
| 23164 | 313 | val neg_exchanges = true | 
| 314 | ) | |
| 315 | ||
| 316 | structure LeCancelNumeralFactor = CancelNumeralFactorFun | |
| 317 | (open CancelNumeralFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 318 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 319 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
 | 
| 320 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
 | |
| 23471 | 321 |   val cancel = @{thm nat_mult_le_cancel1} RS trans
 | 
| 23164 | 322 | val neg_exchanges = true | 
| 323 | ) | |
| 324 | ||
| 325 | val cancel_numeral_factors = | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 326 | map Arith_Data.prep_simproc | 
| 23164 | 327 |    [("nateq_cancel_numeral_factors",
 | 
| 328 | ["(l::nat) * m = n", "(l::nat) = m * n"], | |
| 329 | K EqCancelNumeralFactor.proc), | |
| 330 |     ("natless_cancel_numeral_factors",
 | |
| 331 | ["(l::nat) * m < n", "(l::nat) < m * n"], | |
| 332 | K LessCancelNumeralFactor.proc), | |
| 333 |     ("natle_cancel_numeral_factors",
 | |
| 334 | ["(l::nat) * m <= n", "(l::nat) <= m * n"], | |
| 335 | K LeCancelNumeralFactor.proc), | |
| 336 |     ("natdiv_cancel_numeral_factors",
 | |
| 337 | ["((l::nat) * m) div n", "(l::nat) div (m * n)"], | |
| 23969 | 338 | K DivCancelNumeralFactor.proc), | 
| 339 |     ("natdvd_cancel_numeral_factors",
 | |
| 340 | ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"], | |
| 341 | K DvdCancelNumeralFactor.proc)]; | |
| 23164 | 342 | |
| 343 | ||
| 344 | ||
| 345 | (*** Applying ExtractCommonTermFun ***) | |
| 346 | ||
| 347 | (*this version ALWAYS includes a trailing one*) | |
| 348 | fun long_mk_prod [] = one | |
| 349 | | long_mk_prod (t :: ts) = mk_times (t, mk_prod ts); | |
| 350 | ||
| 351 | (*Find first term that matches u*) | |
| 352 | fun find_first_t past u []         = raise TERM("find_first_t", [])
 | |
| 353 | | find_first_t past u (t::terms) = | |
| 354 | if u aconv t then (rev past @ terms) | |
| 355 | else find_first_t (t::past) u terms | |
| 356 | handle TERM _ => find_first_t (t::past) u terms; | |
| 357 | ||
| 358 | (** Final simplification for the CancelFactor simprocs **) | |
| 30518 | 359 | val simplify_one = Arith_Data.simplify_meta_eq | 
| 23164 | 360 |   [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_1}, @{thm numeral_1_eq_Suc_0}];
 | 
| 361 | ||
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 362 | fun cancel_simplify_meta_eq ss cancel_th th = | 
| 23164 | 363 | simplify_one ss (([th, cancel_th]) MRS trans); | 
| 364 | ||
| 365 | structure CancelFactorCommon = | |
| 366 | struct | |
| 367 | val mk_sum = (fn T:typ => long_mk_prod) | |
| 368 | val dest_sum = dest_prod | |
| 369 | val mk_coeff = mk_coeff | |
| 370 | val dest_coeff = dest_coeff | |
| 371 | val find_first = find_first_t [] | |
| 30518 | 372 | val trans_tac = K Arith_Data.trans_tac | 
| 23881 | 373 |   val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac}
 | 
| 23164 | 374 | fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss)) | 
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 375 | val simplify_meta_eq = cancel_simplify_meta_eq | 
| 23164 | 376 | end; | 
| 377 | ||
| 378 | structure EqCancelFactor = ExtractCommonTermFun | |
| 379 | (open CancelFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 380 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 381 | val mk_bal = HOLogic.mk_eq | 
| 382 | val dest_bal = HOLogic.dest_bin "op =" HOLogic.natT | |
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 383 |   val simp_conv = K(K (SOME @{thm nat_mult_eq_cancel_disj}))
 | 
| 23164 | 384 | ); | 
| 385 | ||
| 386 | structure LessCancelFactor = ExtractCommonTermFun | |
| 387 | (open CancelFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 388 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 389 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less}
 | 
| 390 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less} HOLogic.natT
 | |
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 391 |   val simp_conv = K(K (SOME @{thm nat_mult_less_cancel_disj}))
 | 
| 23164 | 392 | ); | 
| 393 | ||
| 394 | structure LeCancelFactor = ExtractCommonTermFun | |
| 395 | (open CancelFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 396 | val prove_conv = Arith_Data.prove_conv | 
| 23881 | 397 |   val mk_bal   = HOLogic.mk_binrel @{const_name HOL.less_eq}
 | 
| 398 |   val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} HOLogic.natT
 | |
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 399 |   val simp_conv = K(K (SOME @{thm nat_mult_le_cancel_disj}))
 | 
| 23164 | 400 | ); | 
| 401 | ||
| 402 | structure DivideCancelFactor = ExtractCommonTermFun | |
| 403 | (open CancelFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 404 | val prove_conv = Arith_Data.prove_conv | 
| 23164 | 405 |   val mk_bal   = HOLogic.mk_binop @{const_name Divides.div}
 | 
| 406 |   val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.natT
 | |
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 407 |   val simp_conv = K(K (SOME @{thm nat_mult_div_cancel_disj}))
 | 
| 23164 | 408 | ); | 
| 409 | ||
| 23969 | 410 | structure DvdCancelFactor = ExtractCommonTermFun | 
| 411 | (open CancelFactorCommon | |
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 412 | val prove_conv = Arith_Data.prove_conv | 
| 27651 
16a26996c30e
moved op dvd to theory Ring_and_Field; generalized a couple of lemmas
 haftmann parents: 
25919diff
changeset | 413 |   val mk_bal   = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd}
 | 
| 
16a26996c30e
moved op dvd to theory Ring_and_Field; generalized a couple of lemmas
 haftmann parents: 
25919diff
changeset | 414 |   val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} HOLogic.natT
 | 
| 30649 
57753e0ec1d4
1. New cancellation simprocs for common factors in inequations
 nipkow parents: 
30518diff
changeset | 415 |   val simp_conv = K(K (SOME @{thm nat_mult_dvd_cancel_disj}))
 | 
| 23969 | 416 | ); | 
| 417 | ||
| 23164 | 418 | val cancel_factor = | 
| 30496 
7cdcc9dd95cb
vague cleanup in arith proof tools setup: deleted dead code, more proper structures, clearer arrangement
 haftmann parents: 
29269diff
changeset | 419 | map Arith_Data.prep_simproc | 
| 23164 | 420 |    [("nat_eq_cancel_factor",
 | 
| 421 | ["(l::nat) * m = n", "(l::nat) = m * n"], | |
| 422 | K EqCancelFactor.proc), | |
| 423 |     ("nat_less_cancel_factor",
 | |
| 424 | ["(l::nat) * m < n", "(l::nat) < m * n"], | |
| 425 | K LessCancelFactor.proc), | |
| 426 |     ("nat_le_cancel_factor",
 | |
| 427 | ["(l::nat) * m <= n", "(l::nat) <= m * n"], | |
| 428 | K LeCancelFactor.proc), | |
| 429 |     ("nat_divide_cancel_factor",
 | |
| 430 | ["((l::nat) * m) div n", "(l::nat) div (m * n)"], | |
| 23969 | 431 | K DivideCancelFactor.proc), | 
| 432 |     ("nat_dvd_cancel_factor",
 | |
| 433 | ["((l::nat) * m) dvd n", "(l::nat) dvd (m * n)"], | |
| 434 | K DvdCancelFactor.proc)]; | |
| 23164 | 435 | |
| 436 | end; | |
| 437 | ||
| 438 | ||
| 439 | Addsimprocs Nat_Numeral_Simprocs.cancel_numerals; | |
| 440 | Addsimprocs [Nat_Numeral_Simprocs.combine_numerals]; | |
| 441 | Addsimprocs Nat_Numeral_Simprocs.cancel_numeral_factors; | |
| 442 | Addsimprocs Nat_Numeral_Simprocs.cancel_factor; | |
| 443 | ||
| 444 | ||
| 445 | (*examples: | |
| 446 | print_depth 22; | |
| 447 | set timing; | |
| 448 | set trace_simp; | |
| 449 | fun test s = (Goal s; by (Simp_tac 1)); | |
| 450 | ||
| 451 | (*cancel_numerals*) | |
| 452 | test "l +( 2) + (2) + 2 + (l + 2) + (oo + 2) = (uu::nat)"; | |
| 453 | test "(2*length xs < 2*length xs + j)"; | |
| 454 | test "(2*length xs < length xs * 2 + j)"; | |
| 455 | test "2*u = (u::nat)"; | |
| 456 | test "2*u = Suc (u)"; | |
| 457 | test "(i + j + 12 + (k::nat)) - 15 = y"; | |
| 458 | test "(i + j + 12 + (k::nat)) - 5 = y"; | |
| 459 | test "Suc u - 2 = y"; | |
| 460 | test "Suc (Suc (Suc u)) - 2 = y"; | |
| 461 | test "(i + j + 2 + (k::nat)) - 1 = y"; | |
| 462 | test "(i + j + 1 + (k::nat)) - 2 = y"; | |
| 463 | ||
| 464 | test "(2*x + (u*v) + y) - v*3*u = (w::nat)"; | |
| 465 | test "(2*x*u*v + 5 + (u*v)*4 + y) - v*u*4 = (w::nat)"; | |
| 466 | test "(2*x*u*v + (u*v)*4 + y) - v*u = (w::nat)"; | |
| 467 | test "Suc (Suc (2*x*u*v + u*4 + y)) - u = w"; | |
| 468 | test "Suc ((u*v)*4) - v*3*u = w"; | |
| 469 | test "Suc (Suc ((u*v)*3)) - v*3*u = w"; | |
| 470 | ||
| 471 | test "(i + j + 12 + (k::nat)) = u + 15 + y"; | |
| 472 | test "(i + j + 32 + (k::nat)) - (u + 15 + y) = zz"; | |
| 473 | test "(i + j + 12 + (k::nat)) = u + 5 + y"; | |
| 474 | (*Suc*) | |
| 475 | test "(i + j + 12 + k) = Suc (u + y)"; | |
| 476 | test "Suc (Suc (Suc (Suc (Suc (u + y))))) <= ((i + j) + 41 + k)"; | |
| 477 | test "(i + j + 5 + k) < Suc (Suc (Suc (Suc (Suc (u + y)))))"; | |
| 478 | test "Suc (Suc (Suc (Suc (Suc (u + y))))) - 5 = v"; | |
| 479 | test "(i + j + 5 + k) = Suc (Suc (Suc (Suc (Suc (Suc (Suc (u + y)))))))"; | |
| 480 | test "2*y + 3*z + 2*u = Suc (u)"; | |
| 481 | test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = Suc (u)"; | |
| 482 | test "2*y + 3*z + 6*w + 2*y + 3*z + 2*u = 2*y' + 3*z' + 6*w' + 2*y' + 3*z' + u + (vv::nat)"; | |
| 483 | test "6 + 2*y + 3*z + 4*u = Suc (vv + 2*u + z)"; | |
| 484 | test "(2*n*m) < (3*(m*n)) + (u::nat)"; | |
| 485 | ||
| 486 | test "(Suc (Suc (Suc (Suc (Suc (Suc (case length (f c) of 0 => 0 | Suc k => k)))))) <= Suc 0)"; | |
| 487 | ||
| 488 | test "Suc (Suc (Suc (Suc (Suc (Suc (length l1 + length l2)))))) <= length l1"; | |
| 489 | ||
| 490 | test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length l3)))))) <= length (compT P E A ST mxr e))"; | |
| 491 | ||
| 492 | test "( (Suc (Suc (Suc (Suc (Suc (length (compT P E A ST mxr e) + length (compT P E (A Un \<A> e) ST mxr c))))))) <= length (compT P E A ST mxr e))"; | |
| 493 | ||
| 494 | ||
| 495 | (*negative numerals: FAIL*) | |
| 496 | test "(i + j + -23 + (k::nat)) < u + 15 + y"; | |
| 497 | test "(i + j + 3 + (k::nat)) < u + -15 + y"; | |
| 498 | test "(i + j + -12 + (k::nat)) - 15 = y"; | |
| 499 | test "(i + j + 12 + (k::nat)) - -15 = y"; | |
| 500 | test "(i + j + -12 + (k::nat)) - -15 = y"; | |
| 501 | ||
| 502 | (*combine_numerals*) | |
| 503 | test "k + 3*k = (u::nat)"; | |
| 504 | test "Suc (i + 3) = u"; | |
| 505 | test "Suc (i + j + 3 + k) = u"; | |
| 506 | test "k + j + 3*k + j = (u::nat)"; | |
| 507 | test "Suc (j*i + i + k + 5 + 3*k + i*j*4) = (u::nat)"; | |
| 508 | test "(2*n*m) + (3*(m*n)) = (u::nat)"; | |
| 509 | (*negative numerals: FAIL*) | |
| 510 | test "Suc (i + j + -3 + k) = u"; | |
| 511 | ||
| 512 | (*cancel_numeral_factors*) | |
| 513 | test "9*x = 12 * (y::nat)"; | |
| 514 | test "(9*x) div (12 * (y::nat)) = z"; | |
| 515 | test "9*x < 12 * (y::nat)"; | |
| 516 | test "9*x <= 12 * (y::nat)"; | |
| 517 | ||
| 518 | (*cancel_factor*) | |
| 519 | test "x*k = k*(y::nat)"; | |
| 520 | test "k = k*(y::nat)"; | |
| 521 | test "a*(b*c) = (b::nat)"; | |
| 522 | test "a*(b*c) = d*(b::nat)*(x*a)"; | |
| 523 | ||
| 524 | test "x*k < k*(y::nat)"; | |
| 525 | test "k < k*(y::nat)"; | |
| 526 | test "a*(b*c) < (b::nat)"; | |
| 527 | test "a*(b*c) < d*(b::nat)*(x*a)"; | |
| 528 | ||
| 529 | test "x*k <= k*(y::nat)"; | |
| 530 | test "k <= k*(y::nat)"; | |
| 531 | test "a*(b*c) <= (b::nat)"; | |
| 532 | test "a*(b*c) <= d*(b::nat)*(x*a)"; | |
| 533 | ||
| 534 | test "(x*k) div (k*(y::nat)) = (uu::nat)"; | |
| 535 | test "(k) div (k*(y::nat)) = (uu::nat)"; | |
| 536 | test "(a*(b*c)) div ((b::nat)) = (uu::nat)"; | |
| 537 | test "(a*(b*c)) div (d*(b::nat)*(x*a)) = (uu::nat)"; | |
| 538 | *) |