609 (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th) |
609 (fn () => "ISABELLE THM: " ^ Display.string_of_thm ctxt th) |
610 val _ = trace_msg ctxt |
610 val _ = trace_msg ctxt |
611 (fn () => "=============================================") |
611 (fn () => "=============================================") |
612 in (fol_th, th) :: thpairs end |
612 in (fol_th, th) :: thpairs end |
613 |
613 |
614 fun term_instantiate thy = cterm_instantiate o map (pairself (cterm_of thy)) |
614 (* It is normally sufficient to apply "assume_tac" to unify the conclusion with |
|
615 one of the premises. Unfortunately, this sometimes yields "Variable |
|
616 ?SK_a_b_c_x has two distinct types" errors. To avoid this, we instantiate the |
|
617 variables before applying "assume_tac". Typical constraints are of the form |
|
618 ?SK_a_b_c_x SK_d_e_f_y ... SK_a_b_c_x ... SK_g_h_i_z =?= SK_a_b_c_x, |
|
619 where the nonvariables are goal parameters. *) |
|
620 fun unify_first_prem_with_concl thy i th = |
|
621 let |
|
622 val goal = Logic.get_goal (prop_of th) i |> Envir.beta_eta_contract |
|
623 val prem = goal |> Logic.strip_assums_hyp |> hd |
|
624 val concl = goal |> Logic.strip_assums_concl |
|
625 fun pair_untyped_aconv (t1, t2) (u1, u2) = |
|
626 untyped_aconv t1 u1 andalso untyped_aconv t2 u2 |
|
627 fun add_terms tp inst = |
|
628 if exists (pair_untyped_aconv tp) inst then inst |
|
629 else tp :: map (apsnd (subst_atomic [tp])) inst |
|
630 fun is_flex t = |
|
631 case strip_comb t of |
|
632 (Var _, args) => forall is_Bound args |
|
633 | _ => false |
|
634 fun unify_flex flex rigid = |
|
635 case strip_comb flex of |
|
636 (Var (z as (_, T)), args) => |
|
637 add_terms (Var z, |
|
638 fold_rev (curry absdummy) (take (length args) (binder_types T)) rigid) |
|
639 | _ => I |
|
640 fun unify_potential_flex comb atom = |
|
641 if is_flex comb then unify_flex comb atom |
|
642 else if is_Var atom then add_terms (atom, comb) |
|
643 else I |
|
644 fun unify_terms (t, u) = |
|
645 case (t, u) of |
|
646 (t1 $ t2, u1 $ u2) => |
|
647 if is_flex t then unify_flex t u |
|
648 else if is_flex u then unify_flex u t |
|
649 else fold unify_terms [(t1, u1), (t2, u2)] |
|
650 | (_ $ _, _) => unify_potential_flex t u |
|
651 | (_, _ $ _) => unify_potential_flex u t |
|
652 | (Var _, _) => add_terms (t, u) |
|
653 | (_, Var _) => add_terms (u, t) |
|
654 | _ => I |
|
655 val t_inst = [] |> unify_terms (prem, concl) |
|
656 |> map (pairself (cterm_of thy)) |
|
657 in th |> cterm_instantiate t_inst end |
615 |
658 |
616 val copy_prem = @{lemma "P ==> (P ==> P ==> Q) ==> Q" by fast} |
659 val copy_prem = @{lemma "P ==> (P ==> P ==> Q) ==> Q" by fast} |
617 |
660 |
618 fun copy_prems_tac [] ns i = |
661 fun copy_prems_tac [] ns i = |
619 if forall (curry (op =) 1) ns then all_tac else copy_prems_tac (rev ns) [] i |
662 if forall (curry (op =) 1) ns then all_tac else copy_prems_tac (rev ns) [] i |
661 Vartab.fold (fn (x, (S, T)) => |
704 Vartab.fold (fn (x, (S, T)) => |
662 cons (pairself (ctyp_of thy) (TVar (x, S), T))) |
705 cons (pairself (ctyp_of thy) (TVar (x, S), T))) |
663 tyenv [] |
706 tyenv [] |
664 val t_inst = |
707 val t_inst = |
665 [pairself (cterm_of thy o Envir.norm_term env) (Var var, t')] |
708 [pairself (cterm_of thy o Envir.norm_term env) (Var var, t')] |
666 in |
709 in th |> instantiate (ty_inst, t_inst) end |
667 th |> instantiate (ty_inst, t_inst) |
|
668 end |
|
669 | _ => raise Fail "expected a single non-zapped, non-Metis Var" |
710 | _ => raise Fail "expected a single non-zapped, non-Metis Var" |
670 in |
711 in |
671 (DETERM (etac @{thm allE} i THEN rotate_tac ~1 i) |
712 (DETERM (etac @{thm allE} i THEN rotate_tac ~1 i) |
672 THEN PRIMITIVE do_instantiate) st |
713 THEN PRIMITIVE do_instantiate) st |
673 end |
714 end |
839 THEN release_clusters_tac thy ax_counts substs ordered_clusters 1 |
880 THEN release_clusters_tac thy ax_counts substs ordered_clusters 1 |
840 THEN match_tac [prems_imp_false] 1 |
881 THEN match_tac [prems_imp_false] 1 |
841 THEN ALLGOALS (fn i => |
882 THEN ALLGOALS (fn i => |
842 rtac @{thm Meson.skolem_COMBK_I} i |
883 rtac @{thm Meson.skolem_COMBK_I} i |
843 THEN rotate_tac (rotation_for_subgoal i) i |
884 THEN rotate_tac (rotation_for_subgoal i) i |
|
885 THEN PRIMITIVE (unify_first_prem_with_concl thy i) |
844 THEN assume_tac i |
886 THEN assume_tac i |
845 THEN flexflex_tac))) |
887 THEN flexflex_tac))) |
846 handle ERROR _ => |
888 handle ERROR _ => |
847 error ("Cannot replay Metis proof in Isabelle:\n\ |
889 error ("Cannot replay Metis proof in Isabelle:\n\ |
848 \Error when discharging Skolem assumptions.") |
890 \Error when discharging Skolem assumptions.") |