let print ?(depth=0) s =
prerr_endline (String.make (2*depth) ' '^Lazy.force s)
let noprint ?(depth=0) _ = ()
-let debug_print = noprint
+let debug_print = print
open Continuationals.Stack
open NTacStatus
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
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
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
;;
;;
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 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 ("gty:" ^ NTacStatus.ppterm status gty));
+ let is_eq =
+ NCicParamod.is_equation status metasenv subst context raw_gty
+ in
let raw_weak_gty, weak_gty =
if smart then
match raw_gty with
| _ -> None,None
else None,None
in
+ (* we now compute global candidates *)
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 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
+ (* we now compute local candidates *)
let local_cands,smart_local_cands =
let mapf s =
let to_ast t =
(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 context = ctx_of gty in
- let t_ast t =
- let _status, t = term_of_cic_term status t context
- in Ast.NCic t 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 keys = all_keys_of_cic_term metasenv subst context raw_gty in
- (* we only keep those keys that do not require any intros for now *)
- let no_intros_keys = snd (List.hd keys) in
- let cands =
- NDiscriminationTree.TermSet.fold
- (fun ty acc ->
- NDiscriminationTree.TermSet.union acc
- (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
- universe ty)
- ) no_intros_keys NDiscriminationTree.TermSet.empty in
-(* old code:
- let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables
- universe raw_gty in
-*)
- let local_cands =
- NDiscriminationTree.TermSet.fold
- (fun ty acc ->
- Ncic_termSet.union acc (search_in_th (mk_cic_term context ty) cache)
- ) no_intros_keys Ncic_termSet.empty in
-(* old code:
- 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)))));
- let together global local =
- List.map c_ast
- (List.filter (only signature context)
- (NDiscriminationTree.TermSet.elements global)) @
- List.map t_ast (Ncic_termSet.elements local) in
- let candidates = together cands local_cands in
- let candidates = sort_candidates status context candidates in
- let smart_candidates =
- if smart then
- match raw_gty with
- | NCic.Appl _
- | NCic.Const _
- | NCic.Rel _ ->
- let weak_gty = perforate_small status subst metasenv context raw_gty in
- (*
- 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
- let smart_cands =
- NDiscriminationTree.TermSet.diff more_cands cands 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
- together smart_cands smart_local_cands
- (* together more_cands more_local_cands *)
- | _ -> []
- else []
+ (* we now splits candidates in facts or not facts *)
+ let test = is_a_fact_ast status subst metasenv context in
+ let by,given_candidates =
+ match flags.candidates with
+ | Some l -> true, l
+ | None -> false, [] in
+ (* 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
+ (* 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 l2 =
+ (* if smart given candidates are applied in smart mode *)
+ if by && smart then []
+ else if by then given_candidates
+ else l2
+ in l1,l2
in
- let smart_candidates = sort_candidates status context smart_candidates 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,[]
-;; *)
+ (* we now compute candidates to be applied in smart mode, splitted in
+ facts and not facts *)
+ 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
+ in
+ candidates_facts,
+ smart_candidates_facts,
+ sort_candidates status context (candidates_other),
+ sort_candidates status context (smart_candidates_other)
+;;
let applicative_case depth signature status flags gty cache =
app_counter:= !app_counter+1;
in
debug_print ~depth (lazy (string_of_bool is_eq));
(* new *)
- let candidates, smart_candidates =
+ let candidates_facts, smart_candidates_facts,
+ candidates_other, smart_candidates_other =
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 =
- let l1,l2 = List.partition test smart_candidates in
- if is_eq then [],l2 else l1,l2
+ flags status tcache signature gty
in
- let sm = if is_eq then 0 else 2 in
- let sm1 = if flags.last then 2 else 0 in
+ let sm = if is_eq || is_prod 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
;;
exception Found
-;;
-
+;;
(* gty is supposed to be meta-closed *)
let is_subsumed depth filter_depth status gty cache =
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 ->
(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)
- in
+ 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
let width = int "width" flags 4 (* (3+List.length goals)*) in
| 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 =
projects / helm.git / blobdiff