type flags = {
do_types : bool; (* solve goals in Type *)
last : bool; (* last goal: take first solution only *)
+ candidates: Ast.term list option;
maxwidth : int;
maxsize : int;
maxdepth : int;
trace: Ast.term list
}
-let add_to_trace cache t =
+let add_to_trace ~depth cache t =
match t with
- | Ast.NRef _ -> {cache with trace = t::cache.trace}
+ | Ast.NRef _ ->
+ debug_print ~depth (lazy ("Adding to trace: " ^ CicNotationPp.pp_term t));
+ {cache with trace = t::cache.trace}
| Ast.NCic _ (* local candidate *)
| _ -> (*not an application *) cache
+let pptrace tr =
+ (lazy ("Proof Trace: " ^ (String.concat ";"
+ (List.map CicNotationPp.pp_term tr))))
(* not used
let remove_from_trace cache t =
match t with
aux t
;;
+let get_cands retrieve_for diff empty gty weak_gty =
+ let cands = retrieve_for gty in
+ match weak_gty with
+ | None -> cands, empty
+ | Some weak_gty ->
+ let more_cands = retrieve_for weak_gty in
+ cands, diff more_cands cands
+;;
+
+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
+ let raw_weak_gty, weak_gty =
+ if smart then
+ match raw_gty with
+ | NCic.Appl _
+ | NCic.Const _
+ | NCic.Rel _ ->
+ let weak = perforate_small subst metasenv context raw_gty in
+ Some weak, Some (mk_cic_term context 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 -> Ast.NRef r | _ -> assert false in
+ List.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)
+;;
+
+(* old version
let get_candidates ?(smart=true) status cache signature gty =
let universe = status#auto_cache in
let _,_,metasenv,subst,_ = status#obj in
let c_ast = function
| NCic.Const r -> Ast.NRef r | _ -> assert false in
let _, raw_gty = term_of_cic_term status gty context in
- let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables
- universe raw_gty in
+ let cands =
+ NDiscriminationTree.DiscriminationTree.retrieve_unifiables
+ universe raw_gty
+ in
let local_cands = search_in_th gty cache in
debug_print (lazy ("candidates for" ^ NTacStatus.ppterm status gty));
debug_print (lazy ("local cands = " ^ (string_of_int (List.length (Ncic_termSet.elements local_cands)))));
NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
(List.length tl)) in *)
let more_cands =
- NDiscriminationTree.DiscriminationTree.retrieve_unifiables
- universe weak_gty in
+ NDiscriminationTree.DiscriminationTree.retrieve_unifiables
+ universe weak_gty
+ in
let smart_cands =
NDiscriminationTree.TermSet.diff more_cands cands in
- let cic_weak_gty = mk_cic_term context weak_gty in
+ let cic_weak_gty = mk_cic_term context weak_gty in
let more_local_cands = search_in_th cic_weak_gty cache in
let smart_local_cands =
Ncic_termSet.diff more_local_cands local_cands in
(* if smart then smart_candidates, []
else candidates, [] *)
candidates, smart_candidates
-;;
+;;
+
+let get_candidates ?(smart=true) flags status cache signature gty =
+ match flags.candidates with
+ | None -> get_candidates ~smart status cache signature gty
+ | Some l -> l,[]
+;; *)
-let applicative_case depth signature status flags gty (cache:cache) =
+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
in
debug_print(lazy (string_of_bool is_eq));
let candidates, smart_candidates =
- get_candidates ~smart:(not is_eq) status tcache signature gty in
+ get_candidates ~smart:(not is_eq) depth
+ flags status tcache signature gty in
debug_print ~depth
(lazy ("candidates: " ^ string_of_int (List.length candidates)));
debug_print ~depth
| _ -> status, facts
;;
-let rec intros ~depth status (cache:cache) =
+let rec intros ~depth status cache =
match is_prod status with
| Some _ ->
+ let trace = cache.trace in
let status,facts =
intros_facts ~depth status cache.facts
in
(* we reindex the equation from scratch *)
let unit_eq =
index_local_equations status#eq_cache status in
- status, init_cache ~facts ~unit_eq ()
+ status, init_cache ~facts ~unit_eq () ~trace
| _ -> status, cache
;;
flags signature cache depth status : unit =
debug_print ~depth (lazy ("entering auto clusters at depth " ^
(string_of_int depth)));
+ debug_print ~depth (pptrace cache.trace);
(* ignore(Unix.select [] [] [] 0.01); *)
let status = clean_up_tac status in
let goals = head_goals status#stack in
and
(* BRAND NEW VERSION *)
-auto_main flags signature (cache:cache) depth status: unit =
+auto_main flags signature cache depth status: unit =
debug_print ~depth (lazy "entering auto main");
+ debug_print ~depth (pptrace cache.trace);
debug_print ~depth (lazy ("stack length = " ^
(string_of_int (List.length status#stack))));
(* ignore(Unix.select [] [] [] 0.01); *)
let depth,cache =
if t=Ast.Ident("__whd",None) then depth, cache
else depth+1,loop_cache in
- let cache = add_to_trace cache t in
+ let cache = add_to_trace ~depth cache t in
try
- auto_clusters flags signature (cache:cache) depth status
+ auto_clusters flags signature cache depth status
with Gaveup _ ->
debug_print ~depth (lazy "Failed");
())
| _ -> false) trace
;;
-let auto_tac ~params:(_univ,flags) status =
+let auto_tac ~params:(univ,flags) status =
let oldstatus = status in
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 cache = init_cache ~facts ~unit_eq () in
(* pp_th status facts; *)
(*
NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
(NDiscriminationTree.TermSet.elements t))
)));
*)
+ let candidates =
+ match univ with
+ | None -> 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)
+ in
let depth = int "depth" flags 3 in
let size = int "size" flags 10 in
let width = int "width" flags 4 (* (3+List.length goals)*) in
let signature = height_of_goals status in
let flags = {
last = true;
+ candidates = candidates;
maxwidth = width;
maxsize = size;
maxdepth = depth;
| Proved (s,trace) ->
debug_print (lazy ("proved at depth " ^ string_of_int x));
let trace = cleanup_trace s trace in
- let _ = print (lazy
- ("Proof Trace: " ^ (String.concat ";"
- (List.map CicNotationPp.pp_term trace)))) in
+ let _ = print (pptrace trace) in
let stack =
match s#stack with
| (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
projects / helm.git / blobdiff