src/HOL/Tools/Metis/metis_reconstruct.ML
changeset 40261 7a02144874f3
parent 40259 c0e34371c2e2
child 40264 b91e2e16d994
equal deleted inserted replaced
40260:73ecbe2d432b 40261:7a02144874f3
   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