TFL/rules.ML
changeset 11669 4f7ad093b413
parent 11632 6fc8de600f58
child 14643 130076a81b84
equal deleted inserted replaced
11668:548ba68385a3 11669:4f7ad093b413
    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