626 val params = Logic.strip_params (Logic.get_goal (prop_of st) i) |> rev |
626 val params = Logic.strip_params (Logic.get_goal (prop_of st) i) |> rev |
627 fun repair (t as (Var ((s, _), _))) = |
627 fun repair (t as (Var ((s, _), _))) = |
628 (case find_index (fn (s', _) => s' = s) params of |
628 (case find_index (fn (s', _) => s' = s) params of |
629 ~1 => t |
629 ~1 => t |
630 | j => Bound j) |
630 | j => Bound j) |
631 | repair (t $ u) = repair t $ repair u |
631 | repair (t $ u) = |
|
632 (case (repair t, repair u) of |
|
633 (t as Bound j, u as Bound k) => |
|
634 (* This is a rather subtle trick to repair the discrepancy between |
|
635 the fully skolemized term that MESON gives us (where existentials |
|
636 were pulled out) and the reality. *) |
|
637 if k > j then t else t $ u |
|
638 | (t, u) => t $ u) |
632 | repair t = t |
639 | repair t = t |
633 val t' = t |> repair |> fold (curry absdummy) (map snd params) |
640 val t' = t |> repair |> fold (curry absdummy) (map snd params) |
634 fun do_instantiate th = |
641 fun do_instantiate th = |
635 let val var = Term.add_vars (prop_of th) [] |> the_single in |
642 let val var = Term.add_vars (prop_of th) [] |> the_single in |
636 th |> term_instantiate thy [(Var var, t')] |
643 th |> term_instantiate thy [(Var var, t')] |
639 (etac @{thm allE} i |
646 (etac @{thm allE} i |
640 THEN rotate_tac ~1 i |
647 THEN rotate_tac ~1 i |
641 THEN PRIMITIVE do_instantiate) st |
648 THEN PRIMITIVE do_instantiate) st |
642 end |
649 end |
643 |
650 |
|
651 fun fix_exists_tac thy t = |
|
652 etac @{thm exE} |
|
653 THEN' rename_tac [t |> dest_Var |> fst |> fst] |
|
654 |
|
655 fun release_quantifier_tac thy (skolem, t) = |
|
656 (if skolem then fix_exists_tac else instantiate_forall_tac) thy t |
|
657 |
644 fun release_clusters_tac _ _ _ [] = K all_tac |
658 fun release_clusters_tac _ _ _ [] = K all_tac |
645 | release_clusters_tac thy ax_counts substs |
659 | release_clusters_tac thy ax_counts substs |
646 ((ax_no, cluster_no) :: clusters) = |
660 ((ax_no, cluster_no) :: clusters) = |
647 let |
661 let |
648 fun in_right_cluster s = |
662 val cluster_of_var = |
649 (s |> Meson_Clausify.cluster_of_zapped_var_name |> fst |> snd |> fst) |
663 Meson_Clausify.cluster_of_zapped_var_name o fst o fst o dest_Var |
650 = cluster_no |
664 fun in_right_cluster ((_, (cluster_no', _)), _) = cluster_no' = cluster_no |
651 val cluster_substs = |
665 val cluster_substs = |
652 substs |
666 substs |
653 |> map_filter (fn (ax_no', (_, (_, tsubst))) => |
667 |> map_filter (fn (ax_no', (_, (_, tsubst))) => |
654 if ax_no' = ax_no then |
668 if ax_no' = ax_no then |
655 tsubst |> filter (in_right_cluster |
669 tsubst |> map (apfst cluster_of_var) |
656 o fst o fst o dest_Var o fst) |
670 |> filter (in_right_cluster o fst) |
657 |> map snd |> SOME |
671 |> map (apfst snd) |
658 else |
672 |> SOME |
659 NONE) |
673 else |
|
674 NONE) |
660 fun do_cluster_subst cluster_subst = |
675 fun do_cluster_subst cluster_subst = |
661 map (instantiate_forall_tac thy) cluster_subst @ [rotate_tac 1] |
676 map (release_quantifier_tac thy) cluster_subst @ [rotate_tac 1] |
662 val first_prem = find_index (fn (ax_no', _) => ax_no' = ax_no) substs |
677 val first_prem = find_index (fn (ax_no', _) => ax_no' = ax_no) substs |
663 in |
678 in |
664 rotate_tac first_prem |
679 rotate_tac first_prem |
665 THEN' (EVERY' (maps do_cluster_subst cluster_substs)) |
680 THEN' (EVERY' (maps do_cluster_subst cluster_substs)) |
666 THEN' rotate_tac (~ first_prem - length cluster_substs) |
681 THEN' rotate_tac (~ first_prem - length cluster_substs) |
693 prems_imp_false |
708 prems_imp_false |
694 else |
709 else |
695 let |
710 let |
696 val thy = ProofContext.theory_of ctxt |
711 val thy = ProofContext.theory_of ctxt |
697 (* distinguish variables with same name but different types *) |
712 (* distinguish variables with same name but different types *) |
|
713 (* ### FIXME: needed? *) |
698 val prems_imp_false' = |
714 val prems_imp_false' = |
699 prems_imp_false |> try (forall_intr_vars #> gen_all) |
715 prems_imp_false |> try (forall_intr_vars #> gen_all) |
700 |> the_default prems_imp_false |
716 |> the_default prems_imp_false |
701 val prems_imp_false = |
717 val prems_imp_false = |
702 if prop_of prems_imp_false aconv prop_of prems_imp_false' then |
718 if prop_of prems_imp_false aconv prop_of prems_imp_false' then |
777 commas (map ((fn (s, t) => s ^ " |-> " ^ t) |
793 commas (map ((fn (s, t) => s ^ " |-> " ^ t) |
778 o pairself (Syntax.string_of_term ctxt)) tsubst) ^ "}" |
794 o pairself (Syntax.string_of_term ctxt)) tsubst) ^ "}" |
779 val _ = tracing ("SUBSTS (" ^ string_of_int (length substs) ^ "):\n" ^ |
795 val _ = tracing ("SUBSTS (" ^ string_of_int (length substs) ^ "):\n" ^ |
780 cat_lines (map string_for_subst_info substs)) |
796 cat_lines (map string_for_subst_info substs)) |
781 val _ = tracing ("ORDERED CLUSTERS: " ^ PolyML.makestring ordered_clusters) |
797 val _ = tracing ("ORDERED CLUSTERS: " ^ PolyML.makestring ordered_clusters) |
782 val _ = tracing ("OUTER PARAMS: " ^ PolyML.makestring outer_param_names) |
|
783 val _ = tracing ("AXIOM COUNTS: " ^ PolyML.makestring ax_counts) |
798 val _ = tracing ("AXIOM COUNTS: " ^ PolyML.makestring ax_counts) |
784 *) |
799 *) |
785 fun rotation_for_subgoal i = |
800 fun rotation_for_subgoal i = |
786 find_index (fn (_, (subgoal_no, _)) => subgoal_no = i) substs |
801 find_index (fn (_, (subgoal_no, _)) => subgoal_no = i) substs |
787 in |
802 in |