50 fun long_mk_sum [] = HOLogic.zero |
50 fun long_mk_sum [] = HOLogic.zero |
51 | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts); |
51 | long_mk_sum (t :: ts) = mk_plus (t, mk_sum ts); |
52 |
52 |
53 val dest_plus = HOLogic.dest_bin "HOL.plus" HOLogic.natT; |
53 val dest_plus = HOLogic.dest_bin "HOL.plus" HOLogic.natT; |
54 |
54 |
55 (*extract the outer Sucs from a term and convert them to a binary numeral*) |
55 (*Split up a sum into the list of its constituent terms, on the way removing any |
56 fun dest_Sucs (k, Const ("Suc", _) $ t) = dest_Sucs (k+1, t) |
56 Sucs and counting them.*) |
57 | dest_Sucs (0, t) = t |
57 fun dest_Suc_sum (Const ("Suc", _) $ t, (k,ts)) = dest_Suc_sum (t, (k+1,ts)) |
58 | dest_Sucs (k, t) = mk_plus (mk_numeral k, t); |
58 | dest_Suc_sum (t, (k,ts)) = |
59 |
59 let val (t1,t2) = dest_plus t |
60 fun dest_sum t = |
60 in dest_Suc_sum (t1, dest_Suc_sum (t2, (k,ts))) end |
61 let val (t,u) = dest_plus t |
61 handle TERM _ => (k, t::ts); |
62 in dest_sum t @ dest_sum u end |
62 |
63 handle TERM _ => [t]; |
63 (*The Sucs found in the term are converted to a binary numeral*) |
64 |
64 fun dest_Sucs_sum t = |
65 fun dest_Sucs_sum t = dest_sum (dest_Sucs (0,t)); |
65 case dest_Suc_sum (t,(0,[])) of |
|
66 (0,ts) => ts |
|
67 | (k,ts) => mk_numeral k :: ts |
66 |
68 |
67 |
69 |
68 (** Other simproc items **) |
70 (** Other simproc items **) |
69 |
71 |
70 val trans_tac = Int_Numeral_Simprocs.trans_tac; |
72 val trans_tac = Int_Numeral_Simprocs.trans_tac; |
136 mult_0, mult_0_right, mult_1, mult_1_right] @ contra_rules); |
138 mult_0, mult_0_right, mult_1, mult_1_right] @ contra_rules); |
137 |
139 |
138 |
140 |
139 (** Restricted version of dest_Sucs_sum for nat_combine_numerals: |
141 (** Restricted version of dest_Sucs_sum for nat_combine_numerals: |
140 Simprocs never apply unless the original expression contains at least one |
142 Simprocs never apply unless the original expression contains at least one |
141 numeral in a coefficient position. |
143 numeral in a coefficient position. This avoids replacing x+x by |
|
144 2*x, for example, unless numerals have been used already. |
142 **) |
145 **) |
143 |
|
144 fun ignore_Sucs (Const ("Suc", _) $ t) = ignore_Sucs t |
|
145 | ignore_Sucs t = t; |
|
146 |
146 |
147 fun is_numeral (Const("Numeral.number_of", _) $ w) = true |
147 fun is_numeral (Const("Numeral.number_of", _) $ w) = true |
148 | is_numeral _ = false; |
148 | is_numeral _ = false; |
149 |
149 |
150 fun prod_has_numeral t = exists is_numeral (dest_prod t); |
150 fun prod_has_numeral t = exists is_numeral (dest_prod t); |
151 |
151 |
|
152 fun require_has_numeral ts = |
|
153 if exists prod_has_numeral ts then ts |
|
154 else raise TERM("Nat_Numeral_Simprocs.restricted_dest_Sucs_sum", ts); |
|
155 |
152 fun restricted_dest_Sucs_sum t = |
156 fun restricted_dest_Sucs_sum t = |
153 if exists prod_has_numeral (dest_sum (ignore_Sucs t)) |
157 case dest_Suc_sum (t,(0,[])) of |
154 then dest_Sucs_sum t |
158 (0,ts) => require_has_numeral ts |
155 else raise TERM("Nat_Numeral_Simprocs.restricted_dest_Sucs_sum", [t]); |
159 | (k,ts) => mk_numeral k :: require_has_numeral ts |
156 |
160 |
157 |
161 |
158 (*Like HOL_ss but with an ordering that brings numerals to the front |
162 (*Like HOL_ss but with an ordering that brings numerals to the front |
159 under AC-rewriting.*) |
163 under AC-rewriting.*) |
160 val num_ss = Int_Numeral_Simprocs.num_ss; |
164 val num_ss = Int_Numeral_Simprocs.num_ss; |