31 structure ResAxioms : RES_AXIOMS = |
29 structure ResAxioms : RES_AXIOMS = |
32 |
30 |
33 struct |
31 struct |
34 |
32 |
35 |
33 |
36 val tagging_enabled = false (*compile_time option*) |
|
37 |
|
38 (**** Transformation of Elimination Rules into First-Order Formulas****) |
34 (**** Transformation of Elimination Rules into First-Order Formulas****) |
39 |
35 |
40 (* a tactic used to prove an elim-rule. *) |
36 (* a tactic used to prove an elim-rule. *) |
41 fun elimRule_tac th = |
37 fun elimRule_tac th = |
42 ((rtac impI 1) ORELSE (rtac notI 1)) THEN (etac th 1) THEN |
38 (resolve_tac [impI,notI] 1) THEN (etac th 1) THEN REPEAT(blast_tac HOL_cs 1); |
43 REPEAT(fast_tac HOL_cs 1); |
|
44 |
|
45 exception ELIMR2FOL of string; |
|
46 |
39 |
47 fun add_EX tm [] = tm |
40 fun add_EX tm [] = tm |
48 | add_EX tm ((x,xtp)::xs) = add_EX (HOLogic.exists_const xtp $ Abs(x,xtp,tm)) xs; |
41 | add_EX tm ((x,xtp)::xs) = add_EX (HOLogic.exists_const xtp $ Abs(x,xtp,tm)) xs; |
49 |
42 |
50 (*Checks for the premise ~P when the conclusion is P.*) |
43 (*Checks for the premise ~P when the conclusion is P.*) |
51 fun is_neg (Const("Trueprop",_) $ (Const("Not",_) $ Free(p,_))) |
44 fun is_neg (Const("Trueprop",_) $ (Const("Not",_) $ Free(p,_))) |
52 (Const("Trueprop",_) $ Free(q,_)) = (p = q) |
45 (Const("Trueprop",_) $ Free(q,_)) = (p = q) |
53 | is_neg _ _ = false; |
46 | is_neg _ _ = false; |
54 |
47 |
55 (*FIXME: What if dest_Trueprop fails?*) |
48 exception ELIMR2FOL; |
|
49 |
|
50 (*Handles the case where the dummy "conclusion" variable appears negated in the |
|
51 premises, so the final consequent must be kept.*) |
56 fun strip_concl' prems bvs (Const ("==>",_) $ P $ Q) = |
52 fun strip_concl' prems bvs (Const ("==>",_) $ P $ Q) = |
57 strip_concl' (HOLogic.dest_Trueprop P :: prems) bvs Q |
53 strip_concl' (HOLogic.dest_Trueprop P :: prems) bvs Q |
58 | strip_concl' prems bvs P = |
54 | strip_concl' prems bvs P = |
59 let val P' = HOLogic.Not $ (HOLogic.dest_Trueprop P) |
55 let val P' = HOLogic.Not $ (HOLogic.dest_Trueprop P) |
60 in add_EX (foldr1 HOLogic.mk_conj (P'::prems)) bvs end; |
56 in add_EX (foldr1 HOLogic.mk_conj (P'::prems)) bvs end; |
61 |
57 |
|
58 (*Recurrsion over the minor premise of an elimination rule. Final consequent |
|
59 is ignored, as it is the dummy "conclusion" variable.*) |
62 fun strip_concl prems bvs concl (Const ("all", _) $ Abs (x,xtp,body)) = |
60 fun strip_concl prems bvs concl (Const ("all", _) $ Abs (x,xtp,body)) = |
63 strip_concl prems ((x,xtp)::bvs) concl body |
61 strip_concl prems ((x,xtp)::bvs) concl body |
64 | strip_concl prems bvs concl (Const ("==>",_) $ P $ Q) = |
62 | strip_concl prems bvs concl (Const ("==>",_) $ P $ Q) = |
65 if (is_neg P concl) then (strip_concl' prems bvs Q) |
63 if (is_neg P concl) then (strip_concl' prems bvs Q) |
66 else strip_concl (HOLogic.dest_Trueprop P::prems) bvs concl Q |
64 else strip_concl (HOLogic.dest_Trueprop P::prems) bvs concl Q |
67 | strip_concl prems bvs concl _ = add_EX (foldr1 HOLogic.mk_conj prems) bvs; |
65 | strip_concl prems bvs concl Q = |
|
66 if concl aconv Q then add_EX (foldr1 HOLogic.mk_conj prems) bvs |
|
67 else raise ELIMR2FOL (*expected conclusion not found!*) |
68 |
68 |
69 fun trans_elim (major,minors,concl) = |
69 fun trans_elim (major,[],_) = HOLogic.Not $ major |
70 let val disjs = foldr1 HOLogic.mk_disj (map (strip_concl [] [] concl) minors) |
70 | trans_elim (major,minors,concl) = |
71 in |
71 let val disjs = foldr1 HOLogic.mk_disj (map (strip_concl [] [] concl) minors) |
72 HOLogic.mk_imp (HOLogic.dest_Trueprop major, disjs) |
72 in HOLogic.mk_imp (major, disjs) end; |
73 end; |
|
74 |
73 |
75 (* convert an elim rule into an equivalent formula, of type term. *) |
74 (* convert an elim rule into an equivalent formula, of type term. *) |
76 fun elimR2Fol elimR = |
75 fun elimR2Fol elimR = |
77 let val elimR' = Drule.freeze_all elimR |
76 let val elimR' = Drule.freeze_all elimR |
78 val (prems,concl) = (prems_of elimR', concl_of elimR') |
77 val (prems,concl) = (prems_of elimR', concl_of elimR') |
79 val _ = case concl of |
78 val cv = case concl of (*conclusion variable*) |
80 Const("Trueprop",_) $ Free(_,Type("bool",[])) => () |
79 Const("Trueprop",_) $ (v as Free(_,Type("bool",[]))) => v |
81 | Free(_, Type("prop",[])) => () |
80 | v as Free(_, Type("prop",[])) => v |
82 | _ => raise ELIMR2FOL "elimR2Fol: Not an elimination rule!" |
81 | _ => raise ELIMR2FOL |
83 val th = case prems of |
82 in case prems of |
84 [] => raise ELIMR2FOL "elimR2Fol: No premises!" |
83 [] => raise ELIMR2FOL |
85 | [major] => HOLogic.Not $ (HOLogic.dest_Trueprop major) |
84 | (Const("Trueprop",_) $ major) :: minors => |
86 | major::minors => trans_elim (major, minors, concl) |
85 if member (op aconv) (term_frees major) cv then raise ELIMR2FOL |
87 in HOLogic.mk_Trueprop th end |
86 else (trans_elim (major, minors, concl) handle TERM _ => raise ELIMR2FOL) |
88 handle exn => |
87 | _ => raise ELIMR2FOL |
89 (warning ("elimR2Fol raised exception " ^ Toplevel.exn_message exn); |
88 end; |
90 concl_of elimR); |
|
91 |
|
92 (* check if a rule is an elim rule *) |
|
93 fun is_elimR th = |
|
94 case concl_of th of Const ("Trueprop", _) $ Var _ => true |
|
95 | Var(_,Type("prop",[])) => true |
|
96 | _ => false; |
|
97 |
89 |
98 (* convert an elim-rule into an equivalent theorem that does not have the |
90 (* convert an elim-rule into an equivalent theorem that does not have the |
99 predicate variable. Leave other theorems unchanged.*) |
91 predicate variable. Leave other theorems unchanged.*) |
100 fun transform_elim th = |
92 fun transform_elim th = |
101 if is_elimR th then |
93 let val ctm = cterm_of (sign_of_thm th) (HOLogic.mk_Trueprop (elimR2Fol th)) |
102 let val ctm = cterm_of (sign_of_thm th) (elimR2Fol th) |
|
103 in Goal.prove_raw [] ctm (fn _ => elimRule_tac th) end |
94 in Goal.prove_raw [] ctm (fn _ => elimRule_tac th) end |
104 handle exn => (warning ("transform_elim failed: " ^ Toplevel.exn_message exn ^ |
95 handle ELIMR2FOL => th (*not an elimination rule*) |
105 " for theorem " ^ string_of_thm th); th) |
96 | exn => (warning ("transform_elim failed: " ^ Toplevel.exn_message exn ^ |
106 else th; |
97 " for theorem " ^ string_of_thm th); th) |
|
98 |
107 |
99 |
108 |
100 |
109 (**** Transformation of Clasets and Simpsets into First-Order Axioms ****) |
101 (**** Transformation of Clasets and Simpsets into First-Order Axioms ****) |
110 |
102 |
111 |
103 |
155 (*Universal quant: insert a free variable into body and continue*) |
147 (*Universal quant: insert a free variable into body and continue*) |
156 let val fname = variant (add_term_names (p,[])) a |
148 let val fname = variant (add_term_names (p,[])) a |
157 in dec_sko (subst_bound (Free(fname,T), p)) (n, thx) end |
149 in dec_sko (subst_bound (Free(fname,T), p)) (n, thx) end |
158 | dec_sko (Const ("op &", _) $ p $ q) nthy = dec_sko q (dec_sko p nthy) |
150 | dec_sko (Const ("op &", _) $ p $ q) nthy = dec_sko q (dec_sko p nthy) |
159 | dec_sko (Const ("op |", _) $ p $ q) nthy = dec_sko q (dec_sko p nthy) |
151 | dec_sko (Const ("op |", _) $ p $ q) nthy = dec_sko q (dec_sko p nthy) |
160 | dec_sko (Const ("HOL.tag", _) $ p) nthy = dec_sko p nthy |
|
161 | dec_sko (Const ("Trueprop", _) $ p) nthy = dec_sko p nthy |
152 | dec_sko (Const ("Trueprop", _) $ p) nthy = dec_sko p nthy |
162 | dec_sko t nthx = nthx (*Do nothing otherwise*) |
153 | dec_sko t nthx = nthx (*Do nothing otherwise*) |
163 in #2 (dec_sko (#prop (rep_thm th)) (1, (thy,[]))) end; |
154 in #2 (dec_sko (#prop (rep_thm th)) (1, (thy,[]))) end; |
164 |
155 |
165 (*Traverse a theorem, accumulating Skolem function definitions.*) |
156 (*Traverse a theorem, accumulating Skolem function definitions.*) |
303 (**** Extract and Clausify theorems from a theory's claset and simpset ****) |
293 (**** Extract and Clausify theorems from a theory's claset and simpset ****) |
304 |
294 |
305 (*Preserve the name of "th" after the transformation "f"*) |
295 (*Preserve the name of "th" after the transformation "f"*) |
306 fun preserve_name f th = Thm.name_thm (Thm.name_of_thm th, f th); |
296 fun preserve_name f th = Thm.name_thm (Thm.name_of_thm th, f th); |
307 |
297 |
308 (*Tags identify the major premise or conclusion, as hints to resolution provers. |
|
309 However, they don't appear to help in recent tests, and they complicate the code.*) |
|
310 val tagI = thm "tagI"; |
|
311 val tagD = thm "tagD"; |
|
312 |
|
313 val tag_intro = preserve_name (fn th => th RS tagI); |
|
314 val tag_elim = preserve_name (fn th => tagD RS th); |
|
315 |
|
316 fun rules_of_claset cs = |
298 fun rules_of_claset cs = |
317 let val {safeIs,safeEs,hazIs,hazEs,...} = rep_cs cs |
299 let val {safeIs,safeEs,hazIs,hazEs,...} = rep_cs cs |
318 val intros = safeIs @ hazIs |
300 val intros = safeIs @ hazIs |
319 val elims = map Classical.classical_rule (safeEs @ hazEs) |
301 val elims = map Classical.classical_rule (safeEs @ hazEs) |
320 in |
302 in |
321 Output.debug ("rules_of_claset intros: " ^ Int.toString(length intros) ^ |
303 Output.debug ("rules_of_claset intros: " ^ Int.toString(length intros) ^ |
322 " elims: " ^ Int.toString(length elims)); |
304 " elims: " ^ Int.toString(length elims)); |
323 if tagging_enabled |
305 map pairname (intros @ elims) |
324 then map pairname (map tag_intro intros @ map tag_elim elims) |
|
325 else map pairname (intros @ elims) |
|
326 end; |
306 end; |
327 |
307 |
328 fun rules_of_simpset ss = |
308 fun rules_of_simpset ss = |
329 let val ({rules,...}, _) = rep_ss ss |
309 let val ({rules,...}, _) = rep_ss ss |
330 val simps = Net.entries rules |
310 val simps = Net.entries rules |