310 else th; |
310 else th; |
311 |
311 |
312 |
312 |
313 (**** Generation of contrapositives ****) |
313 (**** Generation of contrapositives ****) |
314 |
314 |
|
315 fun is_left (Const ("Trueprop", _) $ |
|
316 (Const ("op |", _) $ (Const ("op |", _) $ _ $ _) $ _)) = true |
|
317 | is_left _ = false; |
|
318 |
315 (*Associate disjuctions to right -- make leftmost disjunct a LITERAL*) |
319 (*Associate disjuctions to right -- make leftmost disjunct a LITERAL*) |
316 fun assoc_right th = assoc_right (th RS disj_assoc) |
320 fun assoc_right th = |
317 handle THM _ => th; |
321 if is_left (prop_of th) then assoc_right (th RS disj_assoc) |
|
322 else th; |
318 |
323 |
319 (*Must check for negative literal first!*) |
324 (*Must check for negative literal first!*) |
320 val clause_rules = [disj_assoc, make_neg_rule, make_pos_rule]; |
325 val clause_rules = [disj_assoc, make_neg_rule, make_pos_rule]; |
321 |
326 |
322 (*For ordinary resolution. *) |
327 (*For ordinary resolution. *) |
347 of any argument contains bool.*) |
352 of any argument contains bool.*) |
348 val has_bool_arg_const = |
353 val has_bool_arg_const = |
349 exists_Const |
354 exists_Const |
350 (fn (c,T) => not(is_conn c) andalso exists (has_bool) (binder_types T)); |
355 (fn (c,T) => not(is_conn c) andalso exists (has_bool) (binder_types T)); |
351 |
356 |
352 (*Raises an exception if any Vars in the theorem mention type bool; they |
357 (*Raises an exception if any Vars in the theorem mention type bool. |
353 could cause make_horn to loop! Also rejects functions whose arguments are |
358 Also rejects functions whose arguments are Booleans or other functions.*) |
354 Booleans or other functions.*) |
|
355 fun is_fol_term t = |
359 fun is_fol_term t = |
356 not (exists (has_bool o fastype_of) (term_vars t) orelse |
360 not (exists (has_bool o fastype_of) (term_vars t) orelse |
357 not (Term.is_first_order ["all","All","Ex"] t) orelse |
361 not (Term.is_first_order ["all","All","Ex"] t) orelse |
358 has_bool_arg_const t orelse |
362 has_bool_arg_const t orelse |
359 has_meta_conn t); |
363 has_meta_conn t); |
360 |
364 |
|
365 fun rigid t = not (is_Var (head_of t)); |
|
366 |
|
367 fun ok4horn (Const ("Trueprop",_) $ (Const ("op |", _) $ t $ _)) = rigid t |
|
368 | ok4horn (Const ("Trueprop",_) $ t) = rigid t |
|
369 | ok4horn _ = false; |
|
370 |
361 (*Create a meta-level Horn clause*) |
371 (*Create a meta-level Horn clause*) |
362 fun make_horn crules th = make_horn crules (tryres(th,crules)) |
372 fun make_horn crules th = |
363 handle THM _ => th; |
373 if ok4horn (concl_of th) |
|
374 then make_horn crules (tryres(th,crules)) handle THM _ => th |
|
375 else th; |
364 |
376 |
365 (*Generate Horn clauses for all contrapositives of a clause. The input, th, |
377 (*Generate Horn clauses for all contrapositives of a clause. The input, th, |
366 is a HOL disjunction.*) |
378 is a HOL disjunction.*) |
367 fun add_contras crules (th,hcs) = |
379 fun add_contras crules (th,hcs) = |
368 let fun rots (0,th) = hcs |
380 let fun rots (0,th) = hcs |
432 |
444 |
433 (*Negation Normal Form*) |
445 (*Negation Normal Form*) |
434 val nnf_rls = [imp_to_disjD, iff_to_disjD, not_conjD, not_disjD, |
446 val nnf_rls = [imp_to_disjD, iff_to_disjD, not_conjD, not_disjD, |
435 not_impD, not_iffD, not_allD, not_exD, not_notD]; |
447 not_impD, not_iffD, not_allD, not_exD, not_notD]; |
436 |
448 |
437 fun make_nnf1 th = make_nnf1 (tryres(th, nnf_rls)) |
449 fun ok4nnf (Const ("Trueprop",_) $ (Const ("Not", _) $ t)) = rigid t |
|
450 | ok4nnf (Const ("Trueprop",_) $ t) = rigid t |
|
451 | ok4nnf _ = false; |
|
452 |
|
453 fun make_nnf1 th = |
|
454 if ok4nnf (concl_of th) |
|
455 then make_nnf1 (tryres(th, nnf_rls)) |
438 handle THM _ => |
456 handle THM _ => |
439 forward_res make_nnf1 |
457 forward_res make_nnf1 |
440 (tryres(th, [conj_forward,disj_forward,all_forward,ex_forward])) |
458 (tryres(th, [conj_forward,disj_forward,all_forward,ex_forward])) |
441 handle THM _ => th; |
459 handle THM _ => th |
|
460 else th; |
442 |
461 |
443 (*The simplification removes defined quantifiers and occurrences of True and False. |
462 (*The simplification removes defined quantifiers and occurrences of True and False. |
444 nnf_ss also includes the one-point simprocs, |
463 nnf_ss also includes the one-point simprocs, |
445 which are needed to avoid the various one-point theorems from generating junk clauses.*) |
464 which are needed to avoid the various one-point theorems from generating junk clauses.*) |
446 val nnf_simps = |
465 val nnf_simps = |
453 HOL_basic_ss addsimps nnf_extra_simps |
472 HOL_basic_ss addsimps nnf_extra_simps |
454 addsimprocs [defALL_regroup,defEX_regroup,neq_simproc,let_simproc]; |
473 addsimprocs [defALL_regroup,defEX_regroup,neq_simproc,let_simproc]; |
455 |
474 |
456 fun make_nnf th = case prems_of th of |
475 fun make_nnf th = case prems_of th of |
457 [] => th |> rewrite_rule (map safe_mk_meta_eq nnf_simps) |
476 [] => th |> rewrite_rule (map safe_mk_meta_eq nnf_simps) |
458 |> simplify nnf_ss (*But this doesn't simplify premises...*) |
477 |> simplify nnf_ss |
459 |> make_nnf1 |
478 |> make_nnf1 |
460 | _ => raise THM ("make_nnf: premises in argument", 0, [th]); |
479 | _ => raise THM ("make_nnf: premises in argument", 0, [th]); |
461 |
480 |
462 (*Pull existential quantifiers to front. This accomplishes Skolemization for |
481 (*Pull existential quantifiers to front. This accomplishes Skolemization for |
463 clauses that arise from a subgoal.*) |
482 clauses that arise from a subgoal.*) |
585 fun negated_asm_of_head th = |
604 fun negated_asm_of_head th = |
586 th RS notEfalse handle THM _ => th RS notEfalse'; |
605 th RS notEfalse handle THM _ => th RS notEfalse'; |
587 |
606 |
588 (*Converting one clause*) |
607 (*Converting one clause*) |
589 fun make_meta_clause th = |
608 fun make_meta_clause th = |
590 if is_fol_term (prop_of th) |
609 negated_asm_of_head (make_horn resolution_clause_rules th); |
591 then negated_asm_of_head (make_horn resolution_clause_rules th) |
610 |
592 else raise THM("make_meta_clause", 0, [th]); |
|
593 |
|
594 fun make_meta_clauses ths = |
611 fun make_meta_clauses ths = |
595 name_thms "MClause#" |
612 name_thms "MClause#" |
596 (distinct Drule.eq_thm_prop (map make_meta_clause ths)); |
613 (distinct Drule.eq_thm_prop (map make_meta_clause ths)); |
597 |
614 |
598 (*Permute a rule's premises to move the i-th premise to the last position.*) |
615 (*Permute a rule's premises to move the i-th premise to the last position.*) |