X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=matitaB%2Fcomponents%2Fng_tactics%2FnnAuto.ml;h=1fa530e782054d30ca02a7da400ed7ef9b0123b3;hb=74c6905907b0bca229366d52450e2a6982b5b8be;hp=201f522d05420ba5ad8e01152ce65abb940d24e8;hpb=365bd84918e8e2fe0c6f3714b94e81b443a8f244;p=helm.git diff --git a/matitaB/components/ng_tactics/nnAuto.ml b/matitaB/components/ng_tactics/nnAuto.ml index 201f522d0..1fa530e78 100644 --- a/matitaB/components/ng_tactics/nnAuto.ml +++ b/matitaB/components/ng_tactics/nnAuto.ml @@ -72,8 +72,12 @@ let print_stat status tbl = let vcompare (_,v1) (_,v2) = Pervasives.compare (relevance v1) (relevance v2) in let l = List.sort vcompare l in + let short_name r = + Filename.chop_extension + (Filename.basename (NReference.string_of_reference r)) + in let vstring (a,v)= - NotationPp.pp_term status (Ast.NCic (NCic.Const a)) ^ ": rel = " ^ + short_name a ^ ": rel = " ^ (string_of_float (relevance v)) ^ "; uses = " ^ (string_of_int !(v.uses)) ^ "; nom = " ^ (string_of_int !(v.nominations)) in @@ -146,9 +150,11 @@ let is_a_fact_ast status subst metasenv ctx cand = let ty = NCicTypeChecker.typeof status subst metasenv ctx t in is_a_fact status (mk_cic_term ctx ty) -let current_goal status = +let current_goal ?(single_goal=true) status = let open_goals = head_goals status#stack in - assert (List.length open_goals = 1); + if single_goal + then assert (List.length open_goals = 1) + else assert (List.length open_goals >= 1); let open_goal = List.hd open_goals in let gty = get_goalty status open_goal in let ctx = ctx_of gty in @@ -292,6 +298,7 @@ let index_local_equations eq_cache status = let open_goals = head_goals status#stack in let open_goal = List.hd open_goals in let ngty = get_goalty status open_goal in + let _,_,metasenv,subst,_ = status#obj in let ctx = apply_subst_context ~fix_projections:true status (ctx_of ngty) in let c = ref 0 in List.fold_left @@ -299,12 +306,12 @@ let index_local_equations eq_cache status = c:= !c+1; let t = NCic.Rel !c in try - let ty = NCicTypeChecker.typeof status [] [] ctx t in + let ty = NCicTypeChecker.typeof status subst metasenv ctx t in if is_a_fact status (mk_cic_term ctx ty) then - (noprint(lazy("eq indexing " ^ (status#ppterm ctx [] [] ty))); - NCicParamod.forward_infer_step status [] [] ctx eq_cache t ty) + (noprint(lazy("eq indexing " ^ (status#ppterm ctx subst metasenv ty))); + NCicParamod.forward_infer_step status metasenv subst ctx eq_cache t ty) else - (noprint (lazy ("not a fact: " ^ (status#ppterm ctx [] [] ty))); + (noprint (lazy ("not a fact: " ^ (status#ppterm ctx subst metasenv ty))); eq_cache) with | NCicTypeChecker.TypeCheckerFailure _ @@ -589,7 +596,7 @@ let compare_statuses ~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; +(* paramodulation has only an implicit knowledge 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 *) @@ -854,7 +861,7 @@ type cache = let add_to_trace status ~depth cache t = match t with | Ast.NRef _ -> - debug_print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term status t)); + print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term status t)); {cache with trace = t::cache.trace} | Ast.NCic _ (* local candidate *) | _ -> (*not an application *) cache @@ -983,10 +990,10 @@ let try_candidate ?(smart=0) flags depth status eq_cache ctx t = 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 + (* some flexibility *) + if diff > res && res > 0 (* facts are never pruned *) then (debug_print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = " - ^ (string_of_int res) ^ " vs. " ^ (string_of_int og_no))); + ^ (string_of_int res) ^ " vs. " ^ (string_of_int diff))); debug_print ~depth (lazy "strange application"); None) else (incr candidate_no; Some ((!candidate_no,t),status)) @@ -1096,18 +1103,17 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = (* we compute candidates to be applied in normal mode, splitted in facts and not facts *) let candidates_facts,candidates_other = - (* warning : the order between global_cands and local_cand is - relevant. In this way we process first local cands *) - let l1,l2 = List.partition test (global_cands@local_cands) in + let gl1,gl2 = List.partition test global_cands in + let ll1,ll2 = List.partition test local_cands 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 l1 = if is_eq then [Ast.Ident("refl",`Ambiguous)] else l1 in + let l1 = if is_eq then [Ast.Ident("refl",`Ambiguous)] else gl1@ll1 in let l2 = (* if smart given candidates are applied in smart mode *) - if by && smart then [] - else if by then given_candidates - else l2 + if by && smart then ll2 + else if by then given_candidates@ll2 + else gl2@ll2 in l1,l2 in (* we now compute candidates to be applied in smart mode, splitted in @@ -1115,11 +1121,14 @@ let get_candidates ?(smart=true) depth flags status cache signature gty = let smart_candidates_facts, smart_candidates_other = if is_prod || not(smart) then [],[] else - let l1,l2 = List.partition test (smart_local_cands@smart_global_cands) in - let l1 = if is_eq then [] else l1 in - let l2 = if by then given_candidates else l2 - in - l1,l2 + let sgl1,sgl2 = List.partition test smart_global_cands in + let sll1,sll2 = List.partition test smart_local_cands in + let l1 = if is_eq then [] else sgl1@sll1 in + let l2 = + if by && smart then given_candidates@sll2 + else if by then sll2 + else sgl2@sll2 + in l1,l2 in candidates_facts, smart_candidates_facts, @@ -1174,130 +1183,9 @@ let applicative_case depth signature status flags gty cache = try_candidates false 2 elems smart_candidates_other ;; - -(* -let get_candidates ?(smart=true) depth flags status cache signature gty = - let maxd = ((depth + 1) = flags.maxdepth) in - let universe = status#auto_cache in - let _,_,metasenv,subst,_ = status#obj in - let context = ctx_of gty in - let _, raw_gty = term_of_cic_term status gty context in - debug_print ~depth (lazy ("gty:" ^ NTacStatus.ppterm status gty)); - let raw_weak_gty, weak_gty = - if smart then - match raw_gty with - | NCic.Appl _ - | NCic.Const _ - | NCic.Rel _ -> - let raw_weak = - perforate_small status subst metasenv context raw_gty in - let weak = mk_cic_term context raw_weak in - debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak)); - Some raw_weak, Some (weak) - | _ -> None,None - else None,None - in - let global_cands, smart_global_cands = - match flags.candidates with - | Some l when (not maxd) -> l,[] - | Some _ - | None -> - let mapf s = - let to_ast = function - | NCic.Const r when true (*is_relevant statistics r*) -> Some (Ast.NRef r) - (* | NCic.Const _ -> None *) - | _ -> assert false in - HExtlib.filter_map - to_ast (NDiscriminationTree.TermSet.elements s) in - let g,l = - get_cands - (NDiscriminationTree.DiscriminationTree.retrieve_unifiables - universe) - NDiscriminationTree.TermSet.diff - NDiscriminationTree.TermSet.empty - raw_gty raw_weak_gty in - mapf g, mapf l in - let local_cands,smart_local_cands = - let mapf s = - let to_ast t = - let _status, t = term_of_cic_term status t context - in Ast.NCic t in - List.map to_ast (Ncic_termSet.elements s) in - let g,l = - get_cands - (fun ty -> search_in_th ty cache) - Ncic_termSet.diff Ncic_termSet.empty gty weak_gty in - mapf g, mapf l in - sort_candidates status context (global_cands@local_cands), - sort_candidates status context (smart_global_cands@smart_local_cands) -;; - -let applicative_case depth signature status flags gty cache = - app_counter:= !app_counter+1; - let _,_,metasenv,subst,_ = status#obj in - let context = ctx_of gty in - let tcache = cache.facts in - let is_prod, is_eq = - let status, t = term_of_cic_term status gty context in - let t = NCicReduction.whd status subst context t in - match t with - | NCic.Prod _ -> true, false - | _ -> false, NCicParamod.is_equation status metasenv subst context t - in - debug_print ~depth (lazy (string_of_bool is_eq)); - (* 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 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 = - match flags.candidates with - | Some l -> [],l - | None -> - 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 - let sm1 = if flags.last then 2 else 0 in - let maxd = (depth + 1 = flags.maxdepth) in - let try_candidates only_one sm acc candidates = - List.fold_left - (fun elems cand -> - if (only_one && (elems <> [])) then elems - else - match try_candidate (~smart:sm) - flags depth status cache.unit_eq context cand with - | None -> elems - | Some x -> x::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 ;; - - (* gty is supposed to be meta-closed *) let is_subsumed depth filter_depth status gty cache = if cache=[] then false else ( @@ -1846,22 +1734,29 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = (* pp_th status facts; *) (* NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t -> - debug_print (lazy( + (*debug_*)print (lazy( NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^ String.concat "\n " (List.map ( status#ppterm ~metasenv:[] ~context:[] ~subst:[]) (NDiscriminationTree.TermSet.elements t)) ))); *) - let candidates = + (* To allow using Rels in the user-specified candidates, we need a context + * but in the case where multiple goals are open, there is no single context + * to type the Rels. At this time, we require that Rels be typed in the + * context of the first selected goal *) + let _,ctx,_ = current_goal ~single_goal:false status in + let status, candidates = match univ with - | None -> None + | None -> status, None | Some l -> - let to_Ast t = - let status, res = disambiguate status [] t None in - let _,res = term_of_cic_term status res (ctx_of res) - in Ast.NCic res - in Some (List.map to_Ast l) + let to_Ast (st,l) t = + let st, res = disambiguate st ctx t None in + let st, res = term_of_cic_term st res (ctx_of res) + in (st, Ast.NCic res::l) + in + let status, l' = List.fold_left to_Ast (status,[]) l in + status, Some l' in let depth = int "depth" flags 3 in let size = int "size" flags 10 in @@ -1900,6 +1795,7 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = | Proved (s,trace) -> debug_print (lazy ("proved at depth " ^ string_of_int x)); List.iter (toref incr_uses statistics) trace; + let _ = debug_print (pptrace status trace) in let trace = cleanup_trace s trace in let _ = debug_print (pptrace status trace) in let stack = @@ -1909,10 +1805,10 @@ let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status = in let s = s#set_stack stack in trace_ref := trace; - oldstatus#set_status s + oldstatus#set_status s in let s = up_to depth depth in - debug_print (print_stat status statistics); + debug_print (print_stat status statistics); debug_print(lazy ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time))); debug_print(lazy