diff --git a/src/ZF/arith_data.ML b/src/ZF/arith_data.ML --- a/src/ZF/arith_data.ML +++ b/src/ZF/arith_data.ML @@ -1,283 +1,283 @@ (* Title: ZF/arith_data.ML Author: Lawrence C Paulson, Cambridge University Computer Laboratory Arithmetic simplification: cancellation of common terms *) signature ARITH_DATA = sig (*the main outcome*) val nat_cancel: simproc list (*tools for use in similar applications*) val gen_trans_tac: Proof.context -> thm -> thm option -> tactic val prove_conv: string -> tactic list -> Proof.context -> thm list -> term * term -> thm option val simplify_meta_eq: thm list -> Proof.context -> thm -> thm (*debugging*) structure EqCancelNumeralsData : CANCEL_NUMERALS_DATA structure LessCancelNumeralsData : CANCEL_NUMERALS_DATA structure DiffCancelNumeralsData : CANCEL_NUMERALS_DATA end; structure ArithData: ARITH_DATA = struct val iT = Ind_Syntax.iT; val zero = \<^Const>\zero\; val succ = \<^Const>\succ\; fun mk_succ t = succ $ t; val one = mk_succ zero; -val mk_plus = FOLogic.mk_binop \<^const_name>\Arith.add\; +fun mk_plus (t, u) = \<^Const>\Arith.add for t u\; (*Thus mk_sum[t] yields t+#0; longer sums don't have a trailing zero*) fun mk_sum [] = zero | mk_sum [t,u] = mk_plus (t, u) | mk_sum (t :: ts) = mk_plus (t, mk_sum ts); (*this version ALWAYS includes a trailing zero*) fun long_mk_sum [] = zero | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts); val dest_plus = FOLogic.dest_bin \<^const_name>\Arith.add\ iT; (* dest_sum *) fun dest_sum \<^Const_>\zero\ = [] | dest_sum \<^Const_>\succ for t\ = one :: dest_sum t | dest_sum \<^Const_>\Arith.add for t u\ = dest_sum t @ dest_sum u | dest_sum tm = [tm]; (*Apply the given rewrite (if present) just once*) fun gen_trans_tac _ _ NONE = all_tac | gen_trans_tac ctxt th2 (SOME th) = ALLGOALS (resolve_tac ctxt [th RS th2]); (*Use <-> or = depending on the type of t*) fun mk_eq_iff(t,u) = if fastype_of t = iT then FOLogic.mk_eq(t,u) else FOLogic.mk_iff(t,u); (*We remove equality assumptions because they confuse the simplifier and because only type-checking assumptions are necessary.*) fun is_eq_thm th = can FOLogic.dest_eq (FOLogic.dest_Trueprop (Thm.prop_of th)); fun add_chyps chyps ct = Drule.list_implies (map Thm.cprop_of chyps, ct); fun prove_conv name tacs ctxt prems (t,u) = if t aconv u then NONE else let val prems' = filter_out is_eq_thm prems val goal = Logic.list_implies (map Thm.prop_of prems', FOLogic.mk_Trueprop (mk_eq_iff (t, u))); in SOME (prems' MRS Goal.prove ctxt [] [] goal (K (EVERY tacs))) handle ERROR msg => (warning (msg ^ "\nCancellation failed: no typing information? (" ^ name ^ ")"); NONE) end; (*** Use CancelNumerals simproc without binary numerals, just for cancellation ***) -val mk_times = FOLogic.mk_binop \<^const_name>\Arith.mult\; +fun mk_times (t, u) = \<^Const>\Arith.mult for t u\; fun mk_prod [] = one | mk_prod [t] = t | mk_prod (t :: ts) = if t = one then mk_prod ts else mk_times (t, mk_prod ts); val dest_times = FOLogic.dest_bin \<^const_name>\Arith.mult\ iT; fun dest_prod t = let val (t,u) = dest_times t in dest_prod t @ dest_prod u end handle TERM _ => [t]; (*Dummy version: the only arguments are 0 and 1*) fun mk_coeff (0, t) = zero | mk_coeff (1, t) = t | mk_coeff _ = raise TERM("mk_coeff", []); (*Dummy version: the "coefficient" is always 1. In the result, the factors are sorted terms*) fun dest_coeff t = (1, mk_prod (sort Term_Ord.term_ord (dest_prod t))); (*Find first coefficient-term THAT MATCHES u*) fun find_first_coeff past u [] = raise TERM("find_first_coeff", []) | find_first_coeff past u (t::terms) = let val (n,u') = dest_coeff t in if u aconv u' then (n, rev past @ terms) else find_first_coeff (t::past) u terms end handle TERM _ => find_first_coeff (t::past) u terms; (*Simplify #1*n and n*#1 to n*) val add_0s = [@{thm add_0_natify}, @{thm add_0_right_natify}]; val add_succs = [@{thm add_succ}, @{thm add_succ_right}]; val mult_1s = [@{thm mult_1_natify}, @{thm mult_1_right_natify}]; val tc_rules = [@{thm natify_in_nat}, @{thm add_type}, @{thm diff_type}, @{thm mult_type}]; val natifys = [@{thm natify_0}, @{thm natify_ident}, @{thm add_natify1}, @{thm add_natify2}, @{thm diff_natify1}, @{thm diff_natify2}]; (*Final simplification: cancel + and **) fun simplify_meta_eq rules ctxt = let val ctxt' = put_simpset FOL_ss ctxt delsimps @{thms iff_simps} (*these could erase the whole rule!*) addsimps rules |> fold Simplifier.add_eqcong [@{thm eq_cong2}, @{thm iff_cong2}] in mk_meta_eq o simplify ctxt' end; val final_rules = add_0s @ mult_1s @ [@{thm mult_0}, @{thm mult_0_right}]; structure CancelNumeralsCommon = struct val mk_sum = (fn T:typ => mk_sum) val dest_sum = dest_sum val mk_coeff = mk_coeff val dest_coeff = dest_coeff val find_first_coeff = find_first_coeff [] val norm_ss1 = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ add_succs @ mult_1s @ @{thms add_ac}) val norm_ss2 = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ mult_1s @ @{thms add_ac} @ @{thms mult_ac} @ tc_rules @ natifys) fun norm_tac ctxt = ALLGOALS (asm_simp_tac (put_simpset norm_ss1 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss2 ctxt)) val numeral_simp_ss = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ tc_rules @ natifys) fun numeral_simp_tac ctxt = ALLGOALS (asm_simp_tac (put_simpset numeral_simp_ss ctxt)) val simplify_meta_eq = simplify_meta_eq final_rules end; (** The functor argumnets are declared as separate structures so that they can be exported to ease debugging. **) structure EqCancelNumeralsData = struct open CancelNumeralsCommon val prove_conv = prove_conv "nateq_cancel_numerals" val mk_bal = FOLogic.mk_eq val dest_bal = FOLogic.dest_eq val bal_add1 = @{thm eq_add_iff [THEN iff_trans]} val bal_add2 = @{thm eq_add_iff [THEN iff_trans]} fun trans_tac ctxt = gen_trans_tac ctxt @{thm iff_trans} end; structure EqCancelNumerals = CancelNumeralsFun(EqCancelNumeralsData); structure LessCancelNumeralsData = struct open CancelNumeralsCommon val prove_conv = prove_conv "natless_cancel_numerals" - val mk_bal = FOLogic.mk_binrel \<^const_name>\Ordinal.lt\ + fun mk_bal (t, u) = \<^Const>\Ordinal.lt for t u\ val dest_bal = FOLogic.dest_bin \<^const_name>\Ordinal.lt\ iT val bal_add1 = @{thm less_add_iff [THEN iff_trans]} val bal_add2 = @{thm less_add_iff [THEN iff_trans]} fun trans_tac ctxt = gen_trans_tac ctxt @{thm iff_trans} end; structure LessCancelNumerals = CancelNumeralsFun(LessCancelNumeralsData); structure DiffCancelNumeralsData = struct open CancelNumeralsCommon val prove_conv = prove_conv "natdiff_cancel_numerals" - val mk_bal = FOLogic.mk_binop \<^const_name>\Arith.diff\ + fun mk_bal (t, u) = \<^Const>\Arith.diff for t u\ val dest_bal = FOLogic.dest_bin \<^const_name>\Arith.diff\ iT val bal_add1 = @{thm diff_add_eq [THEN trans]} val bal_add2 = @{thm diff_add_eq [THEN trans]} fun trans_tac ctxt = gen_trans_tac ctxt @{thm trans} end; structure DiffCancelNumerals = CancelNumeralsFun(DiffCancelNumeralsData); val nat_cancel = [Simplifier.make_simproc \<^context> "nateq_cancel_numerals" {lhss = [\<^term>\l #+ m = n\, \<^term>\l = m #+ n\, \<^term>\l #* m = n\, \<^term>\l = m #* n\, \<^term>\succ(m) = n\, \<^term>\m = succ(n)\], proc = K EqCancelNumerals.proc}, Simplifier.make_simproc \<^context> "natless_cancel_numerals" {lhss = [\<^term>\l #+ m < n\, \<^term>\l < m #+ n\, \<^term>\l #* m < n\, \<^term>\l < m #* n\, \<^term>\succ(m) < n\, \<^term>\m < succ(n)\], proc = K LessCancelNumerals.proc}, Simplifier.make_simproc \<^context> "natdiff_cancel_numerals" {lhss = [\<^term>\(l #+ m) #- n\, \<^term>\l #- (m #+ n)\, \<^term>\(l #* m) #- n\, \<^term>\l #- (m #* n)\, \<^term>\succ(m) #- n\, \<^term>\m #- succ(n)\], proc = K DiffCancelNumerals.proc}]; end; val _ = Theory.setup (Simplifier.map_theory_simpset (fn ctxt => ctxt addsimprocs ArithData.nat_cancel)); (*examples: print_depth 22; set timing; set simp_trace; fun test s = (Goal s; by (Asm_simp_tac 1)); test "x #+ y = x #+ z"; test "y #+ x = x #+ z"; test "x #+ y #+ z = x #+ z"; test "y #+ (z #+ x) = z #+ x"; test "x #+ y #+ z = (z #+ y) #+ (x #+ w)"; test "x#*y #+ z = (z #+ y) #+ (y#*x #+ w)"; test "x #+ succ(y) = x #+ z"; test "x #+ succ(y) = succ(z #+ x)"; test "succ(x) #+ succ(y) #+ z = succ(z #+ y) #+ succ(x #+ w)"; test "(x #+ y) #- (x #+ z) = w"; test "(y #+ x) #- (x #+ z) = dd"; test "(x #+ y #+ z) #- (x #+ z) = dd"; test "(y #+ (z #+ x)) #- (z #+ x) = dd"; test "(x #+ y #+ z) #- ((z #+ y) #+ (x #+ w)) = dd"; test "(x#*y #+ z) #- ((z #+ y) #+ (y#*x #+ w)) = dd"; (*BAD occurrence of natify*) test "(x #+ succ(y)) #- (x #+ z) = dd"; test "x #* y2 #+ y #* x2 = y #* x2 #+ x #* y2"; test "(x #+ succ(y)) #- (succ(z #+ x)) = dd"; test "(succ(x) #+ succ(y) #+ z) #- (succ(z #+ y) #+ succ(x #+ w)) = dd"; (*use of typing information*) test "x : nat ==> x #+ y = x"; test "x : nat --> x #+ y = x"; test "x : nat ==> x #+ y < x"; test "x : nat ==> x < y#+x"; test "x : nat ==> x le succ(x)"; (*fails: no typing information isn't visible*) test "x #+ y = x"; test "x #+ y < x #+ z"; test "y #+ x < x #+ z"; test "x #+ y #+ z < x #+ z"; test "y #+ z #+ x < x #+ z"; test "y #+ (z #+ x) < z #+ x"; test "x #+ y #+ z < (z #+ y) #+ (x #+ w)"; test "x#*y #+ z < (z #+ y) #+ (y#*x #+ w)"; test "x #+ succ(y) < x #+ z"; test "x #+ succ(y) < succ(z #+ x)"; test "succ(x) #+ succ(y) #+ z < succ(z #+ y) #+ succ(x #+ w)"; test "x #+ succ(y) le succ(z #+ x)"; *) diff --git a/src/ZF/int_arith.ML b/src/ZF/int_arith.ML --- a/src/ZF/int_arith.ML +++ b/src/ZF/int_arith.ML @@ -1,327 +1,327 @@ (* Title: ZF/int_arith.ML Author: Larry Paulson Simprocs for linear arithmetic. *) signature INT_NUMERAL_SIMPROCS = sig val cancel_numerals: simproc list val combine_numerals: simproc val combine_numerals_prod: simproc end structure Int_Numeral_Simprocs: INT_NUMERAL_SIMPROCS = struct (* abstract syntax operations *) fun mk_bit 0 = \<^term>\0\ | mk_bit 1 = \<^term>\succ(0)\ | mk_bit _ = raise TERM ("mk_bit", []); fun dest_bit \<^term>\0\ = 0 | dest_bit \<^term>\succ(0)\ = 1 | dest_bit t = raise TERM ("dest_bit", [t]); fun mk_bin i = let fun term_of [] = \<^term>\Pls\ | term_of [~1] = \<^term>\Min\ | term_of (b :: bs) = \<^term>\Bit\ $ term_of bs $ mk_bit b; in term_of (Numeral_Syntax.make_binary i) end; fun dest_bin tm = let fun bin_of \<^term>\Pls\ = [] | bin_of \<^term>\Min\ = [~1] | bin_of (\<^term>\Bit\ $ bs $ b) = dest_bit b :: bin_of bs | bin_of _ = raise TERM ("dest_bin", [tm]); in Numeral_Syntax.dest_binary (bin_of tm) end; (*Utilities*) fun mk_numeral i = \<^Const>\integ_of\ $ mk_bin i; fun dest_numeral \<^Const_>\integ_of for w\ = dest_bin w | dest_numeral t = raise TERM ("dest_numeral", [t]); fun find_first_numeral past (t::terms) = ((dest_numeral t, rev past @ terms) handle TERM _ => find_first_numeral (t::past) terms) | find_first_numeral past [] = raise TERM("find_first_numeral", []); val zero = mk_numeral 0; -val mk_plus = FOLogic.mk_binop \<^const_name>\zadd\; +fun mk_plus (t, u) = \<^Const>\zadd for t u\; (*Thus mk_sum[t] yields t+#0; longer sums don't have a trailing zero*) fun mk_sum [] = zero | mk_sum [t,u] = mk_plus (t, u) | mk_sum (t :: ts) = mk_plus (t, mk_sum ts); (*this version ALWAYS includes a trailing zero*) fun long_mk_sum [] = zero | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts); (*decompose additions AND subtractions as a sum*) fun dest_summing (pos, \<^Const_>\zadd for t u\, ts) = dest_summing (pos, t, dest_summing (pos, u, ts)) | dest_summing (pos, \<^Const_>\zdiff for t u\, ts) = dest_summing (pos, t, dest_summing (not pos, u, ts)) | dest_summing (pos, t, ts) = if pos then t::ts else \<^Const>\zminus for t\ :: ts; fun dest_sum t = dest_summing (true, t, []); val one = mk_numeral 1; -val mk_times = FOLogic.mk_binop \<^const_name>\zmult\; +fun mk_times (t, u) = \<^Const>\zmult for t u\; fun mk_prod [] = one | mk_prod [t] = t | mk_prod (t :: ts) = if t = one then mk_prod ts else mk_times (t, mk_prod ts); val dest_times = FOLogic.dest_bin \<^const_name>\zmult\ \<^typ>\i\; fun dest_prod t = let val (t,u) = dest_times t in dest_prod t @ dest_prod u end handle TERM _ => [t]; (*DON'T do the obvious simplifications; that would create special cases*) fun mk_coeff (k, t) = mk_times (mk_numeral k, t); (*Express t as a product of (possibly) a numeral with other sorted terms*) fun dest_coeff sign \<^Const_>\zminus for t\ = dest_coeff (~sign) t | dest_coeff sign t = let val ts = sort Term_Ord.term_ord (dest_prod t) val (n, ts') = find_first_numeral [] ts handle TERM _ => (1, ts) in (sign*n, mk_prod ts') end; (*Find first coefficient-term THAT MATCHES u*) fun find_first_coeff past u [] = raise TERM("find_first_coeff", []) | find_first_coeff past u (t::terms) = let val (n,u') = dest_coeff 1 t in if u aconv u' then (n, rev past @ terms) else find_first_coeff (t::past) u terms end handle TERM _ => find_first_coeff (t::past) u terms; (*Simplify #1*n and n*#1 to n*) val add_0s = [@{thm zadd_0_intify}, @{thm zadd_0_right_intify}]; val mult_1s = [@{thm zmult_1_intify}, @{thm zmult_1_right_intify}, @{thm zmult_minus1}, @{thm zmult_minus1_right}]; val tc_rules = [@{thm integ_of_type}, @{thm intify_in_int}, @{thm int_of_type}, @{thm zadd_type}, @{thm zdiff_type}, @{thm zmult_type}] @ @{thms bin.intros}; val intifys = [@{thm intify_ident}, @{thm zadd_intify1}, @{thm zadd_intify2}, @{thm zdiff_intify1}, @{thm zdiff_intify2}, @{thm zmult_intify1}, @{thm zmult_intify2}, @{thm zless_intify1}, @{thm zless_intify2}, @{thm zle_intify1}, @{thm zle_intify2}]; (*To perform binary arithmetic*) val bin_simps = [@{thm add_integ_of_left}] @ @{thms bin_arith_simps} @ @{thms bin_rel_simps}; (*To evaluate binary negations of coefficients*) val zminus_simps = @{thms NCons_simps} @ [@{thm integ_of_minus} RS @{thm sym}, @{thm bin_minus_1}, @{thm bin_minus_0}, @{thm bin_minus_Pls}, @{thm bin_minus_Min}, @{thm bin_pred_1}, @{thm bin_pred_0}, @{thm bin_pred_Pls}, @{thm bin_pred_Min}]; (*To let us treat subtraction as addition*) val diff_simps = [@{thm zdiff_def}, @{thm zminus_zadd_distrib}, @{thm zminus_zminus}]; (*push the unary minus down*) val int_minus_mult_eq_1_to_2 = @{lemma "$- w $* z = w $* $- z" by simp}; (*to extract again any uncancelled minuses*) val int_minus_from_mult_simps = [@{thm zminus_zminus}, @{thm zmult_zminus}, @{thm zmult_zminus_right}]; (*combine unary minus with numeric literals, however nested within a product*) val int_mult_minus_simps = [@{thm zmult_assoc}, @{thm zmult_zminus} RS @{thm sym}, int_minus_mult_eq_1_to_2]; structure CancelNumeralsCommon = struct val mk_sum = (fn _ : typ => mk_sum) val dest_sum = dest_sum val mk_coeff = mk_coeff val dest_coeff = dest_coeff 1 val find_first_coeff = find_first_coeff [] fun trans_tac ctxt = ArithData.gen_trans_tac ctxt @{thm iff_trans} val norm_ss1 = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ mult_1s @ diff_simps @ zminus_simps @ @{thms zadd_ac}) val norm_ss2 = simpset_of (put_simpset ZF_ss \<^context> addsimps bin_simps @ int_mult_minus_simps @ intifys) val norm_ss3 = simpset_of (put_simpset ZF_ss \<^context> addsimps int_minus_from_mult_simps @ @{thms zadd_ac} @ @{thms zmult_ac} @ tc_rules @ intifys) fun norm_tac ctxt = ALLGOALS (asm_simp_tac (put_simpset norm_ss1 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss2 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss3 ctxt)) val numeral_simp_ss = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ bin_simps @ tc_rules @ intifys) fun numeral_simp_tac ctxt = ALLGOALS (simp_tac (put_simpset numeral_simp_ss ctxt)) THEN ALLGOALS (asm_simp_tac ctxt) val simplify_meta_eq = ArithData.simplify_meta_eq (add_0s @ mult_1s) end; structure EqCancelNumerals = CancelNumeralsFun (open CancelNumeralsCommon val prove_conv = ArithData.prove_conv "inteq_cancel_numerals" val mk_bal = FOLogic.mk_eq val dest_bal = FOLogic.dest_eq val bal_add1 = @{thm eq_add_iff1} RS @{thm iff_trans} val bal_add2 = @{thm eq_add_iff2} RS @{thm iff_trans} ); structure LessCancelNumerals = CancelNumeralsFun (open CancelNumeralsCommon val prove_conv = ArithData.prove_conv "intless_cancel_numerals" - val mk_bal = FOLogic.mk_binrel \<^const_name>\zless\ + fun mk_bal (t, u) = \<^Const>\zless for t u\ val dest_bal = FOLogic.dest_bin \<^const_name>\zless\ \<^typ>\i\ val bal_add1 = @{thm less_add_iff1} RS @{thm iff_trans} val bal_add2 = @{thm less_add_iff2} RS @{thm iff_trans} ); structure LeCancelNumerals = CancelNumeralsFun (open CancelNumeralsCommon val prove_conv = ArithData.prove_conv "intle_cancel_numerals" - val mk_bal = FOLogic.mk_binrel \<^const_name>\zle\ + fun mk_bal (t, u) = \<^Const>\zle for t u\ val dest_bal = FOLogic.dest_bin \<^const_name>\zle\ \<^typ>\i\ val bal_add1 = @{thm le_add_iff1} RS @{thm iff_trans} val bal_add2 = @{thm le_add_iff2} RS @{thm iff_trans} ); val cancel_numerals = [Simplifier.make_simproc \<^context> "inteq_cancel_numerals" {lhss = [\<^term>\l $+ m = n\, \<^term>\l = m $+ n\, \<^term>\l $- m = n\, \<^term>\l = m $- n\, \<^term>\l $* m = n\, \<^term>\l = m $* n\], proc = K EqCancelNumerals.proc}, Simplifier.make_simproc \<^context> "intless_cancel_numerals" {lhss = [\<^term>\l $+ m $< n\, \<^term>\l $< m $+ n\, \<^term>\l $- m $< n\, \<^term>\l $< m $- n\, \<^term>\l $* m $< n\, \<^term>\l $< m $* n\], proc = K LessCancelNumerals.proc}, Simplifier.make_simproc \<^context> "intle_cancel_numerals" {lhss = [\<^term>\l $+ m $\ n\, \<^term>\l $\ m $+ n\, \<^term>\l $- m $\ n\, \<^term>\l $\ m $- n\, \<^term>\l $* m $\ n\, \<^term>\l $\ m $* n\], proc = K LeCancelNumerals.proc}]; (*version without the hyps argument*) fun prove_conv_nohyps name tacs sg = ArithData.prove_conv name tacs sg []; structure CombineNumeralsData = struct type coeff = int val iszero = (fn x => x = 0) val add = op + val mk_sum = (fn _ : typ => long_mk_sum) (*to work for #2*x $+ #3*x *) val dest_sum = dest_sum val mk_coeff = mk_coeff val dest_coeff = dest_coeff 1 val left_distrib = @{thm left_zadd_zmult_distrib} RS @{thm trans} val prove_conv = prove_conv_nohyps "int_combine_numerals" fun trans_tac ctxt = ArithData.gen_trans_tac ctxt @{thm trans} val norm_ss1 = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ mult_1s @ diff_simps @ zminus_simps @ @{thms zadd_ac} @ intifys) val norm_ss2 = simpset_of (put_simpset ZF_ss \<^context> addsimps bin_simps @ int_mult_minus_simps @ intifys) val norm_ss3 = simpset_of (put_simpset ZF_ss \<^context> addsimps int_minus_from_mult_simps @ @{thms zadd_ac} @ @{thms zmult_ac} @ tc_rules @ intifys) fun norm_tac ctxt = ALLGOALS (asm_simp_tac (put_simpset norm_ss1 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss2 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss3 ctxt)) val numeral_simp_ss = simpset_of (put_simpset ZF_ss \<^context> addsimps add_0s @ bin_simps @ tc_rules @ intifys) fun numeral_simp_tac ctxt = ALLGOALS (simp_tac (put_simpset numeral_simp_ss ctxt)) val simplify_meta_eq = ArithData.simplify_meta_eq (add_0s @ mult_1s) end; structure CombineNumerals = CombineNumeralsFun(CombineNumeralsData); val combine_numerals = Simplifier.make_simproc \<^context> "int_combine_numerals" {lhss = [\<^term>\i $+ j\, \<^term>\i $- j\], proc = K CombineNumerals.proc}; (** Constant folding for integer multiplication **) (*The trick is to regard products as sums, e.g. #3 $* x $* #4 as the "sum" of #3, x, #4; the literals are then multiplied*) structure CombineNumeralsProdData = struct type coeff = int val iszero = (fn x => x = 0) val add = op * val mk_sum = (fn _ : typ => mk_prod) val dest_sum = dest_prod fun mk_coeff(k,t) = if t = one then mk_numeral k else raise TERM("mk_coeff", []) fun dest_coeff t = (dest_numeral t, one) (*We ONLY want pure numerals.*) val left_distrib = @{thm zmult_assoc} RS @{thm sym} RS @{thm trans} val prove_conv = prove_conv_nohyps "int_combine_numerals_prod" fun trans_tac ctxt = ArithData.gen_trans_tac ctxt @{thm trans} val norm_ss1 = simpset_of (put_simpset ZF_ss \<^context> addsimps mult_1s @ diff_simps @ zminus_simps) val norm_ss2 = simpset_of (put_simpset ZF_ss \<^context> addsimps [@{thm zmult_zminus_right} RS @{thm sym}] @ bin_simps @ @{thms zmult_ac} @ tc_rules @ intifys) fun norm_tac ctxt = ALLGOALS (asm_simp_tac (put_simpset norm_ss1 ctxt)) THEN ALLGOALS (asm_simp_tac (put_simpset norm_ss2 ctxt)) val numeral_simp_ss = simpset_of (put_simpset ZF_ss \<^context> addsimps bin_simps @ tc_rules @ intifys) fun numeral_simp_tac ctxt = ALLGOALS (simp_tac (put_simpset numeral_simp_ss ctxt)) val simplify_meta_eq = ArithData.simplify_meta_eq (mult_1s); end; structure CombineNumeralsProd = CombineNumeralsFun(CombineNumeralsProdData); val combine_numerals_prod = Simplifier.make_simproc \<^context> "int_combine_numerals_prod" {lhss = [\<^term>\i $* j\], proc = K CombineNumeralsProd.proc}; end; val _ = Theory.setup (Simplifier.map_theory_simpset (fn ctxt => ctxt addsimprocs (Int_Numeral_Simprocs.cancel_numerals @ [Int_Numeral_Simprocs.combine_numerals, Int_Numeral_Simprocs.combine_numerals_prod])));