116 fun swap_params_conv ctxt i j cv = |
116 fun swap_params_conv ctxt i j cv = |
117 let |
117 let |
118 fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt |
118 fun conv1 0 ctxt = Conv.forall_conv (cv o snd) ctxt |
119 | conv1 k ctxt = |
119 | conv1 k ctxt = |
120 Conv.rewr_conv @{thm swap_params} then_conv |
120 Conv.rewr_conv @{thm swap_params} then_conv |
121 Conv.forall_conv (conv1 (k-1) o snd) ctxt |
121 Conv.forall_conv (conv1 (k - 1) o snd) ctxt |
122 fun conv2 0 ctxt = conv1 j ctxt |
122 fun conv2 0 ctxt = conv1 j ctxt |
123 | conv2 k ctxt = Conv.forall_conv (conv2 (k-1) o snd) ctxt |
123 | conv2 k ctxt = Conv.forall_conv (conv2 (k - 1) o snd) ctxt |
124 in conv2 i ctxt end; |
124 in conv2 i ctxt end; |
125 |
125 |
126 fun swap_prems_conv 0 = Conv.all_conv |
126 fun swap_prems_conv 0 = Conv.all_conv |
127 | swap_prems_conv i = |
127 | swap_prems_conv i = |
128 Conv.implies_concl_conv (swap_prems_conv (i-1)) then_conv |
128 Conv.implies_concl_conv (swap_prems_conv (i - 1)) then_conv |
129 Conv.rewr_conv Drule.swap_prems_eq |
129 Conv.rewr_conv Drule.swap_prems_eq |
130 |
130 |
131 fun drop_judgment ctxt = Object_Logic.drop_judgment (ProofContext.theory_of ctxt); |
131 fun drop_judgment ctxt = Object_Logic.drop_judgment (ProofContext.theory_of ctxt); |
132 |
132 |
133 fun find_eq ctxt t = |
133 fun find_eq ctxt t = |
134 let |
134 let |
135 val l = length (Logic.strip_params t); |
135 val l = length (Logic.strip_params t); |
136 val Hs = Logic.strip_assums_hyp t; |
136 val Hs = Logic.strip_assums_hyp t; |
137 fun find (i, t) = |
137 fun find (i, t) = |
138 case Induct_Args.dest_def (drop_judgment ctxt t) of |
138 (case Induct_Args.dest_def (drop_judgment ctxt t) of |
139 SOME (Bound j, _) => SOME (i, j) |
139 SOME (Bound j, _) => SOME (i, j) |
140 | SOME (_, Bound j) => SOME (i, j) |
140 | SOME (_, Bound j) => SOME (i, j) |
141 | _ => NONE |
141 | _ => NONE); |
142 in |
142 in |
143 case get_first find (map_index I Hs) of |
143 (case get_first find (map_index I Hs) of |
144 NONE => NONE |
144 NONE => NONE |
145 | SOME (0, 0) => NONE |
145 | SOME (0, 0) => NONE |
146 | SOME (i, j) => SOME (i, l-j-1, j) |
146 | SOME (i, j) => SOME (i, l - j - 1, j)) |
147 end; |
147 end; |
148 |
148 |
149 fun mk_swap_rrule ctxt ct = case find_eq ctxt (term_of ct) of |
149 fun mk_swap_rrule ctxt ct = |
|
150 (case find_eq ctxt (term_of ct) of |
150 NONE => NONE |
151 NONE => NONE |
151 | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct); |
152 | SOME (i, k, j) => SOME (swap_params_conv ctxt k j (K (swap_prems_conv i)) ct)); |
152 |
153 |
153 val rearrange_eqs_simproc = Simplifier.simproc |
154 val rearrange_eqs_simproc = |
154 (Thm.theory_of_thm Drule.swap_prems_eq) "rearrange_eqs" ["all t"] |
155 Simplifier.simproc |
155 (fn thy => fn ss => fn t => |
156 (Thm.theory_of_thm Drule.swap_prems_eq) "rearrange_eqs" ["all t"] |
156 mk_swap_rrule (Simplifier.the_context ss) (cterm_of thy t)) |
157 (fn thy => fn ss => fn t => |
|
158 mk_swap_rrule (Simplifier.the_context ss) (cterm_of thy t)); |
|
159 |
157 |
160 |
158 (* rotate k premises to the left by j, skipping over first j premises *) |
161 (* rotate k premises to the left by j, skipping over first j premises *) |
159 |
162 |
160 fun rotate_conv 0 j 0 = Conv.all_conv |
163 fun rotate_conv 0 j 0 = Conv.all_conv |
161 | rotate_conv 0 j k = swap_prems_conv j then_conv rotate_conv 1 j (k-1) |
164 | rotate_conv 0 j k = swap_prems_conv j then_conv rotate_conv 1 j (k - 1) |
162 | rotate_conv i j k = Conv.implies_concl_conv (rotate_conv (i-1) j k); |
165 | rotate_conv i j k = Conv.implies_concl_conv (rotate_conv (i - 1) j k); |
163 |
166 |
164 fun rotate_tac j 0 = K all_tac |
167 fun rotate_tac j 0 = K all_tac |
165 | rotate_tac j k = SUBGOAL (fn (goal, i) => CONVERSION (rotate_conv |
168 | rotate_tac j k = SUBGOAL (fn (goal, i) => |
166 j (length (Logic.strip_assums_hyp goal) - j - k) k) i); |
169 CONVERSION (rotate_conv |
|
170 j (length (Logic.strip_assums_hyp goal) - j - k) k) i); |
|
171 |
167 |
172 |
168 (* rulify operators around definition *) |
173 (* rulify operators around definition *) |
169 |
174 |
170 fun rulify_defs_conv ctxt ct = |
175 fun rulify_defs_conv ctxt ct = |
171 if exists_subterm (is_some o Induct_Args.dest_def) (term_of ct) andalso |
176 if exists_subterm (is_some o Induct_Args.dest_def) (term_of ct) andalso |
276 local |
281 local |
277 |
282 |
278 fun mk_att f g name arg = |
283 fun mk_att f g name arg = |
279 let val (x, thm) = g arg in (Data.map (f (name, thm)) x, thm) end; |
284 let val (x, thm) = g arg in (Data.map (f (name, thm)) x, thm) end; |
280 |
285 |
281 fun del_att which = Thm.declaration_attribute (fn th => Data.map (which (pairself (fn rs => |
286 fun del_att which = |
282 fold Item_Net.remove (filter_rules rs th) rs)))); |
287 Thm.declaration_attribute (fn th => Data.map (which (pairself (fn rs => |
|
288 fold Item_Net.remove (filter_rules rs th) rs)))); |
283 |
289 |
284 fun map1 f (x, y, z, s) = (f x, y, z, s); |
290 fun map1 f (x, y, z, s) = (f x, y, z, s); |
285 fun map2 f (x, y, z, s) = (x, f y, z, s); |
291 fun map2 f (x, y, z, s) = (x, f y, z, s); |
286 fun map3 f (x, y, z, s) = (x, y, f z, s); |
292 fun map3 f (x, y, z, s) = (x, y, f z, s); |
287 fun map4 f (x, y, z, s) = (x, y, z, f s); |
293 fun map4 f (x, y, z, s) = (x, y, z, f s); |