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 = |