equal
deleted
inserted
replaced
49 |
49 |
50 val rbeta : thm -> thm |
50 val rbeta : thm -> thm |
51 (* For debugging my isabelle solver in the conditional rewriter *) |
51 (* For debugging my isabelle solver in the conditional rewriter *) |
52 val term_ref : term list ref |
52 val term_ref : term list ref |
53 val thm_ref : thm list ref |
53 val thm_ref : thm list ref |
54 val mss_ref : meta_simpset list ref |
54 val mss_ref : MetaSimplifier.meta_simpset list ref |
55 val tracing : bool ref |
55 val tracing : bool ref |
56 val CONTEXT_REWRITE_RULE : term * term list * thm * thm list |
56 val CONTEXT_REWRITE_RULE : term * term list * thm * thm list |
57 -> thm -> thm * term list |
57 -> thm -> thm * term list |
58 val RIGHT_ASSOC : thm -> thm |
58 val RIGHT_ASSOC : thm -> thm |
59 |
59 |
544 |
544 |
545 (*--------------------------------------------------------------------------- |
545 (*--------------------------------------------------------------------------- |
546 * Trace information for the rewriter |
546 * Trace information for the rewriter |
547 *---------------------------------------------------------------------------*) |
547 *---------------------------------------------------------------------------*) |
548 val term_ref = ref[] : term list ref |
548 val term_ref = ref[] : term list ref |
549 val mss_ref = ref [] : meta_simpset list ref; |
549 val mss_ref = ref [] : MetaSimplifier.meta_simpset list ref; |
550 val thm_ref = ref [] : thm list ref; |
550 val thm_ref = ref [] : thm list ref; |
551 val tracing = ref false; |
551 val tracing = ref false; |
552 |
552 |
553 fun say s = if !tracing then writeln s else (); |
553 fun say s = if !tracing then writeln s else (); |
554 |
554 |
672 val dummy = mss_ref := [] |
672 val dummy = mss_ref := [] |
673 val cut_lemma' = cut_lemma RS eq_reflection |
673 val cut_lemma' = cut_lemma RS eq_reflection |
674 fun prover used mss thm = |
674 fun prover used mss thm = |
675 let fun cong_prover mss thm = |
675 let fun cong_prover mss thm = |
676 let val dummy = say "cong_prover:" |
676 let val dummy = say "cong_prover:" |
677 val cntxt = prems_of_mss mss |
677 val cntxt = MetaSimplifier.prems_of_mss mss |
678 val dummy = print_thms "cntxt:" cntxt |
678 val dummy = print_thms "cntxt:" cntxt |
679 val dummy = say "cong rule:" |
679 val dummy = say "cong rule:" |
680 val dummy = say (string_of_thm thm) |
680 val dummy = say (string_of_thm thm) |
681 val dummy = thm_ref := (thm :: !thm_ref) |
681 val dummy = thm_ref := (thm :: !thm_ref) |
682 val dummy = mss_ref := (mss :: !mss_ref) |
682 val dummy = mss_ref := (mss :: !mss_ref) |
685 let val tych = cterm_of sign |
685 let val tych = cterm_of sign |
686 val dummy = print_cterms "To eliminate:" [tych imp] |
686 val dummy = print_cterms "To eliminate:" [tych imp] |
687 val ants = map tych (Logic.strip_imp_prems imp) |
687 val ants = map tych (Logic.strip_imp_prems imp) |
688 val eq = Logic.strip_imp_concl imp |
688 val eq = Logic.strip_imp_concl imp |
689 val lhs = tych(get_lhs eq) |
689 val lhs = tych(get_lhs eq) |
690 val mss' = add_prems(mss, map ASSUME ants) |
690 val mss' = MetaSimplifier.add_prems(mss, map ASSUME ants) |
691 val lhs_eq_lhs1 = MetaSimplifier.rewrite_cterm (false,true,false) (prover used) mss' lhs |
691 val lhs_eq_lhs1 = MetaSimplifier.rewrite_cterm (false,true,false) (prover used) mss' lhs |
692 handle U.ERR _ => Thm.reflexive lhs |
692 handle U.ERR _ => Thm.reflexive lhs |
693 val dummy = print_thms "proven:" [lhs_eq_lhs1] |
693 val dummy = print_thms "proven:" [lhs_eq_lhs1] |
694 val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1 |
694 val lhs_eq_lhs2 = implies_intr_list ants lhs_eq_lhs1 |
695 val lhs_eeq_lhs2 = lhs_eq_lhs2 RS meta_eq_to_obj_eq |
695 val lhs_eeq_lhs2 = lhs_eq_lhs2 RS meta_eq_to_obj_eq |
707 val ants1 = map tych (Logic.strip_imp_prems imp_body1) |
707 val ants1 = map tych (Logic.strip_imp_prems imp_body1) |
708 val eq1 = Logic.strip_imp_concl imp_body1 |
708 val eq1 = Logic.strip_imp_concl imp_body1 |
709 val Q = get_lhs eq1 |
709 val Q = get_lhs eq1 |
710 val QeqQ1 = pbeta_reduce (tych Q) |
710 val QeqQ1 = pbeta_reduce (tych Q) |
711 val Q1 = #2(D.dest_eq(cconcl QeqQ1)) |
711 val Q1 = #2(D.dest_eq(cconcl QeqQ1)) |
712 val mss' = add_prems(mss, map ASSUME ants1) |
712 val mss' = MetaSimplifier.add_prems(mss, map ASSUME ants1) |
713 val Q1eeqQ2 = MetaSimplifier.rewrite_cterm (false,true,false) (prover used') mss' Q1 |
713 val Q1eeqQ2 = MetaSimplifier.rewrite_cterm (false,true,false) (prover used') mss' Q1 |
714 handle U.ERR _ => Thm.reflexive Q1 |
714 handle U.ERR _ => Thm.reflexive Q1 |
715 val Q2 = #2 (Logic.dest_equals (#prop(rep_thm Q1eeqQ2))) |
715 val Q2 = #2 (Logic.dest_equals (#prop(rep_thm Q1eeqQ2))) |
716 val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl)) |
716 val Q3 = tych(list_comb(list_mk_aabs(vstrl,Q2),vstrl)) |
717 val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection) |
717 val Q2eeqQ3 = Thm.symmetric(pbeta_reduce Q3 RS eq_reflection) |
732 in if (pbeta_redex Q) (length vlist) |
732 in if (pbeta_redex Q) (length vlist) |
733 then pq_eliminate (thm,sign,vlist,imp_body,Q) |
733 then pq_eliminate (thm,sign,vlist,imp_body,Q) |
734 else |
734 else |
735 let val tych = cterm_of sign |
735 let val tych = cterm_of sign |
736 val ants1 = map tych ants |
736 val ants1 = map tych ants |
737 val mss' = add_prems(mss, map ASSUME ants1) |
737 val mss' = MetaSimplifier.add_prems(mss, map ASSUME ants1) |
738 val Q_eeq_Q1 = MetaSimplifier.rewrite_cterm |
738 val Q_eeq_Q1 = MetaSimplifier.rewrite_cterm |
739 (false,true,false) (prover used') mss' (tych Q) |
739 (false,true,false) (prover used') mss' (tych Q) |
740 handle U.ERR _ => Thm.reflexive (tych Q) |
740 handle U.ERR _ => Thm.reflexive (tych Q) |
741 val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1 |
741 val lhs_eeq_lhs2 = implies_intr_list ants1 Q_eeq_Q1 |
742 val lhs_eq_lhs2 = lhs_eeq_lhs2 RS meta_eq_to_obj_eq |
742 val lhs_eq_lhs2 = lhs_eeq_lhs2 RS meta_eq_to_obj_eq |
757 in Some(eliminate (rename thm)) end |
757 in Some(eliminate (rename thm)) end |
758 handle U.ERR _ => None (* FIXME handle THM as well?? *) |
758 handle U.ERR _ => None (* FIXME handle THM as well?? *) |
759 |
759 |
760 fun restrict_prover mss thm = |
760 fun restrict_prover mss thm = |
761 let val dummy = say "restrict_prover:" |
761 let val dummy = say "restrict_prover:" |
762 val cntxt = rev(prems_of_mss mss) |
762 val cntxt = rev(MetaSimplifier.prems_of_mss mss) |
763 val dummy = print_thms "cntxt:" cntxt |
763 val dummy = print_thms "cntxt:" cntxt |
764 val {prop = Const("==>",_) $ (Const("Trueprop",_) $ A) $ _, |
764 val {prop = Const("==>",_) $ (Const("Trueprop",_) $ A) $ _, |
765 sign,...} = rep_thm thm |
765 sign,...} = rep_thm thm |
766 fun genl tm = let val vlist = gen_rems (op aconv) |
766 fun genl tm = let val vlist = gen_rems (op aconv) |
767 (add_term_frees(tm,[]), globals) |
767 (add_term_frees(tm,[]), globals) |
804 (if (is_cong thm) then cong_prover else restrict_prover) mss thm |
804 (if (is_cong thm) then cong_prover else restrict_prover) mss thm |
805 end |
805 end |
806 val ctm = cprop_of th |
806 val ctm = cprop_of th |
807 val names = add_term_names (term_of ctm, []) |
807 val names = add_term_names (term_of ctm, []) |
808 val th1 = MetaSimplifier.rewrite_cterm(false,true,false) |
808 val th1 = MetaSimplifier.rewrite_cterm(false,true,false) |
809 (prover names) (add_congs(mss_of [cut_lemma'], congs)) ctm |
809 (prover names) (MetaSimplifier.add_congs(MetaSimplifier.mss_of [cut_lemma'], congs)) ctm |
810 val th2 = equal_elim th1 th |
810 val th2 = equal_elim th1 th |
811 in |
811 in |
812 (th2, filter (not o restricted) (!tc_list)) |
812 (th2, filter (not o restricted) (!tc_list)) |
813 end; |
813 end; |
814 |
814 |