raise (Error (lazy "eq_coerc non yet defined",Some e))
| Error _ as e -> debug_print (lazy "error"); raise e
+let compare_statuses ~past ~present =
+ let _,_,past,_,_ = past#obj in
+ let _,_,present,_,_ = present#obj in
+ List.map fst (List.filter (fun (i,_) -> not(List.mem_assoc i past)) present),
+ List.map fst (List.filter (fun (i,_) -> not (List.mem_assoc i present)) past)
+;;
+
+(* paramodulation has only an implicit knoweledge of the symmetry of equality;
+ hence it is in trouble in proving (a = b) = (b = a) *)
+let try_sym tac status g =
+ (* put the right uri *)
+ let sym_eq = Ast.Appl [Ast.Ident("sym_eq",`Ambiguous); Ast.Implicit `Vector] in
+ let _,_,metasenv,subst,_ = status#obj in
+ let _, context, gty = List.assoc g metasenv in
+ let is_eq =
+ NCicParamod.is_equation status metasenv subst context gty
+ in
+ if is_eq then
+ try tac status g
+ with Error _ ->
+ let new_status = instantiate_with_ast status g ("",0,sym_eq) in
+ let go, _ = compare_statuses ~past:status ~present:new_status in
+ assert (List.length go = 1);
+ let ng = List.hd go in
+ tac new_status ng
+ else tac status g
+;;
+
let smart_apply_tac t s =
let unit_eq = index_local_equations s#eq_cache s in
- NTactics.distribute_tac (smart_apply t unit_eq) s
+ NTactics.distribute_tac (try_sym (smart_apply t unit_eq)) s
+ (* NTactics.distribute_tac (smart_apply t unit_eq) s *)
let smart_apply_auto t eq_cache =
- NTactics.distribute_tac (smart_apply t eq_cache)
+ NTactics.distribute_tac (try_sym (smart_apply t eq_cache))
+ (* NTactics.distribute_tac (smart_apply t eq_cache) *)
(****************** types **************)
let sort_new_elems l =
List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l
+let rec stack_goals level gs =
+ if level = 0 then []
+ else match gs with
+ | [] -> assert false
+ | (g,_,_,_)::s ->
+ let is_open = function
+ | (_,Continuationals.Stack.Open i) -> Some i
+ | (_,Continuationals.Stack.Closed _) -> None
+ in
+ HExtlib.filter_map is_open g @ stack_goals (level-1) s
+;;
+
+let open_goals level status = stack_goals level status#stack
+;;
+
let try_candidate ?(smart=0) flags depth status eq_cache ctx t =
try
+ let old_og_no = List.length (open_goals (depth+1) status) in
debug_print ~depth (lazy ("try " ^ (NotationPp.pp_term status) t));
let status =
if smart= 0 then NTactics.apply_tac ("",0,t) status
with Error _ ->
smart_apply_auto ("",0,t) eq_cache status
in
-(*
- let og_no = openg_no status in
- if (* og_no > flags.maxwidth || *)
- ((depth + 1) = flags.maxdepth && og_no <> 0) then
- (debug_print ~depth (lazy "pruned immediately"); None)
- else *)
- (* useless
- let status, cict = disambiguate status ctx ("",0,t) None in
- let status,ct = term_of_cic_term status cict ctx in
- let _,_,metasenv,subst,_ = status#obj in
- let ty = NCicTypeChecker.typeof subst metasenv ctx ct in
- let res = branch status (mk_cic_term ctx ty) in
- if smart=1 && og_no > res then
- (debug_print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = "
+ (* we compare the expected branching with the actual one and
+ prune the candidate when the latter is larger. The optimization
+ is meant to rule out stange applications of flexible terms,
+ such as the application of eq_f that always succeeds.
+ There is some gain but less than expected *)
+ let og_no = List.length (open_goals (depth+1) status) in
+ let status, cict = disambiguate status ctx ("",0,t) None in
+ let status,ct = term_of_cic_term status cict ctx in
+ let _,_,metasenv,subst,_ = status#obj in
+ let ty = NCicTypeChecker.typeof status subst metasenv ctx ct in
+ let res = branch status (mk_cic_term ctx ty) in
+ let diff = og_no - old_og_no in
+ debug_print (lazy ("expected branching: " ^ (string_of_int res)));
+ debug_print (lazy ("actual: branching" ^ (string_of_int diff)));
+ (* one goal is closed by the application *)
+ if og_no - old_og_no >= res then
+ (debug_print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = "
^ (string_of_int res) ^ " vs. " ^ (string_of_int og_no)));
- debug_print ~depth (lazy "strange application"); None)
- else *)
- (incr candidate_no;
- Some ((!candidate_no,t),status))
+ debug_print ~depth (lazy "strange application"); None)
+ else
+ (incr candidate_no; Some ((!candidate_no,t),status))
with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
;;
| _ -> false, NCicParamod.is_equation status metasenv subst context t
in
debug_print ~depth (lazy (string_of_bool is_eq));
- (* old
- let candidates, smart_candidates =
- get_candidates ~smart:(not is_eq) depth
- flags status tcache signature gty in
- (* if the goal is an equation we avoid to apply unit equalities,
- since superposition should take care of them; refl is an
- exception since it prompts for convertibility *)
- let candidates =
- let test x = not (is_a_fact_ast status subst metasenv context x) in
- if is_eq then
- Ast.Ident("refl",None) ::List.filter test candidates
- else candidates in *)
(* new *)
let candidates, smart_candidates =
get_candidates ~smart:true depth
flags status tcache signature gty in
+ let test = is_a_fact_ast status subst metasenv context in
+ let candidates_facts,candidates_other =
(* if the goal is an equation we avoid to apply unit equalities,
- since superposition should take care of them; refl is an
- exception since it prompts for convertibility *)
- let candidates,smart_candidates =
- let test x = not (is_a_fact_ast status subst metasenv context x) in
- if is_eq then
- Ast.Ident("refl",`Ambiguous) ::List.filter test candidates,
- List.filter test smart_candidates
- else candidates,smart_candidates in
- debug_print ~depth
- (lazy ("candidates: " ^ string_of_int (List.length candidates)));
- debug_print ~depth
- (lazy ("smart candidates: " ^
- string_of_int (List.length smart_candidates)));
- (*
- let sm = 0 in
- let smart_candidates = [] in *)
+ since superposition should take care of them; refl is an
+ exception since it prompts for convertibility *)
+ let l1,l2 = List.partition test candidates in
+ (* put the right uri *)
+ if is_eq then [Ast.Ident("refl",`Ambiguous)],l2 else l1,l2
+ in
+ let smart_candidates_facts, smart_candidates_other =
+ let l1,l2 = List.partition test smart_candidates in
+ if is_eq then [],l2 else l1,l2
+ in
let sm = if is_eq then 0 else 2 in
- (* wrong: we constraint maxdepth for equality goals to three *)
- (* let maxdepth = if is_eq then min flags.maxdepth 6 else flags.maxdepth in *)
+ let sm1 = if flags.last then 2 else 0 in
let maxd = (depth + 1 = flags.maxdepth) in
- let only_one = flags.last && maxd in
- debug_print ~depth (lazy ("only_one: " ^ (string_of_bool only_one)));
- debug_print ~depth (lazy ("maxd: " ^ (string_of_bool maxd)));
- let elems =
+ let try_candidates only_one sm acc candidates =
List.fold_left
(fun elems cand ->
if (only_one && (elems <> [])) then elems
- else
- if (maxd && not(is_prod) &
- not(is_a_fact_ast status subst metasenv context cand))
- then (debug_print ~depth (lazy "pruned: not a fact"); elems)
else
match try_candidate (~smart:sm)
flags depth status cache.unit_eq context cand with
| None -> elems
| Some x -> x::elems)
- [] candidates
- in
- let more_elems =
- if only_one && elems <> [] then elems
- else
- List.fold_left
- (fun elems cand ->
- if (only_one && (elems <> [])) then elems
- else
- if (maxd && not(is_prod) &&
- not(is_a_fact_ast status subst metasenv context cand))
- then (debug_print ~depth (lazy "pruned: not a fact"); elems)
- else
- match try_candidate (~smart:2) (* was smart:1 *)
- flags depth status cache.unit_eq context cand with
- | None -> elems
- | Some x -> x::elems)
- [] smart_candidates
- in
- elems@more_elems
+ acc candidates
+ in
+ (* if the goal is the last one we stop at the first fact *)
+ let elems = try_candidates flags.last sm [] candidates_facts in
+ (* now we add smart_facts *)
+ let elems = try_candidates flags.last sm elems smart_candidates_facts in
+ (* if we are at maxdepth and the goal is not a product we are done
+ similarly, if the goal is the last one and we already found a
+ solution *)
+ if (maxd && not(is_prod)) || (flags.last && elems<>[]) then elems
+ else
+ let elems = try_candidates false 2 elems candidates_other in
+ debug_print ~depth (lazy ("not facts: try smart application"));
+ try_candidates false 2 elems smart_candidates_other
;;
exception Found
(* states in l1 have have an empty set of subgoals: no point to sort them *)
debug_print ~depth
(lazy ("alternatives = " ^ (string_of_int (List.length (l1@l@l2)))));
- (* l1 @ (sort_new_elems (l @ l2)), cache *)
- l1 @ (List.rev l2) @ l, cache
+ (* we order alternatives w.r.t the number of subgoals they open *)
+ l1 @ (sort_new_elems l2) @ l, cache
;;
let pp_goal = function
status#set_stack gstatus
;;
-let rec stack_goals level gs =
- if level = 0 then []
- else match gs with
- | [] -> assert false
- | (g,_,_,_)::s ->
- let is_open = function
- | (_,Continuationals.Stack.Open i) -> Some i
- | (_,Continuationals.Stack.Closed _) -> None
- in
- HExtlib.filter_map is_open g @ stack_goals (level-1) s
-;;
-
-let open_goals level status = stack_goals level status#stack
-;;
-
let move_to_side level status =
match status#stack with
| [] -> assert false
List.for_all (fun i -> IntSet.mem i others)
(HExtlib.filter_map is_open g)
+let top_cache ~depth top status cache =
+ if top then
+ let unit_eq = index_local_equations status#eq_cache status in
+ {cache with unit_eq = unit_eq}
+ else cache
+
let rec auto_clusters ?(top=false)
flags signature cache depth status : unit =
debug_print ~depth (lazy ("entering auto clusters at depth " ^
in
auto_clusters flags signature cache (depth-1) status
else if List.length goals < 2 then
+ let cache = top_cache ~depth top status cache in
auto_main flags signature cache depth status
else
let all_goals = open_goals (depth+1) status in
let flags =
{flags with last = (List.length all_goals = 1)} in
(* no need to cluster *)
+ let cache = top_cache ~depth top status cache in
auto_main flags signature cache depth status
else
let classes = if top then List.rev classes else classes in
debug_print ~depth (lazy ("stack length = " ^
(string_of_int lold)));
let fstatus = deep_focus_tac (depth+1) gl status in
+ let cache = top_cache ~depth top fstatus cache in
try
debug_print ~depth (lazy ("focusing on" ^
String.concat "," (List.map string_of_int gl)));
let status = (status:> NTacStatus.tac_status) in
let goals = head_goals status#stack in
let status, facts = mk_th_cache status goals in
- let unit_eq = index_local_equations status#eq_cache status in
- let cache = init_cache ~facts ~unit_eq () in
+(* let unit_eq = index_local_equations status#eq_cache status in *)
+ let cache = init_cache ~facts () in
(* pp_th status facts; *)
(*
NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
projects / helm.git / blobdiff