2 ||M|| This file is part of HELM, an Hypertextual, Electronic
3 ||A|| Library of Mathematics, developed at the Computer Science
4 ||T|| Department, University of Bologna, Italy.
6 ||T|| HELM is free software; you can redistribute it and/or
7 ||A|| modify it under the terms of the GNU General Public License
8 \ / version 2 or (at your option) any later version.
9 \ / This software is distributed as is, NO WARRANTY.
10 V_______________________________________________________________ *)
14 let print ?(depth=0) s =
15 prerr_endline (String.make (2*depth) ' '^Lazy.force s)
16 let noprint ?(depth=0) _ = ()
17 let debug_print = noprint
19 open Continuationals.Stack
21 module Ast = NotationPt
23 (* ======================= statistics ========================= *)
25 let app_counter = ref 0
28 type t = NReference.reference
30 let compare = Pervasives.compare
31 let hash = Hashtbl.hash
34 module RefHash = Hashtbl.Make(RHT);;
37 nominations : int ref;
41 let statistics: info RefHash.t = RefHash.create 503
43 let incr_nominations tbl item =
45 let v = RefHash.find tbl item in incr v.nominations
47 RefHash.add tbl item {nominations = ref 1; uses = ref 0}
49 let incr_uses tbl item =
51 let v = RefHash.find tbl item in incr v.uses
52 with Not_found -> assert false
58 | Ast.NCic _ (* local candidate *)
61 let is_relevant tbl item =
63 let v = RefHash.find tbl item in
64 if !(v.nominations) < 60 then true (* not enough info *)
65 else if !(v.uses) = 0 then false
67 with Not_found -> true
69 let print_stat status tbl =
70 let l = RefHash.fold (fun a v l -> (a,v)::l) tbl [] in
71 let relevance v = float !(v.uses) /. float !(v.nominations) in
72 let vcompare (_,v1) (_,v2) =
73 Pervasives.compare (relevance v1) (relevance v2) in
74 let l = List.sort vcompare l in
76 NotationPp.pp_term status (Ast.NCic (NCic.Const a)) ^ ": rel = " ^
77 (string_of_float (relevance v)) ^
78 "; uses = " ^ (string_of_int !(v.uses)) ^
79 "; nom = " ^ (string_of_int !(v.nominations)) in
80 lazy ("\n\nSTATISTICS:\n" ^
81 String.concat "\n" (List.map vstring l))
83 (* ======================= utility functions ========================= *)
84 module IntSet = Set.Make(struct type t = int let compare = compare end)
86 let get_sgoalty status g =
87 let _,_,metasenv,subst,_ = status#obj in
89 let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
90 let ty = NCicUntrusted.apply_subst status subst ctx ty in
91 let ctx = NCicUntrusted.apply_subst_context status
92 ~fix_projections:true subst ctx
94 NTacStatus.mk_cic_term ctx ty
95 with NCicUtils.Meta_not_found _ as exn -> fail ~exn (lazy "get_sgoalty")
99 let gty = get_sgoalty status g in
100 metas_of_term status gty
103 let menv_closure status gl =
104 let rec closure acc = function
106 | x::l when IntSet.mem x acc -> closure acc l
107 | x::l -> closure (IntSet.add x acc) (deps status x @ l)
108 in closure IntSet.empty gl
111 (* we call a "fact" an object whose hypothesis occur in the goal
112 or in types of goal-variables *)
113 let branch status ty =
114 let status, ty, metas = saturate ~delta:0 status ty in
115 noprint (lazy ("saturated ty :" ^ (ppterm status ty)));
116 let g_metas = metas_of_term status ty in
117 let clos = menv_closure status g_metas in
118 (* let _,_,metasenv,_,_ = status#obj in *)
122 let _, m = term_of_cic_term status m (ctx_of m) in
124 | NCic.Meta(i,_) -> IntSet.add i acc
128 (* IntSet.subset menv clos *)
129 IntSet.cardinal(IntSet.diff menv clos)
131 let is_a_fact status ty = branch status ty = 0
133 let is_a_fact_obj s uri =
134 let obj = NCicEnvironment.get_checked_obj s uri in
136 | (_,_,[],[],NCic.Constant(_,_,_,ty,_)) ->
137 is_a_fact s (mk_cic_term [] ty)
138 (* aggiungere i costruttori *)
141 let is_a_fact_ast status subst metasenv ctx cand =
143 (lazy ("------- checking " ^ NotationPp.pp_term status cand));
144 let status, t = disambiguate status ctx ("",0,cand) None in
145 let status,t = term_of_cic_term status t ctx in
146 let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
147 is_a_fact status (mk_cic_term ctx ty)
149 let current_goal status =
150 let open_goals = head_goals status#stack in
151 assert (List.length open_goals = 1);
152 let open_goal = List.hd open_goals in
153 let gty = get_goalty status open_goal in
154 let ctx = ctx_of gty in
157 let height_of_ref status (NReference.Ref (uri, x)) =
162 | NReference.CoFix _ ->
163 let _,height,_,_,_ = NCicEnvironment.get_checked_obj status uri in
165 | NReference.Def h -> h
166 | NReference.Fix (_,_,h) -> h
169 (*************************** height functions ********************************)
170 let fast_height_of_term status t =
174 NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l
178 | NCic.Implicit _ -> assert false
181 prerr_endline (status#ppterm ~metasenv:[] ~subst:[]
182 ~context:[] t ^ ":" ^ string_of_int (height_of_ref status nref));
184 h := max !h (height_of_ref status nref)
185 | NCic.Prod (_,t1,t2)
186 | NCic.Lambda (_,t1,t2) -> aux t1; aux t2
187 | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
188 | NCic.Appl l -> List.iter aux l
189 | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
194 let height_of_goal g status =
195 let ty = get_goalty status g in
196 let context = ctx_of ty in
197 let _, ty = term_of_cic_term status ty (ctx_of ty) in
198 let h = ref (fast_height_of_term status ty) in
201 | _, NCic.Decl ty -> h := max !h (fast_height_of_term status ty)
202 | _, NCic.Def (bo,ty) ->
203 h := max !h (fast_height_of_term status ty);
204 h := max !h (fast_height_of_term status bo);
210 let height_of_goals status =
211 let open_goals = head_goals status#stack in
212 assert (List.length open_goals > 0);
216 h := max !h (height_of_goal open_goal status))
218 noprint (lazy ("altezza sequente: " ^ string_of_int !h));
222 (* =============================== paramod =========================== *)
223 let solve f status eq_cache goal =
226 if fast then NCicParamod.fast_eq_check
227 else NCicParamod.paramod in
229 let n,h,metasenv,subst,o = status#obj in
230 let gname, ctx, gty = List.assoc goal metasenv in
231 let gty = NCicUntrusted.apply_subst status subst ctx gty in
232 let build_status (pt, _, metasenv, subst) =
234 noprint (lazy ("refining: "^(status#ppterm ctx subst metasenv pt)));
235 let stamp = Unix.gettimeofday () in
236 let metasenv, subst, pt, pty =
237 (* NCicRefiner.typeof status
238 (* (status#set_coerc_db NCicCoercion.empty_db) *)
239 metasenv subst ctx pt None in
240 debug_print (lazy ("refined: "^(status#ppterm ctx subst metasenv pt)));
241 noprint (lazy ("synt: "^(status#ppterm ctx subst metasenv pty)));
242 let metasenv, subst =
243 NCicUnification.unify status metasenv subst ctx gty pty *)
245 (status#set_coerc_db NCicCoercion.empty_db)
246 metasenv subst ctx pt (Some gty)
248 noprint (lazy (Printf.sprintf "Refined in %fs"
249 (Unix.gettimeofday() -. stamp)));
250 let status = status#set_obj (n,h,metasenv,subst,o) in
251 let metasenv = List.filter (fun j,_ -> j <> goal) metasenv in
252 let subst = (goal,(gname,ctx,pt,pty)) :: subst in
253 Some (status#set_obj (n,h,metasenv,subst,o))
255 NCicRefiner.RefineFailure msg
256 | NCicRefiner.Uncertain msg ->
257 debug_print (lazy ("WARNING: refining in fast_eq_check failed\n" ^
258 snd (Lazy.force msg) ^
259 "\n in the environment\n" ^
260 status#ppmetasenv subst metasenv)); None
261 | NCicRefiner.AssertFailure msg ->
262 debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^
264 "\n in the environment\n" ^
265 status#ppmetasenv subst metasenv)); None
268 HExtlib.filter_map build_status
269 (f status metasenv subst ctx eq_cache (NCic.Rel ~-1,gty))
272 let fast_eq_check eq_cache status (goal:int) =
273 match solve NCicParamod.fast_eq_check status eq_cache goal with
274 | [] -> raise (Error (lazy "no proof found",None))
278 let dist_fast_eq_check eq_cache s =
279 NTactics.distribute_tac (fast_eq_check eq_cache) s
282 let auto_eq_check eq_cache status =
284 let s = dist_fast_eq_check eq_cache status in
287 | Error _ -> debug_print (lazy ("no paramod proof found"));[]
290 let index_local_equations eq_cache status =
291 noprint (lazy "indexing equations");
292 let open_goals = head_goals status#stack in
293 let open_goal = List.hd open_goals in
294 let ngty = get_goalty status open_goal in
295 let ctx = apply_subst_context ~fix_projections:true status (ctx_of ngty) in
300 let t = NCic.Rel !c in
302 let ty = NCicTypeChecker.typeof status [] [] ctx t in
303 if is_a_fact status (mk_cic_term ctx ty) then
304 (noprint(lazy("eq indexing " ^ (status#ppterm ctx [] [] ty)));
305 NCicParamod.forward_infer_step eq_cache t ty)
307 (noprint (lazy ("not a fact: " ^ (status#ppterm ctx [] [] ty)));
310 | NCicTypeChecker.TypeCheckerFailure _
311 | NCicTypeChecker.AssertFailure _ -> eq_cache)
315 let fast_eq_check_tac ~params s =
316 let unit_eq = index_local_equations s#eq_cache s in
317 dist_fast_eq_check unit_eq s
320 let paramod eq_cache status goal =
321 match solve NCicParamod.paramod status eq_cache goal with
322 | [] -> raise (Error (lazy "no proof found",None))
326 let paramod_tac ~params s =
327 let unit_eq = index_local_equations s#eq_cache s in
328 NTactics.distribute_tac (paramod unit_eq) s
331 let demod eq_cache status goal =
332 match solve NCicParamod.demod status eq_cache goal with
333 | [] -> raise (Error (lazy "no progress",None))
337 let demod_tac ~params s =
338 let unit_eq = index_local_equations s#eq_cache s in
339 NTactics.distribute_tac (demod unit_eq) s
343 let fast_eq_check_tac_all ~params eq_cache status =
344 let g,_,_ = current_goal status in
345 let allstates = fast_eq_check_all status eq_cache g in
346 let pseudo_low_tac s _ _ = s in
347 let pseudo_low_tactics =
348 List.map pseudo_low_tac allstates
350 List.map (fun f -> NTactics.distribute_tac f status) pseudo_low_tactics
355 let demod status eq_cache goal =
356 let n,h,metasenv,subst,o = status#obj in
357 let gname, ctx, gty = List.assoc goal metasenv in
358 let gty = NCicUntrusted.apply_subst subst ctx gty in
360 let demod_tac ~params s =
361 let unit_eq = index_local_equations s#eq_cache s in
362 dist_fast_eq_check unit_eq s
365 (*************** subsumption ****************)
367 let close_wrt_context status =
371 | name, NCic.Decl t -> NCic.Prod(name,t,ty)
372 | name, NCic.Def(bo, _) -> NCicSubstitution.subst status bo ty)
375 let args_for_context ?(k=1) ctx =
378 (fun (n,l) ctx_entry ->
380 | name, NCic.Decl t -> n+1,NCic.Rel(n)::l
381 | name, NCic.Def(bo, _) -> n+1,l)
385 let constant_for_meta status ctx ty i =
386 let name = "cic:/foo"^(string_of_int i)^".con" in
387 let uri = NUri.uri_of_string name in
388 let ty = close_wrt_context status ty ctx in
389 (* prerr_endline (status#ppterm [] [] [] ty); *)
390 let attr = (`Generated,`Definition,`Local) in
391 let obj = NCic.Constant([],name,None,ty,attr) in
392 (* Constant of relevance * string * term option * term * c_attr *)
396 let refresh metasenv =
398 (fun (metasenv,subst) (i,(iattr,ctx,ty)) ->
399 let ikind = NCicUntrusted.kind_of_meta iattr in
400 let metasenv,j,instance,ty =
401 NCicMetaSubst.mk_meta ~attrs:iattr
402 metasenv ctx ~with_type:ty ikind in
403 let s_entry = i,(iattr, ctx, instance, ty) in
404 let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
405 metasenv,s_entry::subst)
406 (metasenv,[]) metasenv
408 (* close metasenv returns a ground instance of all the metas in the
409 metasenv, insantiatied with axioms, and the list of these axioms *)
410 let close_metasenv status metasenv subst =
412 let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
414 let metasenv = NCicUntrusted.sort_metasenv status subst metasenv in
416 (fun (subst,objs) (i,(iattr,ctx,ty)) ->
417 let ty = NCicUntrusted.apply_subst status subst ctx ty in
419 NCicUntrusted.apply_subst_context status ~fix_projections:true
421 let (uri,_,_,_,obj) as okind =
422 constant_for_meta status ctx ty i in
424 NCicEnvironment.check_and_add_obj status okind;
425 let iref = NReference.reference_of_spec uri NReference.Decl in
427 let args = args_for_context ctx in
428 if args = [] then NCic.Const iref
429 else NCic.Appl(NCic.Const iref::args)
431 (* prerr_endline (status#ppterm ctx [] [] iterm); *)
432 let s_entry = i, ([], ctx, iterm, ty)
433 in s_entry::subst,okind::objs
434 with _ -> assert false)
438 let ground_instances status gl =
439 let _,_,metasenv,subst,_ = status#obj in
440 let subset = menv_closure status gl in
441 let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
443 let submenv = metasenv in
445 let subst, objs = close_metasenv status submenv subst in
449 let (_, ctx, t, _) = List.assoc i subst in
450 noprint (lazy (status#ppterm ctx [] [] t));
452 (fun (uri,_,_,_,_) as obj ->
453 NCicEnvironment.invalidate_item (`Obj (uri, obj)))
458 Not_found -> assert false
462 let replace_meta status i args target =
463 let rec aux k = function
464 (* TODO: local context *)
465 | NCic.Meta (j,lc) when i = j ->
469 List.map (NCicSubstitution.subst_meta status lc) args in
470 NCic.Appl(NCic.Rel k::args))
471 | NCic.Meta (j,lc) as m ->
478 aux k (NCicSubstitution.lift status n t)) l))))
479 | t -> NCicUtils.map status (fun _ k -> k+1) k aux t
484 let close_wrt_metasenv status subst =
486 (fun ty (i,(iattr,ctx,mty)) ->
487 let mty = NCicUntrusted.apply_subst status subst ctx mty in
489 NCicUntrusted.apply_subst_context status ~fix_projections:true
491 let cty = close_wrt_context status mty ctx in
492 let name = "foo"^(string_of_int i) in
493 let ty = NCicSubstitution.lift status 1 ty in
494 let args = args_for_context ~k:1 ctx in
495 (* prerr_endline (status#ppterm ctx [] [] iterm); *)
496 let ty = replace_meta status i args ty
498 NCic.Prod(name,cty,ty))
502 let _,_,metasenv,subst,_ = status#obj in
503 let subset = menv_closure status [g] in
504 let subset = IntSet.remove g subset in
505 let elems = IntSet.elements subset in
506 let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
507 let ty = NCicUntrusted.apply_subst status subst ctx ty in
508 noprint (lazy ("metas in " ^ (status#ppterm ctx [] metasenv ty)));
509 noprint (lazy (String.concat ", " (List.map string_of_int elems)));
510 let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
511 let submenv = List.rev (NCicUntrusted.sort_metasenv status subst submenv) in
513 let submenv = metasenv in
515 let ty = close_wrt_metasenv status subst ty submenv in
516 noprint (lazy (status#ppterm ctx [] [] ty));
520 (****************** smart application ********************)
522 let saturate_to_ref status metasenv subst ctx nref ty =
523 let height = height_of_ref status nref in
524 let rec aux metasenv ty args =
525 let ty,metasenv,moreargs =
526 NCicMetaSubst.saturate status ~delta:height metasenv subst ctx ty 0 in
528 | NCic.Const(NReference.Ref (_,NReference.Def _) as nre)
530 let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
531 aux metasenv bo (args@moreargs)
532 | NCic.Appl(NCic.Const(NReference.Ref (_,NReference.Def _) as nre)::tl)
534 let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
535 aux metasenv (NCic.Appl(bo::tl)) (args@moreargs)
536 | _ -> ty,metasenv,(args@moreargs)
540 let smart_apply t unit_eq status g =
541 let n,h,metasenv,subst,o = status#obj in
542 let gname, ctx, gty = List.assoc g metasenv in
543 (* let ggty = mk_cic_term context gty in *)
544 let status, t = disambiguate status ctx t None in
545 let status,t = term_of_cic_term status t ctx in
546 let _,_,metasenv,subst,_ = status#obj in
547 let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
548 let ty,metasenv,args =
551 | NCic.Appl(NCic.Const(nref)::_) ->
552 saturate_to_ref status metasenv subst ctx nref ty
554 NCicMetaSubst.saturate status metasenv subst ctx ty 0 in
555 let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in
556 let status = status#set_obj (n,h,metasenv,subst,o) in
557 let pterm = if args=[] then t else
559 | NCic.Appl l -> NCic.Appl(l@args)
560 | _ -> NCic.Appl(t::args)
562 noprint(lazy("pterm " ^ (status#ppterm ctx [] [] pterm)));
563 noprint(lazy("pty " ^ (status#ppterm ctx [] [] ty)));
566 NUri.uri_of_string "cic:/matita/basics/logic/eq_coerc.con" in
567 let ref = NReference.reference_of_spec uri (NReference.Def(2)) in
571 NCic.Appl[eq_coerc;ty;NCic.Implicit `Type;pterm;inst] in
572 let smart = mk_cic_term ctx smart in
574 let status = instantiate status g smart in
575 let _,_,metasenv,subst,_ = status#obj in
576 let _,ctx,jty = List.assoc j metasenv in
577 let jty = NCicUntrusted.apply_subst status subst ctx jty in
578 noprint(lazy("goal " ^ (status#ppterm ctx [] [] jty)));
579 fast_eq_check unit_eq status j
581 | NCicEnvironment.ObjectNotFound s as e ->
582 raise (Error (lazy "eq_coerc non yet defined",Some e))
583 | Error _ as e -> debug_print (lazy "error"); raise e
585 let smart_apply_tac t s =
586 let unit_eq = index_local_equations s#eq_cache s in
587 NTactics.distribute_tac (smart_apply t unit_eq) s
589 let smart_apply_auto t eq_cache =
590 NTactics.distribute_tac (smart_apply t eq_cache)
593 (****************** types **************)
596 type th_cache = (NCic.context * InvRelDiscriminationTree.t) list
598 (* cartesian: term set list -> term list set *)
601 [] -> NDiscriminationTree.TermListSet.empty
603 NDiscriminationTree.TermSet.fold
604 (fun x acc -> NDiscriminationTree.TermListSet.add [x] acc) l NDiscriminationTree.TermListSet.empty
606 let rest = cartesian tl in
607 NDiscriminationTree.TermSet.fold
609 NDiscriminationTree.TermListSet.fold (fun l acc' -> NDiscriminationTree.TermListSet.add (x::l) acc') rest acc
610 ) he NDiscriminationTree.TermListSet.empty
613 (* all_keys_of_cic_type: term -> term set *)
614 let all_keys_of_cic_type status metasenv subst context ty =
616 (* Here we are dropping the metasenv, but this should not raise any
617 exception (hopefully...) *)
619 NCicMetaSubst.saturate status ~delta:max_int metasenv subst context ty 0
625 NCic.Appl (he::tl) ->
628 let wty = NCicReduction.whd status ~delta:0 ~subst context ty in
630 NDiscriminationTree.TermSet.add ty (aux ty)
632 NDiscriminationTree.TermSet.union
633 (NDiscriminationTree.TermSet.add ty (aux ty))
634 (NDiscriminationTree.TermSet.add wty (aux wty))
637 NDiscriminationTree.TermListSet.fold
638 (fun l acc -> NDiscriminationTree.TermSet.add (NCic.Appl l) acc)
639 (cartesian ((NDiscriminationTree.TermSet.singleton he)::tl'))
640 NDiscriminationTree.TermSet.empty
641 | _ -> NDiscriminationTree.TermSet.empty
643 let ty,ity = saturate ty in
644 let wty,iwty = saturate (NCicReduction.whd status ~delta:0 ~subst context ty) in
646 [ity, NDiscriminationTree.TermSet.add ty (aux ty)]
648 [ity, NDiscriminationTree.TermSet.add ty (aux ty) ;
649 iwty, NDiscriminationTree.TermSet.add wty (aux wty) ]
652 let all_keys_of_type status t =
653 let _,_,metasenv,subst,_ = status#obj in
654 let context = ctx_of t in
655 let status, t = apply_subst status context t in
657 all_keys_of_cic_type status metasenv subst context
658 (snd (term_of_cic_term status t context))
662 (fun (intros,keys) ->
664 NDiscriminationTree.TermSet.fold
665 (fun t acc -> Ncic_termSet.add (mk_cic_term context t) acc)
666 keys Ncic_termSet.empty
671 let keys_of_type status orig_ty =
672 (* Here we are dropping the metasenv (in the status), but this should not
673 raise any exception (hopefully...) *)
674 let _, ty, _ = saturate ~delta:max_int status orig_ty in
675 let _, ty = apply_subst status (ctx_of ty) ty in
678 let orig_ty' = NCicTacReduction.normalize ~subst context orig_ty in
679 if orig_ty' <> orig_ty then
680 let ty',_,_= NCicMetaSubst.saturate ~delta:0 metasenv subst context orig_ty' 0 in
686 (*CSC: strange: we keep ty, ty normalized and ty ~delta:(h-1) *)
688 let _, ty = term_of_cic_term status ty (ctx_of ty) in
690 | NCic.Const (NReference.Ref (_,(NReference.Def h | NReference.Fix (_,_,h))))
691 | NCic.Appl (NCic.Const(NReference.Ref(_,(NReference.Def h | NReference.Fix (_,_,h))))::_)
693 let _,ty,_= saturate status ~delta:(h-1) orig_ty in
700 let all_keys_of_term status t =
701 let status, orig_ty = typeof status (ctx_of t) t in
702 all_keys_of_type status orig_ty
705 let keys_of_term status t =
706 let status, orig_ty = typeof status (ctx_of t) t in
707 keys_of_type status orig_ty
710 let mk_th_cache status gl =
712 (fun (status, acc) g ->
713 let gty = get_goalty status g in
714 let ctx = ctx_of gty in
715 noprint(lazy("th cache for: "^ppterm status gty));
716 noprint(lazy("th cache in: "^ppcontext status ctx));
717 if List.mem_assq ctx acc then status, acc else
718 let idx = InvRelDiscriminationTree.empty in
721 (fun (status, i, idx) _ ->
722 let t = mk_cic_term ctx (NCic.Rel i) in
723 let status, keys = keys_of_term status t in
724 noprint(lazy("indexing: "^ppterm status t ^ ": " ^ string_of_int (List.length keys)));
726 List.fold_left (fun idx k ->
727 InvRelDiscriminationTree.index idx k t) idx keys
732 status, (ctx, idx) :: acc)
736 let all_elements ctx cache =
737 let dummy = mk_cic_term ctx (NCic.Meta (0,(0, (NCic.Irl 0)))) in
739 let idx = List.assq ctx cache in
740 Ncic_termSet.elements
741 (InvRelDiscriminationTree.retrieve_unifiables idx dummy)
744 let add_to_th t c ty =
745 let key_c = ctx_of t in
746 if not (List.mem_assq key_c c) then
747 (key_c ,InvRelDiscriminationTree.index
748 InvRelDiscriminationTree.empty ty t ) :: c
750 let rec replace = function
752 | (x, idx) :: tl when x == key_c ->
753 (x, InvRelDiscriminationTree.index idx ty t) :: tl
754 | x :: tl -> x :: replace tl
759 let rm_from_th t c ty =
760 let key_c = ctx_of t in
761 if not (List.mem_assq key_c c) then assert false
763 let rec replace = function
765 | (x, idx) :: tl when x == key_c ->
766 (x, InvRelDiscriminationTree.remove_index idx ty t) :: tl
767 | x :: tl -> x :: replace tl
772 let pp_idx status idx =
773 InvRelDiscriminationTree.iter idx
775 noprint(lazy("K: " ^ NCicInverseRelIndexable.string_of_path k));
777 (fun t -> debug_print(lazy("\t"^ppterm status t)))
781 let pp_th (status: #NTacStatus.pstatus) =
784 noprint(lazy( "-----------------------------------------------"));
785 noprint(lazy( (status#ppcontext ~metasenv:[] ~subst:[] ctx)));
786 noprint(lazy( "||====> "));
790 let search_in_th gty th =
791 let c = ctx_of gty in
792 let rec aux acc = function
793 | [] -> (* Ncic_termSet.elements *) acc
796 let idx = List.assoc(*q*) k th in
797 let acc = Ncic_termSet.union acc
798 (InvRelDiscriminationTree.retrieve_unifiables idx gty)
801 with Not_found -> aux acc tl
803 aux Ncic_termSet.empty c
807 do_types : bool; (* solve goals in Type *)
808 last : bool; (* last goal: take first solution only *)
809 candidates: Ast.term list option;
817 {facts : th_cache; (* positive results *)
818 under_inspection : cic_term list * th_cache; (* to prune looping *)
819 failures : th_cache; (* to avoid repetitions *)
820 unit_eq : NCicParamod.state;
824 let add_to_trace status ~depth cache t =
827 debug_print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term status t));
828 {cache with trace = t::cache.trace}
829 | Ast.NCic _ (* local candidate *)
830 | _ -> (*not an application *) cache
832 let pptrace status tr =
833 (lazy ("Proof Trace: " ^ (String.concat ";"
834 (List.map (NotationPp.pp_term status) tr))))
836 let remove_from_trace cache t =
839 (match cache.trace with
840 | _::tl -> {cache with trace = tl}
842 | Ast.NCic _ (* local candidate *)
843 | _ -> (*not an application *) cache *)
846 type goal = int * sort (* goal, depth, sort *)
847 type fail = goal * cic_term
848 type candidate = int * Ast.term (* unique candidate number, candidate *)
850 exception Gaveup of th_cache (* failure cache *)
851 exception Proved of NTacStatus.tac_status * Ast.term list
853 (* let close_failures _ c = c;; *)
854 (* let prunable _ _ _ = false;; *)
855 (* let cache_examine cache gty = `Notfound;; *)
856 (* let put_in_subst s _ _ _ = s;; *)
857 (* let add_to_cache_and_del_from_orlist_if_green_cut _ _ c _ _ o f _ = c, o, f, false ;; *)
858 (* let cache_add_underinspection c _ _ = c;; *)
860 let init_cache ?(facts=[]) ?(under_inspection=[],[])
862 ?(unit_eq=NCicParamod.empty_state)
867 under_inspection = under_inspection;
871 let only signature _context candidate = true
873 (* TASSI: nel trie ci mettiamo solo il body, non il ty *)
875 NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate
877 let height = fast_height_of_term status candidate_ty in
878 let rc = signature >= height in
880 noprint (lazy ("Filtro: " ^ status#ppterm ~context:[] ~subst:[]
881 ~metasenv:[] candidate ^ ": " ^ string_of_int height))
883 noprint (lazy ("Tengo: " ^ status#ppterm ~context:[] ~subst:[]
884 ~metasenv:[] candidate ^ ": " ^ string_of_int height));
889 let candidate_no = ref 0;;
891 let openg_no status = List.length (head_goals status#stack)
893 let sort_candidates status ctx candidates =
894 let _,_,metasenv,subst,_ = status#obj in
896 let status,ct = disambiguate status ctx ("",0,cand) None in
897 let status,t = term_of_cic_term status ct ctx in
898 let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
899 let res = branch status (mk_cic_term ctx ty) in
900 noprint (lazy ("branch factor for: " ^ (ppterm status ct) ^ " = "
901 ^ (string_of_int res)));
904 let candidates = List.map (fun t -> branch t,t) candidates in
906 List.sort (fun (a,_) (b,_) -> a - b) candidates in
907 let candidates = List.map snd candidates in
908 debug_print (lazy ("candidates =\n" ^ (String.concat "\n"
909 (List.map (NotationPp.pp_term status) candidates))));
912 let sort_new_elems l =
913 List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l
915 let try_candidate ?(smart=0) flags depth status eq_cache ctx t =
917 debug_print ~depth (lazy ("try " ^ (NotationPp.pp_term status) t));
919 if smart= 0 then NTactics.apply_tac ("",0,t) status
920 else if smart = 1 then smart_apply_auto ("",0,t) eq_cache status
921 else (* smart = 2: both *)
922 try NTactics.apply_tac ("",0,t) status
924 smart_apply_auto ("",0,t) eq_cache status
927 let og_no = openg_no status in
928 if (* og_no > flags.maxwidth || *)
929 ((depth + 1) = flags.maxdepth && og_no <> 0) then
930 (debug_print ~depth (lazy "pruned immediately"); None)
933 let status, cict = disambiguate status ctx ("",0,t) None in
934 let status,ct = term_of_cic_term status cict ctx in
935 let _,_,metasenv,subst,_ = status#obj in
936 let ty = NCicTypeChecker.typeof subst metasenv ctx ct in
937 let res = branch status (mk_cic_term ctx ty) in
938 if smart=1 && og_no > res then
939 (debug_print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = "
940 ^ (string_of_int res) ^ " vs. " ^ (string_of_int og_no)));
941 debug_print ~depth (lazy "strange application"); None)
944 Some ((!candidate_no,t),status))
945 with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
948 let sort_of status subst metasenv ctx t =
949 let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
950 let metasenv',ty = NCicUnification.fix_sorts status metasenv subst ty in
951 assert (metasenv = metasenv');
952 NCicTypeChecker.typeof status subst metasenv ctx ty
955 let type0= NUri.uri_of_string ("cic:/matita/pts/Type0.univ")
958 let perforate_small status subst metasenv context t =
959 let rec aux = function
960 | NCic.Appl (hd::tl) ->
962 let s = sort_of status subst metasenv context t in
964 | NCic.Sort(NCic.Type [`Type,u])
965 when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0))
968 NCic.Appl (hd::List.map map tl)
974 let get_cands retrieve_for diff empty gty weak_gty =
975 let cands = retrieve_for gty in
977 | None -> cands, empty
979 let more_cands = retrieve_for weak_gty in
980 cands, diff more_cands cands
983 let get_candidates ?(smart=true) depth flags status cache signature gty =
984 let maxd = ((depth + 1) = flags.maxdepth) in
985 let universe = status#auto_cache in
986 let _,_,metasenv,subst,_ = status#obj in
987 let context = ctx_of gty in
988 let _, raw_gty = term_of_cic_term status gty context in
989 debug_print ~depth (lazy ("gty:" ^ NTacStatus.ppterm status gty));
990 let raw_weak_gty, weak_gty =
997 perforate_small status subst metasenv context raw_gty in
998 let weak = mk_cic_term context raw_weak in
999 debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak));
1000 Some raw_weak, Some (weak)
1004 let global_cands, smart_global_cands =
1005 match flags.candidates with
1006 | Some l when (not maxd) -> l,[]
1010 let to_ast = function
1011 | NCic.Const r when true (*is_relevant statistics r*) -> Some (Ast.NRef r)
1012 (* | NCic.Const _ -> None *)
1013 | _ -> assert false in
1015 to_ast (NDiscriminationTree.TermSet.elements s) in
1018 (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1020 NDiscriminationTree.TermSet.diff
1021 NDiscriminationTree.TermSet.empty
1022 raw_gty raw_weak_gty in
1024 let local_cands,smart_local_cands =
1027 let _status, t = term_of_cic_term status t context
1029 List.map to_ast (Ncic_termSet.elements s) in
1032 (fun ty -> search_in_th ty cache)
1033 Ncic_termSet.diff Ncic_termSet.empty gty weak_gty in
1035 sort_candidates status context (global_cands@local_cands),
1036 sort_candidates status context (smart_global_cands@smart_local_cands)
1040 let get_candidates ?(smart=true) status cache signature gty =
1041 let universe = status#auto_cache in
1042 let _,_,metasenv,subst,_ = status#obj in
1043 let context = ctx_of gty in
1045 let _status, t = term_of_cic_term status t context
1047 let c_ast = function
1048 | NCic.Const r -> Ast.NRef r | _ -> assert false in
1049 let _, raw_gty = term_of_cic_term status gty context in
1050 let keys = all_keys_of_cic_term metasenv subst context raw_gty in
1051 (* we only keep those keys that do not require any intros for now *)
1052 let no_intros_keys = snd (List.hd keys) in
1054 NDiscriminationTree.TermSet.fold
1056 NDiscriminationTree.TermSet.union acc
1057 (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1059 ) no_intros_keys NDiscriminationTree.TermSet.empty in
1061 let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1065 NDiscriminationTree.TermSet.fold
1067 Ncic_termSet.union acc (search_in_th (mk_cic_term context ty) cache)
1068 ) no_intros_keys Ncic_termSet.empty in
1070 let local_cands = search_in_th gty cache in
1072 debug_print (lazy ("candidates for" ^ NTacStatus.ppterm status gty));
1073 debug_print (lazy ("local cands = " ^ (string_of_int (List.length (Ncic_termSet.elements local_cands)))));
1074 let together global local =
1076 (List.filter (only signature context)
1077 (NDiscriminationTree.TermSet.elements global)) @
1078 List.map t_ast (Ncic_termSet.elements local) in
1079 let candidates = together cands local_cands in
1080 let candidates = sort_candidates status context candidates in
1081 let smart_candidates =
1087 let weak_gty = perforate_small status subst metasenv context raw_gty in
1089 NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
1090 (List.length tl)) in *)
1092 NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1096 NDiscriminationTree.TermSet.diff more_cands cands in
1097 let cic_weak_gty = mk_cic_term context weak_gty in
1098 let more_local_cands = search_in_th cic_weak_gty cache in
1099 let smart_local_cands =
1100 Ncic_termSet.diff more_local_cands local_cands in
1101 together smart_cands smart_local_cands
1102 (* together more_cands more_local_cands *)
1106 let smart_candidates = sort_candidates status context smart_candidates in
1107 (* if smart then smart_candidates, []
1108 else candidates, [] *)
1109 candidates, smart_candidates
1112 let get_candidates ?(smart=true) flags status cache signature gty =
1113 match flags.candidates with
1114 | None -> get_candidates ~smart status cache signature gty
1118 let applicative_case depth signature status flags gty cache =
1119 app_counter:= !app_counter+1;
1120 let _,_,metasenv,subst,_ = status#obj in
1121 let context = ctx_of gty in
1122 let tcache = cache.facts in
1123 let is_prod, is_eq =
1124 let status, t = term_of_cic_term status gty context in
1125 let t = NCicReduction.whd status subst context t in
1127 | NCic.Prod _ -> true, false
1128 | _ -> false, NCicParamod.is_equation status metasenv subst context t
1130 debug_print ~depth (lazy (string_of_bool is_eq));
1132 let candidates, smart_candidates =
1133 get_candidates ~smart:(not is_eq) depth
1134 flags status tcache signature gty in
1135 (* if the goal is an equation we avoid to apply unit equalities,
1136 since superposition should take care of them; refl is an
1137 exception since it prompts for convertibility *)
1139 let test x = not (is_a_fact_ast status subst metasenv context x) in
1141 Ast.Ident("refl",None) ::List.filter test candidates
1142 else candidates in *)
1144 let candidates, smart_candidates =
1145 get_candidates ~smart:true depth
1146 flags status tcache signature gty in
1147 (* if the goal is an equation we avoid to apply unit equalities,
1148 since superposition should take care of them; refl is an
1149 exception since it prompts for convertibility *)
1150 let candidates,smart_candidates =
1151 let test x = not (is_a_fact_ast status subst metasenv context x) in
1153 Ast.Ident("refl",None) ::List.filter test candidates,
1154 List.filter test smart_candidates
1155 else candidates,smart_candidates in
1157 (lazy ("candidates: " ^ string_of_int (List.length candidates)));
1159 (lazy ("smart candidates: " ^
1160 string_of_int (List.length smart_candidates)));
1163 let smart_candidates = [] in *)
1164 let sm = if is_eq then 0 else 2 in
1165 (* wrong: we constraint maxdepth for equality goals to three *)
1166 (* let maxdepth = if is_eq then min flags.maxdepth 6 else flags.maxdepth in *)
1167 let maxd = (depth + 1 = flags.maxdepth) in
1168 let only_one = flags.last && maxd in
1169 debug_print ~depth (lazy ("only_one: " ^ (string_of_bool only_one)));
1170 debug_print ~depth (lazy ("maxd: " ^ (string_of_bool maxd)));
1174 if (only_one && (elems <> [])) then elems
1176 if (maxd && not(is_prod) &
1177 not(is_a_fact_ast status subst metasenv context cand))
1178 then (debug_print ~depth (lazy "pruned: not a fact"); elems)
1180 match try_candidate (~smart:sm)
1181 flags depth status cache.unit_eq context cand with
1183 | Some x -> x::elems)
1187 if only_one && elems <> [] then elems
1191 if (only_one && (elems <> [])) then elems
1193 if (maxd && not(is_prod) &&
1194 not(is_a_fact_ast status subst metasenv context cand))
1195 then (debug_print ~depth (lazy "pruned: not a fact"); elems)
1197 match try_candidate (~smart:2) (* was smart:1 *)
1198 flags depth status cache.unit_eq context cand with
1200 | Some x -> x::elems)
1210 (* gty is supposed to be meta-closed *)
1211 let is_subsumed depth filter_depth status gty cache =
1212 if cache=[] then false else (
1213 debug_print ~depth (lazy("Subsuming " ^ (ppterm status gty)));
1214 let n,h,metasenv,subst,obj = status#obj in
1215 let ctx = ctx_of gty in
1216 let _ , raw_gty = term_of_cic_term status gty ctx in
1217 let target = NCicSubstitution.lift status 1 raw_gty in
1218 (* we compute candidates using the perforated type *)
1225 perforate_small status subst metasenv ctx raw_gty in
1226 let weak = mk_cic_term ctx raw_weak in
1227 debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak));
1231 (* candidates must only be searched w.r.t the given context *)
1234 let idx = List.assq ctx cache in
1237 Ncic_termSet.elements
1238 (InvRelDiscriminationTree.retrieve_unifiables idx weak)
1240 with Not_found -> []
1242 (* this is a dirty trick: the first argument of an application is used
1243 to remember at which depth a goal failed *)
1245 let ctx = ctx_of t in
1246 let _, src = term_of_cic_term status t ctx in
1248 | NCic.Appl [NCic.Implicit (`Typeof d); t]
1249 when d <= depth -> Some (mk_cic_term ctx t)
1252 if filter_depth then HExtlib.filter_map filter candidates else candidates in
1254 (lazy ("failure candidates: " ^ string_of_int (List.length candidates)));
1258 let _ , source = term_of_cic_term status t ctx in
1260 NCic.Prod("foo",source,target) in
1261 let metasenv,j,_,_ =
1262 NCicMetaSubst.mk_meta
1263 metasenv ctx ~with_type:implication `IsType in
1264 let status = status#set_obj (n,h,metasenv,subst,obj) in
1265 let status = status#set_stack [([1,Open j],[],[],`NoTag)] in
1267 let status = NTactics.intro_tac "foo" status in
1269 NTactics.apply_tac ("",0,Ast.NCic (NCic.Rel 1)) status
1271 if (head_goals status#stack = []) then raise Found
1276 with Found -> debug_print ~depth (lazy "success");true)
1279 let rec guess_name name ctx =
1280 if name = "_" then guess_name "auto" ctx else
1281 if not (List.mem_assoc name ctx) then name else
1282 guess_name (name^"'") ctx
1285 let is_prod status =
1286 let _, ctx, gty = current_goal status in
1287 let status, gty = apply_subst status ctx gty in
1288 let _, raw_gty = term_of_cic_term status gty ctx in
1290 | NCic.Prod (name,src,_) ->
1291 let status, src = whd status ~delta:0 ctx (mk_cic_term ctx src) in
1292 (match snd (term_of_cic_term status src ctx) with
1293 | NCic.Const(NReference.Ref (_,NReference.Ind _) as r)
1294 | NCic.Appl (NCic.Const(NReference.Ref (_,NReference.Ind _) as r)::_) ->
1295 let _,_,itys,_,_ = NCicEnvironment.get_checked_indtys status r in
1297 (* | [_,_,_,[_;_]] con nat va, ovviamente, in loop *)
1299 | [_,_,_,[]] -> `Inductive (guess_name name ctx)
1300 | _ -> `Some (guess_name name ctx))
1301 | _ -> `Some (guess_name name ctx))
1304 let intro ~depth status facts name =
1305 let status = NTactics.intro_tac name status in
1306 let _, ctx, ngty = current_goal status in
1307 let t = mk_cic_term ctx (NCic.Rel 1) in
1308 let status, keys = keys_of_term status t in
1309 let facts = List.fold_left (add_to_th t) facts keys in
1310 debug_print ~depth (lazy ("intro: "^ name));
1311 (* unprovability is not stable w.r.t introduction *)
1315 let rec intros_facts ~depth status facts =
1316 if List.length (head_goals status#stack) <> 1 then status, facts else
1317 match is_prod status with
1321 intro ~depth status facts name
1322 in intros_facts ~depth status facts
1323 (* | `Inductive name ->
1324 let status = NTactics.case1_tac name status in
1325 intros_facts ~depth status facts *)
1326 | _ -> status, facts
1329 let intros ~depth status cache =
1330 match is_prod status with
1333 let trace = cache.trace in
1335 intros_facts ~depth status cache.facts
1337 if head_goals status#stack = [] then
1338 let status = NTactics.merge_tac status in
1339 [(0,Ast.Ident("__intros",None)),status], cache
1341 (* we reindex the equation from scratch *)
1342 let unit_eq = index_local_equations status#eq_cache status in
1343 let status = NTactics.merge_tac status in
1344 [(0,Ast.Ident("__intros",None)),status],
1345 init_cache ~facts ~unit_eq () ~trace
1349 let reduce ~whd ~depth status g =
1350 let n,h,metasenv,subst,o = status#obj in
1351 let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in
1352 let ty = NCicUntrusted.apply_subst status subst ctx ty in
1354 (if whd then NCicReduction.whd else NCicTacReduction.normalize) status ~subst ctx ty
1359 (lazy ("reduced to: "^ status#ppterm ctx subst metasenv ty'));
1361 (g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv)
1363 let status = status#set_obj (n,h,metasenv,subst,o) in
1364 (* we merge to gain a depth level; the previous goal level should
1366 let status = NTactics.merge_tac status in
1368 [(!candidate_no,Ast.Ident("__whd",None)),status])
1371 let do_something signature flags status g depth gty cache =
1372 let l0, cache = intros ~depth status cache in
1373 if l0 <> [] then l0, cache
1376 let l = reduce ~whd:true ~depth status g in
1377 (* if l <> [] then l,cache else *)
1378 (* backward aplications *)
1383 ((!candidate_no,Ast.Ident("__paramod",None)),s))
1384 (auto_eq_check cache.unit_eq status)
1387 if ((l1 <> []) && flags.last) then [] else
1388 applicative_case depth signature status flags gty cache
1392 (fun ((_,t),_) -> toref incr_nominations statistics t) l2;
1393 (* states in l1 have have an empty set of subgoals: no point to sort them *)
1395 (lazy ("alternatives = " ^ (string_of_int (List.length (l1@l@l2)))));
1396 (* we order alternatives w.r.t the number of subgoals they open *)
1397 l1 @ (sort_new_elems l2) @ l, cache
1400 let pp_goal = function
1401 | (_,Continuationals.Stack.Open i)
1402 | (_,Continuationals.Stack.Closed i) -> string_of_int i
1405 let pp_goals status l =
1409 let gty = get_goalty status i in
1410 NTacStatus.ppterm status gty)
1417 let compare = Pervasives.compare
1421 module MS = HTopoSort.Make(M)
1424 let sort_tac status =
1426 match status#stack with
1427 | [] -> assert false
1428 | (goals, t, k, tag) :: s ->
1429 let g = head_goals status#stack in
1431 (List.rev (MS.topological_sort g (deps status))) in
1432 noprint (lazy ("old g = " ^
1433 String.concat "," (List.map string_of_int g)));
1434 noprint (lazy ("sorted goals = " ^
1435 String.concat "," (List.map string_of_int sortedg)));
1436 let is_it i = function
1437 | (_,Continuationals.Stack.Open j )
1438 | (_,Continuationals.Stack.Closed j ) -> i = j
1441 List.map (fun i -> List.find (is_it i) goals) sortedg
1443 (sorted_goals, t, k, tag) :: s
1445 status#set_stack gstatus
1448 let clean_up_tac status =
1450 match status#stack with
1451 | [] -> assert false
1452 | (g, t, k, tag) :: s ->
1453 let is_open = function
1454 | (_,Continuationals.Stack.Open _) -> true
1455 | (_,Continuationals.Stack.Closed _) -> false
1457 let g' = List.filter is_open g in
1458 (g', t, k, tag) :: s
1460 status#set_stack gstatus
1463 let focus_tac focus status =
1465 match status#stack with
1466 | [] -> assert false
1467 | (g, t, k, tag) :: s ->
1468 let in_focus = function
1469 | (_,Continuationals.Stack.Open i)
1470 | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1472 let focus,others = List.partition in_focus g
1474 (* we need to mark it as a BranchTag, otherwise cannot merge later *)
1475 (focus,[],[],`BranchTag) :: (others, t, k, tag) :: s
1477 status#set_stack gstatus
1480 let deep_focus_tac level focus status =
1481 let in_focus = function
1482 | (_,Continuationals.Stack.Open i)
1483 | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1485 let rec slice level gs =
1486 if level = 0 then [],[],gs else
1488 | [] -> assert false
1489 | (g, t, k, tag) :: s ->
1490 let f,o,gs = slice (level-1) s in
1491 let f1,o1 = List.partition in_focus g
1493 (f1,[],[],`BranchTag)::f, (o1, t, k, tag)::o, gs
1496 let f,o,s = slice level status#stack in f@o@s
1498 status#set_stack gstatus
1501 let rec stack_goals level gs =
1502 if level = 0 then []
1504 | [] -> assert false
1506 let is_open = function
1507 | (_,Continuationals.Stack.Open i) -> Some i
1508 | (_,Continuationals.Stack.Closed _) -> None
1510 HExtlib.filter_map is_open g @ stack_goals (level-1) s
1513 let open_goals level status = stack_goals level status#stack
1516 let move_to_side level status =
1517 match status#stack with
1518 | [] -> assert false
1520 let is_open = function
1521 | (_,Continuationals.Stack.Open i) -> Some i
1522 | (_,Continuationals.Stack.Closed _) -> None
1524 let others = menv_closure status (stack_goals (level-1) tl) in
1525 List.for_all (fun i -> IntSet.mem i others)
1526 (HExtlib.filter_map is_open g)
1528 let rec auto_clusters ?(top=false)
1529 flags signature cache depth status : unit =
1530 debug_print ~depth (lazy ("entering auto clusters at depth " ^
1531 (string_of_int depth)));
1532 debug_print ~depth (pptrace status cache.trace);
1533 (* ignore(Unix.select [] [] [] 0.01); *)
1534 let status = clean_up_tac status in
1535 let goals = head_goals status#stack in
1537 if depth = 0 then raise (Proved (status, cache.trace))
1539 let status = NTactics.merge_tac status in
1541 let l,tree = cache.under_inspection in
1543 | [] -> cache (* possible because of intros that cleans the cache *)
1544 | a::tl -> let tree = rm_from_th a tree a in
1545 {cache with under_inspection = tl,tree}
1547 auto_clusters flags signature cache (depth-1) status
1548 else if List.length goals < 2 then
1549 auto_main flags signature cache depth status
1551 let all_goals = open_goals (depth+1) status in
1552 debug_print ~depth (lazy ("goals = " ^
1553 String.concat "," (List.map string_of_int all_goals)));
1554 let classes = HExtlib.clusters (deps status) all_goals in
1555 (* if any of the classes exceed maxwidth we fail *)
1558 if List.length gl > flags.maxwidth then
1560 debug_print ~depth (lazy "FAIL GLOBAL WIDTH");
1561 HLog.warn (sprintf "global width (%u) exceeded: %u"
1562 flags.maxwidth (List.length gl));
1563 raise (Gaveup cache.failures)
1564 end else ()) classes;
1565 if List.length classes = 1 then
1567 {flags with last = (List.length all_goals = 1)} in
1568 (* no need to cluster *)
1569 auto_main flags signature cache depth status
1571 let classes = if top then List.rev classes else classes in
1577 ("cluster:" ^ String.concat "," (List.map string_of_int l)))
1579 (* we now process each cluster *)
1580 let status,cache,b =
1582 (fun (status,cache,b) gl ->
1584 {flags with last = (List.length gl = 1)} in
1585 let lold = List.length status#stack in
1586 debug_print ~depth (lazy ("stack length = " ^
1587 (string_of_int lold)));
1588 let fstatus = deep_focus_tac (depth+1) gl status in
1590 debug_print ~depth (lazy ("focusing on" ^
1591 String.concat "," (List.map string_of_int gl)));
1592 auto_main flags signature cache depth fstatus; assert false
1594 | Proved(status,trace) ->
1595 let status = NTactics.merge_tac status in
1596 let cache = {cache with trace = trace} in
1597 let lnew = List.length status#stack in
1598 assert (lold = lnew);
1600 | Gaveup failures when top ->
1601 let cache = {cache with failures = failures} in
1604 (status,cache,false) classes
1606 let rec final_merge n s =
1607 if n = 0 then s else final_merge (n-1) (NTactics.merge_tac s)
1608 in let status = final_merge depth status
1609 in if b then raise (Proved(status,cache.trace)) else raise (Gaveup cache.failures)
1613 (* BRAND NEW VERSION *)
1614 auto_main flags signature cache depth status: unit =
1615 debug_print ~depth (lazy "entering auto main");
1616 debug_print ~depth (pptrace status cache.trace);
1617 debug_print ~depth (lazy ("stack length = " ^
1618 (string_of_int (List.length status#stack))));
1619 (* ignore(Unix.select [] [] [] 0.01); *)
1620 let status = sort_tac (clean_up_tac status) in
1621 let goals = head_goals status#stack in
1623 | [] when depth = 0 -> raise (Proved (status,cache.trace))
1625 let status = NTactics.merge_tac status in
1627 let l,tree = cache.under_inspection in
1629 | [] -> cache (* possible because of intros that cleans the cache *)
1630 | a::tl -> let tree = rm_from_th a tree a in
1631 {cache with under_inspection = tl,tree}
1633 auto_clusters flags signature cache (depth-1) status
1635 if depth > 0 && move_to_side depth status
1637 let status = NTactics.merge_tac status in
1639 let l,tree = cache.under_inspection in
1641 | [] -> cache (* possible because of intros that cleans the cache*)
1642 | a::tl -> let tree = rm_from_th a tree a in
1643 {cache with under_inspection = tl,tree}
1645 auto_clusters flags signature cache (depth-1) status
1647 let ng = List.length goals in
1648 (* moved inside auto_clusters *)
1649 if ng > flags.maxwidth then begin
1650 debug_print ~depth (lazy "FAIL LOCAL WIDTH");
1651 HLog.warn (sprintf "local width (%u) exceeded: %u"
1653 raise (Gaveup cache.failures)
1654 end else if depth = flags.maxdepth then
1655 raise (Gaveup cache.failures)
1657 let status = NTactics.branch_tac ~force:true status in
1658 let g,gctx, gty = current_goal status in
1659 let ctx,ty = close status g in
1660 let closegty = mk_cic_term ctx ty in
1661 let status, gty = apply_subst status gctx gty in
1662 debug_print ~depth (lazy("Attacking goal " ^
1663 string_of_int g ^ " : "^ppterm status gty));
1664 debug_print ~depth (lazy ("current failures: " ^
1665 string_of_int (List.length (all_elements ctx cache.failures))));
1667 let _,_,metasenv,subst,_ = status#obj in
1668 NCicParamod.is_equation status metasenv subst ctx ty in
1669 (* if the goal is an equality we artificially raise its depth up to
1670 flags.maxdepth - 1 *)
1671 if (not flags.last && is_eq && (depth < (flags.maxdepth -2))) then
1672 (* for efficiency reasons, in this case we severely cripple the
1674 (debug_print ~depth (lazy ("RAISING DEPTH TO " ^ string_of_int (depth+1)));
1675 auto_main flags signature cache (depth+1) status)
1676 (* check for loops *)
1677 else if is_subsumed depth false status closegty (snd cache.under_inspection) then
1678 (debug_print ~depth (lazy "SUBSUMED");
1679 raise (Gaveup cache.failures))
1680 (* check for failures *)
1681 else if is_subsumed depth true status closegty cache.failures then
1682 (debug_print ~depth (lazy "ALREADY MET");
1683 raise (Gaveup cache.failures))
1685 let new_sig = height_of_goal g status in
1686 if new_sig < signature then
1687 (debug_print ~depth (lazy ("news = " ^ (string_of_int new_sig)));
1688 debug_print ~depth (lazy ("olds = " ^ (string_of_int signature))));
1689 let alternatives, cache =
1690 do_something signature flags status g depth gty cache in
1693 let l,tree = cache.under_inspection in
1694 let l,tree = closegty::l, add_to_th closegty tree closegty in
1695 {cache with under_inspection = l,tree}
1699 (fun allfailures ((_,t),status) ->
1701 (lazy ("(re)considering goal " ^
1702 (string_of_int g) ^" : "^ppterm status gty));
1703 debug_print (~depth:depth)
1704 (lazy ("Case: " ^ NotationPp.pp_term status t));
1706 if t=Ast.Ident("__whd",None) ||
1707 t=Ast.Ident("__intros",None)
1709 else depth+1,loop_cache in
1710 let cache = add_to_trace status ~depth cache t in
1711 let cache = {cache with failures = allfailures} in
1713 auto_clusters flags signature cache depth status;
1716 debug_print ~depth (lazy "Failed");
1718 cache.failures alternatives in
1722 let dty = NCic.Appl [NCic.Implicit (`Typeof depth); ty] in
1725 (*prerr_endline ("FAILURE : " ^ ppterm status gty);*)
1726 add_to_th newfail failures closegty
1728 debug_print ~depth (lazy "no more candidates");
1729 raise (Gaveup failures)
1732 let int name l def =
1733 try int_of_string (List.assoc name l)
1734 with Failure _ | Not_found -> def
1737 module AstSet = Set.Make(struct type t = Ast.term let compare = compare end)
1739 let cleanup_trace s trace =
1740 (* removing duplicates *)
1743 (fun acc t -> AstSet.add t acc)
1744 AstSet.empty trace in
1745 let trace = AstSet.elements trace_set
1746 (* filtering facts *)
1750 | Ast.NRef (NReference.Ref (u,_)) -> not (is_a_fact_obj s u)
1754 let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status =
1755 let oldstatus = status in
1756 let status = (status:> NTacStatus.tac_status) in
1757 let goals = head_goals status#stack in
1758 let status, facts = mk_th_cache status goals in
1759 let unit_eq = index_local_equations status#eq_cache status in
1760 let cache = init_cache ~facts ~unit_eq () in
1761 (* pp_th status facts; *)
1763 NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
1765 NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
1766 String.concat "\n " (List.map (
1767 status#ppterm ~metasenv:[] ~context:[] ~subst:[])
1768 (NDiscriminationTree.TermSet.elements t))
1776 let status, res = disambiguate status [] t None in
1777 let _,res = term_of_cic_term status res (ctx_of res)
1779 in Some (List.map to_Ast l)
1781 let depth = int "depth" flags 3 in
1782 let size = int "size" flags 10 in
1783 let width = int "width" flags 4 (* (3+List.length goals)*) in
1785 (* let goals = List.map (fun i -> (i,P)) goals in *)
1786 let signature = height_of_goals status in
1789 candidates = candidates;
1793 timeout = Unix.gettimeofday() +. 3000.;
1796 let initial_time = Unix.gettimeofday() in
1801 ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1803 ("Applicative nodes:"^string_of_int !app_counter));
1804 raise (Error (lazy "auto gave up", None)))
1806 let _ = debug_print (lazy("\n\nRound "^string_of_int x^"\n")) in
1807 let flags = { flags with maxdepth = x }
1809 try auto_clusters (~top:true) flags signature cache 0 status;assert false
1811 try auto_main flags signature cache 0 status;assert false
1814 | Gaveup _ -> up_to (x+1) y
1815 | Proved (s,trace) ->
1816 debug_print (lazy ("proved at depth " ^ string_of_int x));
1817 List.iter (toref incr_uses statistics) trace;
1818 let trace = cleanup_trace s trace in
1819 let _ = debug_print (pptrace status trace) in
1822 | (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
1825 let s = s#set_stack stack in
1827 oldstatus#set_status s
1829 let s = up_to depth depth in
1830 debug_print (print_stat status statistics);
1832 ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1834 ("Applicative nodes:"^string_of_int !app_counter));
1838 let auto_tac ~params:(_,flags as params) ?trace_ref =
1839 if List.mem_assoc "demod" flags then
1841 else if List.mem_assoc "paramod" flags then
1843 else if List.mem_assoc "fast_paramod" flags then
1844 fast_eq_check_tac ~params
1845 else auto_tac ~params ?trace_ref