47 |
47 |
48 val one_to_of_int_one_simproc = |
48 val one_to_of_int_one_simproc = |
49 make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc", |
49 make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc", |
50 proc = proc1, identifier = []}; |
50 proc = proc1, identifier = []}; |
51 |
51 |
52 val allowed_consts = |
52 fun check (Const (@{const_name "HOL.one"}, @{typ int})) = false |
53 [@{const_name "op ="}, @{const_name "HOL.times"}, @{const_name "HOL.uminus"}, |
53 | check (Const (@{const_name "HOL.one"}, _)) = true |
54 @{const_name "HOL.minus"}, @{const_name "HOL.plus"}, |
54 | check (Const (s, _)) = member (op =) [@{const_name "op ="}, |
55 @{const_name "HOL.zero"}, @{const_name "HOL.one"}, @{const_name "HOL.less"}, |
55 @{const_name "HOL.times"}, @{const_name "HOL.uminus"}, |
56 @{const_name "HOL.less_eq"}]; |
56 @{const_name "HOL.minus"}, @{const_name "HOL.plus"}, |
57 |
57 @{const_name "HOL.zero"}, |
58 fun check t = case t of |
58 @{const_name "HOL.less"}, @{const_name "HOL.less_eq"}] s |
59 Const(s,t) => if s = @{const_name "HOL.one"} then not (t = @{typ int}) |
59 | check (a $ b) = check a andalso check b |
60 else s mem_string allowed_consts |
60 | check _ = false; |
61 | a$b => check a andalso check b |
|
62 | _ => false; |
|
63 |
61 |
64 val conv = |
62 val conv = |
65 Simplifier.rewrite |
63 Simplifier.rewrite |
66 (HOL_basic_ss addsimps |
64 (HOL_basic_ss addsimps |
67 ((map (fn th => th RS sym) [@{thm of_int_add}, @{thm of_int_mult}, |
65 ((map (fn th => th RS sym) [@{thm of_int_add}, @{thm of_int_mult}, |
78 |
76 |
79 val zero_one_idom_simproc = |
77 val zero_one_idom_simproc = |
80 make_simproc {lhss = lhss' , name = "zero_one_idom_simproc", |
78 make_simproc {lhss = lhss' , name = "zero_one_idom_simproc", |
81 proc = sproc, identifier = []} |
79 proc = sproc, identifier = []} |
82 |
80 |
83 val add_rules = |
|
84 simp_thms @ @{thms arith_simps} @ @{thms rel_simps} @ @{thms arith_special} @ |
|
85 @{thms int_arith_rules} |
|
86 |
|
87 val nat_inj_thms = [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2] |
|
88 |
|
89 val numeral_base_simprocs = Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc |
|
90 :: Numeral_Simprocs.combine_numerals |
|
91 :: Numeral_Simprocs.cancel_numerals; |
|
92 |
|
93 val setup = |
|
94 Lin_Arith.map_data (fn {add_mono_thms, mult_mono_thms, inj_thms, lessD, neqE, simpset} => |
|
95 {add_mono_thms = add_mono_thms, |
|
96 mult_mono_thms = (*@{thm mult_strict_left_mono} :: @{thm mult_left_mono} :: *)mult_mono_thms, |
|
97 inj_thms = nat_inj_thms @ inj_thms, |
|
98 lessD = lessD @ [@{thm zless_imp_add1_zle}], |
|
99 neqE = neqE, |
|
100 simpset = simpset addsimps add_rules |
|
101 addsimprocs numeral_base_simprocs}) #> |
|
102 Lin_Arith.add_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) #> |
|
103 Lin_Arith.add_discrete_type @{type_name Int.int} |
|
104 |
|
105 val fast_int_arith_simproc = |
81 val fast_int_arith_simproc = |
106 Simplifier.simproc (the_context ()) |
82 Simplifier.simproc @{theory} "fast_int_arith" |
107 "fast_int_arith" |
|
108 ["(m::'a::{ordered_idom,number_ring}) < n", |
83 ["(m::'a::{ordered_idom,number_ring}) < n", |
109 "(m::'a::{ordered_idom,number_ring}) <= n", |
84 "(m::'a::{ordered_idom,number_ring}) <= n", |
110 "(m::'a::{ordered_idom,number_ring}) = n"] (K Lin_Arith.lin_arith_simproc); |
85 "(m::'a::{ordered_idom,number_ring}) = n"] (K Lin_Arith.lin_arith_simproc); |
111 |
86 |
|
87 val global_setup = Simplifier.map_simpset |
|
88 (fn simpset => simpset addsimprocs [fast_int_arith_simproc]); |
|
89 |
|
90 val setup = |
|
91 Lin_Arith.add_inj_thms [@{thm zle_int} RS iffD2, @{thm int_int_eq} RS iffD2] |
|
92 #> Lin_Arith.add_lessD @{thm zless_imp_add1_zle} |
|
93 #> Lin_Arith.add_simps (@{thms simp_thms} @ @{thms arith_simps} @ @{thms rel_simps} |
|
94 @ @{thms arith_special} @ @{thms int_arith_rules}) |
|
95 #> Lin_Arith.add_simprocs (Numeral_Simprocs.assoc_fold_simproc :: zero_one_idom_simproc |
|
96 :: Numeral_Simprocs.combine_numerals |
|
97 :: Numeral_Simprocs.cancel_numerals) |
|
98 #> Lin_Arith.add_inj_const (@{const_name of_nat}, HOLogic.natT --> HOLogic.intT) |
|
99 #> Lin_Arith.add_discrete_type @{type_name Int.int} |
|
100 |
112 end; |
101 end; |
113 |
|
114 Addsimprocs [Int_Arith.fast_int_arith_simproc]; |
|