18 fun dest_imp ((c as Const("op -->",_)) $ s $ t) = SOME (c, s, t) |
18 fun dest_imp ((c as Const("op -->",_)) $ s $ t) = SOME (c, s, t) |
19 | dest_imp _ = NONE; |
19 | dest_imp _ = NONE; |
20 val conj = HOLogic.conj |
20 val conj = HOLogic.conj |
21 val imp = HOLogic.imp |
21 val imp = HOLogic.imp |
22 (*rules*) |
22 (*rules*) |
23 val iff_reflection = HOL.eq_reflection |
23 val iff_reflection = thm "eq_reflection" |
24 val iffI = HOL.iffI |
24 val iffI = thm "iffI" |
25 val iff_trans = HOL.trans |
25 val iff_trans = thm "trans" |
26 val conjI= HOL.conjI |
26 val conjI= thm "conjI" |
27 val conjE= HOL.conjE |
27 val conjE= thm "conjE" |
28 val impI = HOL.impI |
28 val impI = thm "impI" |
29 val mp = HOL.mp |
29 val mp = thm "mp" |
30 val uncurry = thm "uncurry" |
30 val uncurry = thm "uncurry" |
31 val exI = HOL.exI |
31 val exI = thm "exI" |
32 val exE = HOL.exE |
32 val exE = thm "exE" |
33 val iff_allI = thm "iff_allI" |
33 val iff_allI = thm "iff_allI" |
34 val iff_exI = thm "iff_exI" |
34 val iff_exI = thm "iff_exI" |
35 val all_comm = thm "all_comm" |
35 val all_comm = thm "all_comm" |
36 val ex_comm = thm "ex_comm" |
36 val ex_comm = thm "ex_comm" |
37 end); |
37 end); |
38 |
38 |
39 structure HOL = |
39 structure Simpdata = |
40 struct |
40 struct |
41 |
41 |
42 open HOL; |
42 local |
43 |
43 val eq_reflection = thm "eq_reflection" |
44 val Eq_FalseI = thm "Eq_FalseI"; |
44 in fun mk_meta_eq r = r RS eq_reflection end; |
45 val Eq_TrueI = thm "Eq_TrueI"; |
|
46 val simp_implies_def = thm "simp_implies_def"; |
|
47 val simp_impliesI = thm "simp_impliesI"; |
|
48 |
|
49 fun mk_meta_eq r = r RS eq_reflection; |
|
50 fun safe_mk_meta_eq r = mk_meta_eq r handle Thm.THM _ => r; |
45 fun safe_mk_meta_eq r = mk_meta_eq r handle Thm.THM _ => r; |
51 |
46 |
52 fun mk_eq thm = case concl_of thm |
47 local |
|
48 val Eq_FalseI = thm "Eq_FalseI" |
|
49 val Eq_TrueI = thm "Eq_TrueI" |
|
50 in fun mk_eq th = case concl_of th |
53 (*expects Trueprop if not == *) |
51 (*expects Trueprop if not == *) |
54 of Const ("==",_) $ _ $ _ => thm |
52 of Const ("==",_) $ _ $ _ => th |
55 | _ $ (Const ("op =", _) $ _ $ _) => mk_meta_eq thm |
53 | _ $ (Const ("op =", _) $ _ $ _) => mk_meta_eq th |
56 | _ $ (Const ("Not", _) $ _) => thm RS Eq_FalseI |
54 | _ $ (Const ("Not", _) $ _) => th RS Eq_FalseI |
57 | _ => thm RS Eq_TrueI; |
55 | _ => th RS Eq_TrueI |
58 |
56 end; |
59 fun mk_eq_True r = |
57 |
|
58 local |
|
59 val meta_eq_to_obj_eq = thm "meta_eq_to_obj_eq" |
|
60 val Eq_TrueI = thm "Eq_TrueI" |
|
61 in fun mk_eq_True r = |
60 SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE; |
62 SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE; |
|
63 end; |
61 |
64 |
62 (* Produce theorems of the form |
65 (* Produce theorems of the form |
63 (P1 =simp=> ... =simp=> Pn => x == y) ==> (P1 =simp=> ... =simp=> Pn => x = y) |
66 (P1 =simp=> ... =simp=> Pn => x == y) ==> (P1 =simp=> ... =simp=> Pn => x = y) |
64 *) |
67 *) |
65 fun lift_meta_eq_to_obj_eq i st = |
68 local |
|
69 val meta_eq_to_obj_eq = thm "meta_eq_to_obj_eq" |
|
70 val simp_implies_def = thm "simp_implies_def" |
|
71 in fun lift_meta_eq_to_obj_eq i st = |
66 let |
72 let |
67 fun count_imp (Const ("HOL.simp_implies", _) $ P $ Q) = 1 + count_imp Q |
73 fun count_imp (Const ("HOL.simp_implies", _) $ P $ Q) = 1 + count_imp Q |
68 | count_imp _ = 0; |
74 | count_imp _ = 0; |
69 val j = count_imp (Logic.strip_assums_concl (List.nth (prems_of st, i - 1))) |
75 val j = count_imp (Logic.strip_assums_concl (List.nth (prems_of st, i - 1))) |
70 in if j = 0 then meta_eq_to_obj_eq |
76 in if j = 0 then meta_eq_to_obj_eq |
114 in atoms end; |
121 in atoms end; |
115 |
122 |
116 fun mksimps pairs = |
123 fun mksimps pairs = |
117 map_filter (try mk_eq) o mk_atomize pairs o gen_all; |
124 map_filter (try mk_eq) o mk_atomize pairs o gen_all; |
118 |
125 |
119 fun unsafe_solver_tac prems = |
126 local |
|
127 val simp_impliesI = thm "simp_impliesI" |
|
128 val TrueI = thm "TrueI" |
|
129 val FalseE = thm "FalseE" |
|
130 val refl = thm "refl" |
|
131 in fun unsafe_solver_tac prems = |
120 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
132 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
121 FIRST'[resolve_tac(reflexive_thm :: TrueI :: refl :: prems), atac, etac FalseE]; |
133 FIRST'[resolve_tac(reflexive_thm :: TrueI :: refl :: prems), atac, etac FalseE]; |
|
134 end; |
122 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac; |
135 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac; |
123 |
136 |
124 (*No premature instantiation of variables during simplification*) |
137 (*No premature instantiation of variables during simplification*) |
125 fun safe_solver_tac prems = |
138 local |
|
139 val simp_impliesI = thm "simp_impliesI" |
|
140 val TrueI = thm "TrueI" |
|
141 val FalseE = thm "FalseE" |
|
142 val refl = thm "refl" |
|
143 in fun safe_solver_tac prems = |
126 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
144 (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN' |
127 FIRST'[match_tac(reflexive_thm :: TrueI :: refl :: prems), |
145 FIRST'[match_tac(reflexive_thm :: TrueI :: refl :: prems), |
128 eq_assume_tac, ematch_tac [FalseE]]; |
146 eq_assume_tac, ematch_tac [FalseE]]; |
|
147 end; |
129 val safe_solver = mk_solver "HOL safe" safe_solver_tac; |
148 val safe_solver = mk_solver "HOL safe" safe_solver_tac; |
130 |
|
131 end; |
|
132 |
149 |
133 structure SplitterData = |
150 structure SplitterData = |
134 struct |
151 struct |
135 structure Simplifier = Simplifier |
152 structure Simplifier = Simplifier |
136 val mk_eq = HOL.mk_eq |
153 val mk_eq = mk_eq |
137 val meta_eq_to_iff = HOL.meta_eq_to_obj_eq |
154 val meta_eq_to_iff = thm "meta_eq_to_obj_eq" |
138 val iffD = HOL.iffD2 |
155 val iffD = thm "iffD2" |
139 val disjE = HOL.disjE |
156 val disjE = thm "disjE" |
140 val conjE = HOL.conjE |
157 val conjE = thm "conjE" |
141 val exE = HOL.exE |
158 val exE = thm "exE" |
142 val contrapos = HOL.contrapos_nn |
159 val contrapos = thm "contrapos_nn" |
143 val contrapos2 = HOL.contrapos_pp |
160 val contrapos2 = thm "contrapos_pp" |
144 val notnotD = HOL.notnotD |
161 val notnotD = thm "notnotD" |
145 end; |
162 end; |
146 |
163 |
147 structure Splitter = SplitterFun(SplitterData); |
164 structure Splitter = SplitterFun(SplitterData); |
148 |
|
149 |
165 |
150 (* integration of simplifier with classical reasoner *) |
166 (* integration of simplifier with classical reasoner *) |
151 |
167 |
152 structure Clasimp = ClasimpFun |
168 structure Clasimp = ClasimpFun |
153 (structure Simplifier = Simplifier and Splitter = Splitter |
169 (structure Simplifier = Simplifier and Splitter = Splitter |
154 and Classical = Classical and Blast = Blast |
170 and Classical = Classical and Blast = Blast |
155 val iffD1 = HOL.iffD1 val iffD2 = HOL.iffD2 val notE = HOL.notE); |
171 val iffD1 = thm "iffD1" val iffD2 = thm "iffD2" val notE = thm "notE"); |
156 |
|
157 structure HOL = |
|
158 struct |
|
159 |
|
160 open HOL; |
|
161 |
172 |
162 val mksimps_pairs = |
173 val mksimps_pairs = |
163 [("op -->", [mp]), ("op &", [thm "conjunct1", thm "conjunct2"]), |
174 [("op -->", [thm "mp"]), ("op &", [thm "conjunct1", thm "conjunct2"]), |
164 ("All", [spec]), ("True", []), ("False", []), |
175 ("All", [thm "spec"]), ("True", []), ("False", []), |
165 ("HOL.If", [thm "if_bool_eq_conj" RS iffD1])]; |
176 ("HOL.If", [thm "if_bool_eq_conj" RS thm "iffD1"])]; |
166 |
177 |
167 val simpset_basic = |
178 val simpset_basic = |
168 Simplifier.theory_context (the_context ()) empty_ss |
179 Simplifier.theory_context (the_context ()) empty_ss |
169 setsubgoaler asm_simp_tac |
180 setsubgoaler asm_simp_tac |
170 setSSolver safe_solver |
181 setSSolver safe_solver |
215 |
226 |
216 local |
227 local |
217 val thy = the_context (); |
228 val thy = the_context (); |
218 val Let_folded = thm "Let_folded"; |
229 val Let_folded = thm "Let_folded"; |
219 val Let_unfold = thm "Let_unfold"; |
230 val Let_unfold = thm "Let_unfold"; |
|
231 val Let_def = thm "Let_def"; |
220 val (f_Let_unfold, x_Let_unfold) = |
232 val (f_Let_unfold, x_Let_unfold) = |
221 let val [(_$(f$x)$_)] = prems_of Let_unfold |
233 let val [(_$(f$x)$_)] = prems_of Let_unfold |
222 in (cterm_of thy f, cterm_of thy x) end |
234 in (cterm_of thy f, cterm_of thy x) end |
223 val (f_Let_folded, x_Let_folded) = |
235 val (f_Let_folded, x_Let_folded) = |
224 let val [(_$(f$x)$_)] = prems_of Let_folded |
236 let val [(_$(f$x)$_)] = prems_of Let_folded |
234 val ([t'], ctxt') = Variable.import_terms false [t] ctxt; |
246 val ([t'], ctxt') = Variable.import_terms false [t] ctxt; |
235 in Option.map (hd o Variable.export ctxt' ctxt o single) |
247 in Option.map (hd o Variable.export ctxt' ctxt o single) |
236 (case t' of (Const ("Let",_)$x$f) => (* x and f are already in normal form *) |
248 (case t' of (Const ("Let",_)$x$f) => (* x and f are already in normal form *) |
237 if not (!use_let_simproc) then NONE |
249 if not (!use_let_simproc) then NONE |
238 else if is_Free x orelse is_Bound x orelse is_Const x |
250 else if is_Free x orelse is_Bound x orelse is_Const x |
239 then SOME (thm "Let_def") |
251 then SOME Let_def |
240 else |
252 else |
241 let |
253 let |
242 val n = case f of (Abs (x,_,_)) => x | _ => "x"; |
254 val n = case f of (Abs (x,_,_)) => x | _ => "x"; |
243 val cx = cterm_of sg x; |
255 val cx = cterm_of sg x; |
244 val {T=xT,...} = rep_cterm cx; |
256 val {T=xT,...} = rep_cterm cx; |
287 [| A1; ...; An |] ==> False |
299 [| A1; ...; An |] ==> False |
288 where the Ai are atomic, i.e. no top-level &, | or EX |
300 where the Ai are atomic, i.e. no top-level &, | or EX |
289 *) |
301 *) |
290 |
302 |
291 local |
303 local |
|
304 val conjE = thm "conjE" |
|
305 val exE = thm "exE" |
|
306 val disjE = thm "disjE" |
|
307 val notE = thm "notE" |
|
308 val rev_mp = thm "rev_mp" |
|
309 val ccontr = thm "ccontr" |
292 val nnf_simpset = |
310 val nnf_simpset = |
293 empty_ss setmkeqTrue mk_eq_True |
311 empty_ss setmkeqTrue mk_eq_True |
294 setmksimps (mksimps mksimps_pairs) |
312 setmksimps (mksimps mksimps_pairs) |
295 addsimps [thm "imp_conv_disj", thm "iff_conv_conj_imp", thm "de_Morgan_disj", thm "de_Morgan_conj", |
313 addsimps [thm "imp_conv_disj", thm "iff_conv_conj_imp", thm "de_Morgan_disj", thm "de_Morgan_conj", |
296 thm "not_all", thm "not_ex", thm "not_not"]; |
314 thm "not_all", thm "not_ex", thm "not_not"]; |