src/HOL/Tools/Sledgehammer/metis_tactics.ML
changeset 39937 4ee63a30194c
parent 39936 8f415cfc2180
child 39938 0a2091f86eb4
equal deleted inserted replaced
39936:8f415cfc2180 39937:4ee63a30194c
    56    literalsWeight = 0.0,
    56    literalsWeight = 0.0,
    57    models = []}
    57    models = []}
    58 val resolution_params = {active = active_params, waiting = waiting_params}
    58 val resolution_params = {active = active_params, waiting = waiting_params}
    59 
    59 
    60 (* In principle, it should be sufficient to apply "assume_tac" to unify the
    60 (* In principle, it should be sufficient to apply "assume_tac" to unify the
    61    conclusion with one of the premises. However, in practice, this fails
    61    conclusion with one of the premises. However, in practice, this is unreliable
    62    horribly because of the mildly higher-order nature of the unification
    62    because of the mildly higher-order nature of the unification problems.
    63    problems. Typical constraints are of the form "?x a b =?= b", where "a" and
    63    Typical constraints are of the form
    64    "b" are goal parameters. *)
    64    "?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",
    65 fun unify_prem_with_concl thy i th =
    65    where the nonvariables are goal parameters. *)
       
    66 fun unify_first_prem_with_concl thy i th =
    66   let
    67   let
    67     val goal = Logic.get_goal (prop_of th) i |> Envir.beta_eta_contract
    68     val goal = Logic.get_goal (prop_of th) i |> Envir.beta_eta_contract
    68     val prem = goal |> Logic.strip_assums_hyp |> hd
    69     val prem = goal |> Logic.strip_assums_hyp |> hd
    69     val concl = goal |> Logic.strip_assums_concl
    70     val concl = goal |> Logic.strip_assums_concl
    70     fun add_types Tp instT =
    71     fun add_types Tp instT =
    85     fun add_terms tp inst =
    86     fun add_terms tp inst =
    86       if exists (pair_untyped_aconv tp) inst then inst
    87       if exists (pair_untyped_aconv tp) inst then inst
    87       else tp :: map (apsnd (subst_atomic [tp])) inst
    88       else tp :: map (apsnd (subst_atomic [tp])) inst
    88     fun is_flex t =
    89     fun is_flex t =
    89       case strip_comb t of
    90       case strip_comb t of
    90         (Var _, args) => forall (is_Bound orf is_Var) args
    91         (Var _, args) => forall is_Bound args
    91       | _ => false
    92       | _ => false
    92     fun unify_flex flex rigid =
    93     fun unify_flex flex rigid =
    93       case strip_comb flex of
    94       case strip_comb flex of
    94         (Var (z as (_, T)), args) =>
    95         (Var (z as (_, T)), args) =>
    95         add_terms (Var z,
    96         add_terms (Var z,
   152     etac @{thm allE} i
   153     etac @{thm allE} i
   153     THEN rotate_tac ~1 i
   154     THEN rotate_tac ~1 i
   154     THEN PRIMITIVE do_instantiate
   155     THEN PRIMITIVE do_instantiate
   155   end
   156   end
   156 
   157 
   157 (*### TODO: fix confusion between ax_no and goal_no *)
       
   158 fun release_clusters_tac _ _ _ _ [] = K all_tac
   158 fun release_clusters_tac _ _ _ _ [] = K all_tac
   159   | release_clusters_tac thy ax_counts substs params
   159   | release_clusters_tac thy ax_counts substs params
   160                          ((ax_no, cluster_no) :: clusters) =
   160                          ((ax_no, cluster_no) :: clusters) =
   161     let
   161     let
   162 (*      val n = AList.lookup (op =) ax_counts ax_no |> the (*###*) *)
       
   163       fun in_right_cluster s =
   162       fun in_right_cluster s =
   164         (s |> Meson_Clausify.cluster_of_zapped_var_name |> fst |> snd |> fst)
   163         (s |> Meson_Clausify.cluster_of_zapped_var_name |> fst |> snd |> fst)
   165         = cluster_no
   164         = cluster_no
   166       val alls =
   165       val cluster_substs =
   167         substs
   166         substs
   168         |> maps (fn (ax_no', (_, (_, tsubst))) =>
   167         |> map_filter (fn (ax_no', (_, (_, tsubst))) =>
   169                     if ax_no' = ax_no then
   168                           if ax_no' = ax_no then
   170                       tsubst |> filter (in_right_cluster
   169                             tsubst |> filter (in_right_cluster
   171                                         o fst o fst o dest_Var o fst)
   170                                                o fst o fst o dest_Var o fst)
   172                              |> map snd
   171                                     |> map snd |> SOME
   173                     else
   172                            else
   174                       [])
   173                              NONE)
   175       val params' = params
   174       val n = length cluster_substs
       
   175       fun do_cluster_subst cluster_subst =
       
   176         map (instantiate_forall_tac thy params) cluster_subst @ [rotate_tac 1]
       
   177       val params' = params (*### existentials! *)
   176     in
   178     in
   177       rotate_tac ax_no
   179       rotate_tac ax_no
   178       THEN' EVERY' (map (instantiate_forall_tac thy params) alls)
   180       THEN' (EVERY' (maps do_cluster_subst cluster_substs))
   179 (*      THEN' ### *)
   181       THEN' rotate_tac (~ ax_no - length cluster_substs)
   180       THEN' rotate_tac (~ ax_no)
       
   181       THEN' release_clusters_tac thy ax_counts substs params' clusters
   182       THEN' release_clusters_tac thy ax_counts substs params' clusters
   182    end
   183     end
   183 
   184 
   184 val cluster_ord =
   185 val cluster_ord =
   185   prod_ord (prod_ord int_ord (prod_ord int_ord int_ord)) bool_ord
   186   prod_ord (prod_ord int_ord (prod_ord int_ord int_ord)) bool_ord
   186 
   187 
   187 val tysubst_ord =
   188 val tysubst_ord =
   292       fun rotation_for_subgoal i =
   293       fun rotation_for_subgoal i =
   293         find_index (fn (_, (subgoal_no, _)) => subgoal_no = i) substs
   294         find_index (fn (_, (subgoal_no, _)) => subgoal_no = i) substs
   294     in
   295     in
   295       Goal.prove ctxt [] [] @{prop False}
   296       Goal.prove ctxt [] [] @{prop False}
   296           (K (cut_rules_tac (map (fst o nth axioms o fst o fst) ax_counts) 1
   297           (K (cut_rules_tac (map (fst o nth axioms o fst o fst) ax_counts) 1
       
   298               THEN print_tac "cut:"
   297               THEN TRY (REPEAT_ALL_NEW (etac @{thm exE}) 1)
   299               THEN TRY (REPEAT_ALL_NEW (etac @{thm exE}) 1)
       
   300               THEN print_tac "eliminated outermost existentials:"
   298               THEN copy_prems_tac (map snd ax_counts) [] 1
   301               THEN copy_prems_tac (map snd ax_counts) [] 1
   299               THEN release_clusters_tac thy ax_counts substs params0
   302               THEN release_clusters_tac thy ax_counts substs params0
   300                                         ordered_clusters 1
   303                                         ordered_clusters 1
   301               THEN print_tac "released axioms:"
   304               THEN print_tac "released clusters:"
   302               THEN match_tac [prems_imp_false] 1
   305               THEN match_tac [prems_imp_false] 1
   303               THEN print_tac "applied rule:"
   306               THEN print_tac "applied rule:"
       
   307               THEN print_tac "unified skolems:"
   304               THEN ALLGOALS (fn i =>
   308               THEN ALLGOALS (fn i =>
   305                        rtac @{thm skolem_COMBK_I} i
   309                        rtac @{thm skolem_COMBK_I} i
   306                        THEN rotate_tac (rotation_for_subgoal i) i
   310                        THEN rotate_tac (rotation_for_subgoal i) i
   307                        THEN PRIMITIVE (unify_prem_with_concl thy i)
   311                        THEN PRIMITIVE (unify_first_prem_with_concl thy i)
   308                        THEN assume_tac i)))
   312                        THEN assume_tac i)))
   309     end
   313     end
   310 
   314 
   311 (* Main function to start Metis proof and reconstruction *)
   315 (* Main function to start Metis proof and reconstruction *)
   312 fun FOL_SOLVE mode ctxt cls ths0 =
   316 fun FOL_SOLVE mode ctxt cls ths0 =