67 val not_ex = thm "not_ex"; |
67 val not_ex = thm "not_ex"; |
68 val not_iff = thm "not_iff"; |
68 val not_iff = thm "not_iff"; |
69 val not_imp = thm "not_imp"; |
69 val not_imp = thm "not_imp"; |
70 val not_not = thm "not_not"; |
70 val not_not = thm "not_not"; |
71 val rev_conj_cong = thm "rev_conj_cong"; |
71 val rev_conj_cong = thm "rev_conj_cong"; |
|
72 val simp_impliesE = thm "simp_impliesI"; |
|
73 val simp_impliesI = thm "simp_impliesI"; |
|
74 val simp_implies_cong = thm "simp_implies_cong"; |
|
75 val simp_implies_def = thm "simp_implies_def"; |
72 val simp_thms = thms "simp_thms"; |
76 val simp_thms = thms "simp_thms"; |
73 val split_if = thm "split_if"; |
77 val split_if = thm "split_if"; |
74 val split_if_asm = thm "split_if_asm"; |
78 val split_if_asm = thm "split_if_asm"; |
75 val atomize_not = thm"atomize_not"; |
79 val atomize_not = thm"atomize_not"; |
76 |
80 |
196 (* Expects Trueprop(.) if not == *) |
200 (* Expects Trueprop(.) if not == *) |
197 |
201 |
198 fun mk_eq_True r = |
202 fun mk_eq_True r = |
199 SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE; |
203 SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE; |
200 |
204 |
|
205 (* Produce theorems of the form |
|
206 (P1 =simp=> ... =simp=> Pn => x == y) ==> (P1 =simp=> ... =simp=> Pn => x = y) |
|
207 *) |
|
208 fun lift_meta_eq_to_obj_eq i st = |
|
209 let |
|
210 val {sign, ...} = rep_thm st; |
|
211 fun count_imp (Const ("HOL.simp_implies", _) $ P $ Q) = 1 + count_imp Q |
|
212 | count_imp _ = 0; |
|
213 val j = count_imp (Logic.strip_assums_concl (List.nth (prems_of st, i - 1))) |
|
214 in if j = 0 then meta_eq_to_obj_eq |
|
215 else |
|
216 let |
|
217 val Ps = map (fn k => Free ("P" ^ string_of_int k, propT)) (1 upto j); |
|
218 fun mk_simp_implies Q = foldr (fn (R, S) => |
|
219 Const ("HOL.simp_implies", propT --> propT --> propT) $ R $ S) Q Ps |
|
220 val aT = TFree ("'a", HOLogic.typeS); |
|
221 val x = Free ("x", aT); |
|
222 val y = Free ("y", aT) |
|
223 in prove_goalw_cterm [simp_implies_def] |
|
224 (cterm_of sign (Logic.mk_implies |
|
225 (mk_simp_implies (Logic.mk_equals (x, y)), |
|
226 mk_simp_implies (HOLogic.mk_Trueprop (HOLogic.mk_eq (x, y)))))) |
|
227 (fn hyps => [REPEAT (ares_tac (meta_eq_to_obj_eq :: hyps) 1)]) |
|
228 end |
|
229 end; |
|
230 |
201 (*Congruence rules for = (instead of ==)*) |
231 (*Congruence rules for = (instead of ==)*) |
202 fun mk_meta_cong rl = |
232 fun mk_meta_cong rl = zero_var_indexes |
203 zero_var_indexes(mk_meta_eq(replicate (nprems_of rl) meta_eq_to_obj_eq MRS rl)) |
233 (let val rl' = Seq.hd (TRYALL (fn i => fn st => |
204 handle THM _ => |
234 rtac (lift_meta_eq_to_obj_eq i st) i st) rl) |
205 error("Premises and conclusion of congruence rules must be =-equalities"); |
235 in mk_meta_eq rl' handle THM _ => |
|
236 if Logic.is_equals (concl_of rl') then rl' |
|
237 else error "Conclusion of congruence rules must be =-equality" |
|
238 end); |
206 |
239 |
207 (* Elimination of True from asumptions: *) |
240 (* Elimination of True from asumptions: *) |
208 |
241 |
209 local fun rd s = read_cterm (sign_of (the_context())) (s, propT); |
242 local fun rd s = read_cterm (sign_of (the_context())) (s, propT); |
210 in val True_implies_equals = standard' (equal_intr |
243 in val True_implies_equals = standard' (equal_intr |
261 |
294 |
262 fun mksimps pairs = |
295 fun mksimps pairs = |
263 (List.mapPartial (try mk_eq) o mk_atomize pairs o gen_all); |
296 (List.mapPartial (try mk_eq) o mk_atomize pairs o gen_all); |
264 |
297 |
265 fun unsafe_solver_tac prems = |
298 fun unsafe_solver_tac prems = |
|
299 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
266 FIRST'[resolve_tac(reflexive_thm::TrueI::refl::prems), atac, etac FalseE]; |
300 FIRST'[resolve_tac(reflexive_thm::TrueI::refl::prems), atac, etac FalseE]; |
267 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac; |
301 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac; |
268 |
302 |
269 (*No premature instantiation of variables during simplification*) |
303 (*No premature instantiation of variables during simplification*) |
270 fun safe_solver_tac prems = |
304 fun safe_solver_tac prems = |
|
305 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
271 FIRST'[match_tac(reflexive_thm::TrueI::refl::prems), |
306 FIRST'[match_tac(reflexive_thm::TrueI::refl::prems), |
272 eq_assume_tac, ematch_tac [FalseE]]; |
307 eq_assume_tac, ematch_tac [FalseE]]; |
273 val safe_solver = mk_solver "HOL safe" safe_solver_tac; |
308 val safe_solver = mk_solver "HOL safe" safe_solver_tac; |
274 |
309 |
275 val HOL_basic_ss = |
310 val HOL_basic_ss = |
296 de_Morgan_conj, de_Morgan_disj, imp_disj1, imp_disj2, not_imp, |
331 de_Morgan_conj, de_Morgan_disj, imp_disj1, imp_disj2, not_imp, |
297 disj_not1, not_all, not_ex, cases_simp, |
332 disj_not1, not_all, not_ex, cases_simp, |
298 thm "the_eq_trivial", the_sym_eq_trivial] |
333 thm "the_eq_trivial", the_sym_eq_trivial] |
299 @ ex_simps @ all_simps @ simp_thms) |
334 @ ex_simps @ all_simps @ simp_thms) |
300 addsimprocs [defALL_regroup,defEX_regroup,let_simproc] |
335 addsimprocs [defALL_regroup,defEX_regroup,let_simproc] |
301 addcongs [imp_cong] |
336 addcongs [imp_cong, simp_implies_cong] |
302 addsplits [split_if]; |
337 addsplits [split_if]; |
303 |
338 |
304 fun hol_simplify rews = Simplifier.full_simplify (HOL_basic_ss addsimps rews); |
339 fun hol_simplify rews = Simplifier.full_simplify (HOL_basic_ss addsimps rews); |
305 |
340 |
306 |
341 |