216 |
216 |
217 (** Final simplification for the CancelFactor simprocs **) |
217 (** Final simplification for the CancelFactor simprocs **) |
218 val simplify_one = Arith_Data.simplify_meta_eq |
218 val simplify_one = Arith_Data.simplify_meta_eq |
219 [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}]; |
219 [@{thm mult_1_left}, @{thm mult_1_right}, @{thm div_by_1}, @{thm numeral_1_eq_1}]; |
220 |
220 |
221 fun cancel_simplify_meta_eq cancel_th ss th = |
221 fun cancel_simplify_meta_eq ss cancel_th th = |
222 simplify_one ss (([th, cancel_th]) MRS trans); |
222 simplify_one ss (([th, cancel_th]) MRS trans); |
|
223 |
|
224 local |
|
225 val Tp_Eq = Thm.reflexive(Thm.cterm_of (@{theory HOL}) HOLogic.Trueprop) |
|
226 fun Eq_True_elim Eq = |
|
227 Thm.equal_elim (Thm.combination Tp_Eq (Thm.symmetric Eq)) @{thm TrueI} |
|
228 in |
|
229 fun sign_conv pos_th neg_th ss t = |
|
230 let val T = fastype_of t; |
|
231 val zero = Const(@{const_name HOL.zero}, T); |
|
232 val less = Const(@{const_name HOL.less}, [T,T] ---> HOLogic.boolT); |
|
233 val pos = less $ zero $ t and neg = less $ t $ zero |
|
234 fun prove p = |
|
235 Option.map Eq_True_elim (LinArith.lin_arith_simproc ss p) |
|
236 handle THM _ => NONE |
|
237 in case prove pos of |
|
238 SOME th => SOME(th RS pos_th) |
|
239 | NONE => (case prove neg of |
|
240 SOME th => SOME(th RS neg_th) |
|
241 | NONE => NONE) |
|
242 end; |
|
243 end |
223 |
244 |
224 structure CancelFactorCommon = |
245 structure CancelFactorCommon = |
225 struct |
246 struct |
226 val mk_sum = long_mk_prod |
247 val mk_sum = long_mk_prod |
227 val dest_sum = dest_prod |
248 val dest_sum = dest_prod |
229 val dest_coeff = dest_coeff |
250 val dest_coeff = dest_coeff |
230 val find_first = find_first_t [] |
251 val find_first = find_first_t [] |
231 val trans_tac = K Arith_Data.trans_tac |
252 val trans_tac = K Arith_Data.trans_tac |
232 val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac} |
253 val norm_ss = HOL_ss addsimps mult_1s @ @{thms mult_ac} |
233 fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss)) |
254 fun norm_tac ss = ALLGOALS (simp_tac (Simplifier.inherit_context ss norm_ss)) |
|
255 val simplify_meta_eq = cancel_simplify_meta_eq |
234 end; |
256 end; |
235 |
257 |
236 (*mult_cancel_left requires a ring with no zero divisors.*) |
258 (*mult_cancel_left requires a ring with no zero divisors.*) |
237 structure EqCancelFactor = ExtractCommonTermFun |
259 structure EqCancelFactor = ExtractCommonTermFun |
238 (open CancelFactorCommon |
260 (open CancelFactorCommon |
239 val prove_conv = Arith_Data.prove_conv |
261 val prove_conv = Arith_Data.prove_conv |
240 val mk_bal = HOLogic.mk_eq |
262 val mk_bal = HOLogic.mk_eq |
241 val dest_bal = HOLogic.dest_bin "op =" Term.dummyT |
263 val dest_bal = HOLogic.dest_bin "op =" Term.dummyT |
242 val simplify_meta_eq = cancel_simplify_meta_eq @{thm mult_cancel_left} |
264 val simp_conv = K (K (SOME @{thm mult_cancel_left})) |
|
265 ); |
|
266 |
|
267 (*for ordered rings*) |
|
268 structure LeCancelFactor = ExtractCommonTermFun |
|
269 (open CancelFactorCommon |
|
270 val prove_conv = Arith_Data.prove_conv |
|
271 val mk_bal = HOLogic.mk_binrel @{const_name HOL.less_eq} |
|
272 val dest_bal = HOLogic.dest_bin @{const_name HOL.less_eq} Term.dummyT |
|
273 val simp_conv = sign_conv |
|
274 @{thm mult_le_cancel_left_pos} @{thm mult_le_cancel_left_neg} |
|
275 ); |
|
276 |
|
277 (*for ordered rings*) |
|
278 structure LessCancelFactor = ExtractCommonTermFun |
|
279 (open CancelFactorCommon |
|
280 val prove_conv = Arith_Data.prove_conv |
|
281 val mk_bal = HOLogic.mk_binrel @{const_name HOL.less} |
|
282 val dest_bal = HOLogic.dest_bin @{const_name HOL.less} Term.dummyT |
|
283 val simp_conv = sign_conv |
|
284 @{thm mult_less_cancel_left_pos} @{thm mult_less_cancel_left_neg} |
243 ); |
285 ); |
244 |
286 |
245 (*zdiv_zmult_zmult1_if is for integer division (div).*) |
287 (*zdiv_zmult_zmult1_if is for integer division (div).*) |
246 structure IntDivCancelFactor = ExtractCommonTermFun |
288 structure IntDivCancelFactor = ExtractCommonTermFun |
247 (open CancelFactorCommon |
289 (open CancelFactorCommon |
248 val prove_conv = Arith_Data.prove_conv |
290 val prove_conv = Arith_Data.prove_conv |
249 val mk_bal = HOLogic.mk_binop @{const_name Divides.div} |
291 val mk_bal = HOLogic.mk_binop @{const_name Divides.div} |
250 val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT |
292 val dest_bal = HOLogic.dest_bin @{const_name Divides.div} HOLogic.intT |
251 val simplify_meta_eq = cancel_simplify_meta_eq @{thm zdiv_zmult_zmult1_if} |
293 val simp_conv = K (K (SOME @{thm zdiv_zmult_zmult1_if})) |
252 ); |
294 ); |
253 |
295 |
254 structure IntModCancelFactor = ExtractCommonTermFun |
296 structure IntModCancelFactor = ExtractCommonTermFun |
255 (open CancelFactorCommon |
297 (open CancelFactorCommon |
256 val prove_conv = Arith_Data.prove_conv |
298 val prove_conv = Arith_Data.prove_conv |
257 val mk_bal = HOLogic.mk_binop @{const_name Divides.mod} |
299 val mk_bal = HOLogic.mk_binop @{const_name Divides.mod} |
258 val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} HOLogic.intT |
300 val dest_bal = HOLogic.dest_bin @{const_name Divides.mod} HOLogic.intT |
259 val simplify_meta_eq = cancel_simplify_meta_eq @{thm zmod_zmult_zmult1} |
301 val simp_conv = K (K (SOME @{thm zmod_zmult_zmult1})) |
260 ); |
302 ); |
261 |
303 |
262 structure IntDvdCancelFactor = ExtractCommonTermFun |
304 structure IntDvdCancelFactor = ExtractCommonTermFun |
263 (open CancelFactorCommon |
305 (open CancelFactorCommon |
264 val prove_conv = Arith_Data.prove_conv |
306 val prove_conv = Arith_Data.prove_conv |
265 val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd} |
307 val mk_bal = HOLogic.mk_binrel @{const_name Ring_and_Field.dvd} |
266 val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT |
308 val dest_bal = HOLogic.dest_bin @{const_name Ring_and_Field.dvd} Term.dummyT |
267 val simplify_meta_eq = cancel_simplify_meta_eq @{thm dvd_mult_cancel_left} |
309 val simp_conv = K (K (SOME @{thm dvd_mult_cancel_left})) |
268 ); |
310 ); |
269 |
311 |
270 (*Version for all fields, including unordered ones (type complex).*) |
312 (*Version for all fields, including unordered ones (type complex).*) |
271 structure DivideCancelFactor = ExtractCommonTermFun |
313 structure DivideCancelFactor = ExtractCommonTermFun |
272 (open CancelFactorCommon |
314 (open CancelFactorCommon |
273 val prove_conv = Arith_Data.prove_conv |
315 val prove_conv = Arith_Data.prove_conv |
274 val mk_bal = HOLogic.mk_binop @{const_name HOL.divide} |
316 val mk_bal = HOLogic.mk_binop @{const_name HOL.divide} |
275 val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT |
317 val dest_bal = HOLogic.dest_bin @{const_name HOL.divide} Term.dummyT |
276 val simplify_meta_eq = cancel_simplify_meta_eq @{thm mult_divide_mult_cancel_left_if} |
318 val simp_conv = K (K (SOME @{thm mult_divide_mult_cancel_left_if})) |
277 ); |
319 ); |
278 |
320 |
279 val cancel_factors = |
321 val cancel_factors = |
280 map Arith_Data.prep_simproc |
322 map Arith_Data.prep_simproc |
281 [("ring_eq_cancel_factor", |
323 [("ring_eq_cancel_factor", |
282 ["(l::'a::{idom}) * m = n", |
324 ["(l::'a::{idom}) * m = n", |
283 "(l::'a::{idom}) = m * n"], |
325 "(l::'a::{idom}) = m * n"], |
284 K EqCancelFactor.proc), |
326 K EqCancelFactor.proc), |
|
327 ("ordered_ring_le_cancel_factor", |
|
328 ["(l::'a::ordered_ring) * m <= n", |
|
329 "(l::'a::ordered_ring) <= m * n"], |
|
330 K LeCancelFactor.proc), |
|
331 ("ordered_ring_less_cancel_factor", |
|
332 ["(l::'a::ordered_ring) * m < n", |
|
333 "(l::'a::ordered_ring) < m * n"], |
|
334 K LessCancelFactor.proc), |
285 ("int_div_cancel_factor", |
335 ("int_div_cancel_factor", |
286 ["((l::int) * m) div n", "(l::int) div (m * n)"], |
336 ["((l::int) * m) div n", "(l::int) div (m * n)"], |
287 K IntDivCancelFactor.proc), |
337 K IntDivCancelFactor.proc), |
288 ("int_mod_cancel_factor", |
338 ("int_mod_cancel_factor", |
289 ["((l::int) * m) mod n", "(l::int) mod (m * n)"], |
339 ["((l::int) * m) mod n", "(l::int) mod (m * n)"], |