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 depth '\t'^Lazy.force s)
16 let noprint ?(depth=0) _ = ()
17 let debug_print = noprint
19 open Continuationals.Stack
21 module Ast = CicNotationPt
22 let app_counter = ref 0
24 (* ======================= utility functions ========================= *)
25 module IntSet = Set.Make(struct type t = int let compare = compare end)
27 let get_sgoalty status g =
28 let _,_,metasenv,subst,_ = status#obj in
30 let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
31 let ty = NCicUntrusted.apply_subst subst ctx ty in
32 let ctx = NCicUntrusted.apply_subst_context
33 ~fix_projections:true subst ctx
35 NTacStatus.mk_cic_term ctx ty
36 with NCicUtils.Meta_not_found _ as exn -> fail ~exn (lazy "get_sgoalty")
40 let gty = get_sgoalty status g in
41 metas_of_term status gty
44 let menv_closure status gl =
45 let rec closure acc = function
47 | x::l when IntSet.mem x acc -> closure acc l
48 | x::l -> closure (IntSet.add x acc) (deps status x @ l)
49 in closure IntSet.empty gl
52 (* we call a "fact" an object whose hypothesis occur in the goal
53 or in types of goal-variables *)
54 let branch status ty =
55 let status, ty, metas = saturate ~delta:0 status ty in
56 noprint (lazy ("saturated ty :" ^ (ppterm status ty)));
57 let g_metas = metas_of_term status ty in
58 let clos = menv_closure status g_metas in
59 (* let _,_,metasenv,_,_ = status#obj in *)
63 let _, m = term_of_cic_term status m (ctx_of m) in
65 | NCic.Meta(i,_) -> IntSet.add i acc
69 (* IntSet.subset menv clos *)
70 IntSet.cardinal(IntSet.diff menv clos)
72 let is_a_fact status ty = branch status ty = 0
74 let is_a_fact_obj s uri =
75 let obj = NCicEnvironment.get_checked_obj uri in
77 | (_,_,[],[],NCic.Constant(_,_,_,ty,_)) ->
78 is_a_fact s (mk_cic_term [] ty)
79 (* aggiungere i costruttori *)
82 let is_a_fact_ast status subst metasenv ctx cand =
84 (lazy ("------- checking " ^ CicNotationPp.pp_term cand));
85 let status, t = disambiguate status ctx ("",0,cand) None in
86 let status,t = term_of_cic_term status t ctx in
87 let ty = NCicTypeChecker.typeof subst metasenv ctx t in
88 is_a_fact status (mk_cic_term ctx ty)
90 let current_goal status =
91 let open_goals = head_goals status#stack in
92 assert (List.length open_goals = 1);
93 let open_goal = List.hd open_goals in
94 let gty = get_goalty status open_goal in
95 let ctx = ctx_of gty in
98 let height_of_ref (NReference.Ref (uri, x)) =
103 | NReference.CoFix _ ->
104 let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in
106 | NReference.Def h -> h
107 | NReference.Fix (_,_,h) -> h
110 (*************************** height functions ********************************)
111 let fast_height_of_term t =
115 NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l
119 | NCic.Implicit _ -> assert false
120 | NCic.Const nref as t ->
122 prerr_endline (NCicPp.ppterm ~metasenv:[] ~subst:[]
123 ~context:[] t ^ ":" ^ string_of_int (height_of_ref nref));
125 h := max !h (height_of_ref nref)
126 | NCic.Prod (_,t1,t2)
127 | NCic.Lambda (_,t1,t2) -> aux t1; aux t2
128 | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
129 | NCic.Appl l -> List.iter aux l
130 | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
135 let height_of_goal g status =
136 let ty = get_goalty status g in
137 let context = ctx_of ty in
138 let _, ty = term_of_cic_term status ty (ctx_of ty) in
139 let h = ref (fast_height_of_term ty) in
142 | _, NCic.Decl ty -> h := max !h (fast_height_of_term ty)
143 | _, NCic.Def (bo,ty) ->
144 h := max !h (fast_height_of_term ty);
145 h := max !h (fast_height_of_term bo);
151 let height_of_goals status =
152 let open_goals = head_goals status#stack in
153 assert (List.length open_goals > 0);
157 h := max !h (height_of_goal open_goal status))
159 debug_print (lazy ("altezza sequente: " ^ string_of_int !h));
163 (* =============================== paramod =========================== *)
164 let solve f status eq_cache goal =
167 if fast then NCicParamod.fast_eq_check
168 else NCicParamod.paramod in
170 let n,h,metasenv,subst,o = status#obj in
171 let gname, ctx, gty = List.assoc goal metasenv in
172 let gty = NCicUntrusted.apply_subst subst ctx gty in
173 let build_status (pt, _, metasenv, subst) =
175 debug_print (lazy ("refining: "^(NCicPp.ppterm ctx subst metasenv pt)));
176 let stamp = Unix.gettimeofday () in
177 let metasenv, subst, pt, pty =
178 (* NCicRefiner.typeof status
179 (* (status#set_coerc_db NCicCoercion.empty_db) *)
180 metasenv subst ctx pt None in
181 print (lazy ("refined: "^(NCicPp.ppterm ctx subst metasenv pt)));
182 debug_print (lazy ("synt: "^(NCicPp.ppterm ctx subst metasenv pty)));
183 let metasenv, subst =
184 NCicUnification.unify status metasenv subst ctx gty pty *)
186 (status#set_coerc_db NCicCoercion.empty_db)
187 metasenv subst ctx pt (Some gty)
189 debug_print (lazy (Printf.sprintf "Refined in %fs"
190 (Unix.gettimeofday() -. stamp)));
191 let status = status#set_obj (n,h,metasenv,subst,o) in
192 let metasenv = List.filter (fun j,_ -> j <> goal) metasenv in
193 let subst = (goal,(gname,ctx,pt,pty)) :: subst in
194 Some (status#set_obj (n,h,metasenv,subst,o))
196 NCicRefiner.RefineFailure msg
197 | NCicRefiner.Uncertain msg ->
198 print (lazy ("WARNING: refining in fast_eq_check failed\n" ^
199 snd (Lazy.force msg) ^
200 "\n in the environment\n" ^
201 NCicPp.ppmetasenv subst metasenv)); None
202 | NCicRefiner.AssertFailure msg ->
203 print (lazy ("WARNING: refining in fast_eq_check failed" ^
205 "\n in the environment\n" ^
206 NCicPp.ppmetasenv subst metasenv)); None
209 HExtlib.filter_map build_status
210 (f status metasenv subst ctx eq_cache (NCic.Rel ~-1,gty))
213 let fast_eq_check eq_cache status goal =
214 match solve NCicParamod.fast_eq_check status eq_cache goal with
215 | [] -> raise (Error (lazy "no proof found",None))
219 let dist_fast_eq_check eq_cache s =
220 NTactics.distribute_tac (fast_eq_check eq_cache) s
223 let auto_eq_check eq_cache status =
225 let s = dist_fast_eq_check eq_cache status in
231 (* warning: ctx is supposed to be already instantiated w.r.t subst *)
232 let index_local_equations eq_cache status =
233 debug_print (lazy "indexing equations");
234 let open_goals = head_goals status#stack in
235 let open_goal = List.hd open_goals in
236 let ngty = get_goalty status open_goal in
237 let ctx = ctx_of ngty in
242 let t = NCic.Rel !c in
244 let ty = NCicTypeChecker.typeof [] [] ctx t in
245 if is_a_fact status (mk_cic_term ctx ty) then
246 (debug_print(lazy("eq indexing " ^ (NCicPp.ppterm ctx [] [] ty)));
247 NCicParamod.forward_infer_step eq_cache t ty)
249 (debug_print (lazy ("not a fact: " ^ (NCicPp.ppterm ctx [] [] ty)));
252 | NCicTypeChecker.TypeCheckerFailure _
253 | NCicTypeChecker.AssertFailure _ -> eq_cache)
257 let fast_eq_check_tac ~params s =
258 let unit_eq = index_local_equations s#eq_cache s in
259 dist_fast_eq_check unit_eq s
262 let paramod eq_cache status goal =
263 match solve NCicParamod.paramod status eq_cache goal with
264 | [] -> raise (Error (lazy "no proof found",None))
268 let paramod_tac ~params s =
269 let unit_eq = index_local_equations s#eq_cache s in
270 NTactics.distribute_tac (paramod unit_eq) s
273 let demod eq_cache status goal =
274 match solve NCicParamod.demod status eq_cache goal with
275 | [] -> raise (Error (lazy "no progress",None))
279 let demod_tac ~params s =
280 let unit_eq = index_local_equations s#eq_cache s in
281 NTactics.distribute_tac (demod unit_eq) s
285 let fast_eq_check_tac_all ~params eq_cache status =
286 let g,_,_ = current_goal status in
287 let allstates = fast_eq_check_all status eq_cache g in
288 let pseudo_low_tac s _ _ = s in
289 let pseudo_low_tactics =
290 List.map pseudo_low_tac allstates
292 List.map (fun f -> NTactics.distribute_tac f status) pseudo_low_tactics
297 let demod status eq_cache goal =
298 let n,h,metasenv,subst,o = status#obj in
299 let gname, ctx, gty = List.assoc goal metasenv in
300 let gty = NCicUntrusted.apply_subst subst ctx gty in
302 let demod_tac ~params s =
303 let unit_eq = index_local_equations s#eq_cache s in
304 dist_fast_eq_check unit_eq s
307 (*************** subsumption ****************)
309 let close_wrt_context =
313 | name, NCic.Decl t -> NCic.Prod(name,t,ty)
314 | name, NCic.Def(bo, _) -> NCicSubstitution.subst bo ty)
317 let args_for_context ?(k=1) ctx =
320 (fun (n,l) ctx_entry ->
322 | name, NCic.Decl t -> n+1,NCic.Rel(n)::l
323 | name, NCic.Def(bo, _) -> n+1,l)
327 let constant_for_meta ctx ty i =
328 let name = "cic:/foo"^(string_of_int i)^".con" in
329 let uri = NUri.uri_of_string name in
330 let ty = close_wrt_context ty ctx in
331 (* prerr_endline (NCicPp.ppterm [] [] [] ty); *)
332 let attr = (`Generated,`Definition,`Local) in
333 let obj = NCic.Constant([],name,None,ty,attr) in
334 (* Constant of relevance * string * term option * term * c_attr *)
338 let refresh metasenv =
340 (fun (metasenv,subst) (i,(iattr,ctx,ty)) ->
341 let ikind = NCicUntrusted.kind_of_meta iattr in
342 let metasenv,j,instance,ty =
343 NCicMetaSubst.mk_meta ~attrs:iattr
344 metasenv ctx ~with_type:ty ikind in
345 let s_entry = i,(iattr, ctx, instance, ty) in
346 let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
347 metasenv,s_entry::subst)
348 (metasenv,[]) metasenv
350 (* close metasenv returns a ground instance of all the metas in the
351 metasenv, insantiatied with axioms, and the list of these axioms *)
352 let close_metasenv metasenv subst =
354 let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
356 let metasenv = NCicUntrusted.sort_metasenv subst metasenv in
358 (fun (subst,objs) (i,(iattr,ctx,ty)) ->
359 let ty = NCicUntrusted.apply_subst subst ctx ty in
361 NCicUntrusted.apply_subst_context ~fix_projections:true
363 let (uri,_,_,_,obj) as okind =
364 constant_for_meta ctx ty i in
366 NCicEnvironment.check_and_add_obj okind;
367 let iref = NReference.reference_of_spec uri NReference.Decl in
369 let args = args_for_context ctx in
370 if args = [] then NCic.Const iref
371 else NCic.Appl(NCic.Const iref::args)
373 (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
374 let s_entry = i, ([], ctx, iterm, ty)
375 in s_entry::subst,okind::objs
376 with _ -> assert false)
380 let ground_instances status gl =
381 let _,_,metasenv,subst,_ = status#obj in
382 let subset = menv_closure status gl in
383 let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
385 let submenv = metasenv in
387 let subst, objs = close_metasenv submenv subst in
391 let (_, ctx, t, _) = List.assoc i subst in
392 debug_print (lazy (NCicPp.ppterm ctx [] [] t));
394 (fun (uri,_,_,_,_) as obj ->
395 NCicEnvironment.invalidate_item (`Obj (uri, obj)))
400 Not_found -> assert false
404 let replace_meta i args target =
405 let rec aux k = function
406 (* TODO: local context *)
407 | NCic.Meta (j,lc) when i = j ->
411 List.map (NCicSubstitution.subst_meta lc) args in
412 NCic.Appl(NCic.Rel k::args))
413 | NCic.Meta (j,lc) as m ->
420 aux k (NCicSubstitution.lift n t)) l))))
421 | t -> NCicUtils.map (fun _ k -> k+1) k aux t
426 let close_wrt_metasenv subst =
428 (fun ty (i,(iattr,ctx,mty)) ->
429 let mty = NCicUntrusted.apply_subst subst ctx mty in
431 NCicUntrusted.apply_subst_context ~fix_projections:true
433 let cty = close_wrt_context mty ctx in
434 let name = "foo"^(string_of_int i) in
435 let ty = NCicSubstitution.lift 1 ty in
436 let args = args_for_context ~k:1 ctx in
437 (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
438 let ty = replace_meta i args ty
440 NCic.Prod(name,cty,ty))
444 let _,_,metasenv,subst,_ = status#obj in
445 let subset = menv_closure status [g] in
446 let subset = IntSet.remove g subset in
447 let elems = IntSet.elements subset in
448 let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
449 let ty = NCicUntrusted.apply_subst subst ctx ty in
450 debug_print (lazy ("metas in " ^ (NCicPp.ppterm ctx [] metasenv ty)));
451 debug_print (lazy (String.concat ", " (List.map string_of_int elems)));
452 let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
453 let submenv = List.rev (NCicUntrusted.sort_metasenv subst submenv) in
455 let submenv = metasenv in
457 let ty = close_wrt_metasenv subst ty submenv in
458 debug_print (lazy (NCicPp.ppterm ctx [] [] ty));
462 (****************** smart application ********************)
464 let saturate_to_ref metasenv subst ctx nref ty =
465 let height = height_of_ref nref in
466 let rec aux metasenv ty args =
467 let ty,metasenv,moreargs =
468 NCicMetaSubst.saturate ~delta:height metasenv subst ctx ty 0 in
470 | NCic.Const(NReference.Ref (_,NReference.Def _) as nre)
472 let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
473 aux metasenv ty (args@moreargs)
474 | NCic.Appl(NCic.Const(NReference.Ref (_,NReference.Def _) as nre)::tl)
476 let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
477 aux metasenv (NCic.Appl(bo::tl)) (args@moreargs)
478 | _ -> ty,metasenv,(args@moreargs)
482 let smart_apply t unit_eq status g =
483 let n,h,metasenv,subst,o = status#obj in
484 let gname, ctx, gty = List.assoc g metasenv in
485 (* let ggty = mk_cic_term context gty in *)
486 let status, t = disambiguate status ctx t None in
487 let status,t = term_of_cic_term status t ctx in
488 let _,_,metasenv,subst,_ = status#obj in
489 let ty = NCicTypeChecker.typeof subst metasenv ctx t in
490 let ty,metasenv,args =
493 | NCic.Appl(NCic.Const(nref)::_) ->
494 saturate_to_ref metasenv subst ctx nref ty
496 NCicMetaSubst.saturate metasenv subst ctx ty 0 in
497 let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in
498 let status = status#set_obj (n,h,metasenv,subst,o) in
499 let pterm = if args=[] then t else
501 | NCic.Appl l -> NCic.Appl(l@args)
502 | _ -> NCic.Appl(t::args)
504 noprint(lazy("pterm " ^ (NCicPp.ppterm ctx [] [] pterm)));
505 noprint(lazy("pty " ^ (NCicPp.ppterm ctx [] [] ty)));
508 NUri.uri_of_string "cic:/matita/ng/Plogic/equality/eq_coerc.con" in
509 let ref = NReference.reference_of_spec uri (NReference.Def(2)) in
513 NCic.Appl[eq_coerc;ty;NCic.Implicit `Type;pterm;inst] in
514 let smart = mk_cic_term ctx smart in
516 let status = instantiate status g smart in
517 let _,_,metasenv,subst,_ = status#obj in
518 let _,ctx,jty = List.assoc j metasenv in
519 let jty = NCicUntrusted.apply_subst subst ctx jty in
520 debug_print(lazy("goal " ^ (NCicPp.ppterm ctx [] [] jty)));
521 fast_eq_check unit_eq status j
523 | Error _ as e -> debug_print (lazy "error"); raise e
525 let smart_apply_tac t s =
526 let unit_eq = index_local_equations s#eq_cache s in
527 NTactics.distribute_tac (smart_apply t unit_eq) s
529 let smart_apply_auto t eq_cache =
530 NTactics.distribute_tac (smart_apply t eq_cache)
533 (****************** types **************)
536 type th_cache = (NCic.context * InvRelDiscriminationTree.t) list
538 let keys_of_term status t =
539 let status, orig_ty = typeof status (ctx_of t) t in
540 let _, ty, _ = saturate ~delta:max_int status orig_ty in
543 let _, ty = term_of_cic_term status ty (ctx_of ty) in
545 | NCic.Const (NReference.Ref (_,(NReference.Def h | NReference.Fix (_,_,h))))
546 | NCic.Appl (NCic.Const(NReference.Ref(_,(NReference.Def h | NReference.Fix (_,_,h))))::_)
548 let _,ty,_= saturate status ~delta:(h-1) orig_ty in
555 let mk_th_cache status gl =
557 (fun (status, acc) g ->
558 let gty = get_goalty status g in
559 let ctx = ctx_of gty in
560 debug_print(lazy("th cache for: "^ppterm status gty));
561 debug_print(lazy("th cache in: "^ppcontext status ctx));
562 if List.mem_assq ctx acc then status, acc else
563 let idx = InvRelDiscriminationTree.empty in
566 (fun (status, i, idx) _ ->
567 let t = mk_cic_term ctx (NCic.Rel i) in
568 let status, keys = keys_of_term status t in
569 debug_print(lazy("indexing: "^ppterm status t ^ ": " ^ string_of_int (List.length keys)));
571 List.fold_left (fun idx k ->
572 InvRelDiscriminationTree.index idx k t) idx keys
577 status, (ctx, idx) :: acc)
581 let add_to_th t c ty =
582 let key_c = ctx_of t in
583 if not (List.mem_assq key_c c) then
584 (key_c ,InvRelDiscriminationTree.index
585 InvRelDiscriminationTree.empty ty t ) :: c
587 let rec replace = function
589 | (x, idx) :: tl when x == key_c ->
590 (x, InvRelDiscriminationTree.index idx ty t) :: tl
591 | x :: tl -> x :: replace tl
596 let rm_from_th t c ty =
597 let key_c = ctx_of t in
598 if not (List.mem_assq key_c c) then assert false
600 let rec replace = function
602 | (x, idx) :: tl when x == key_c ->
603 (x, InvRelDiscriminationTree.remove_index idx ty t) :: tl
604 | x :: tl -> x :: replace tl
609 let pp_idx status idx =
610 InvRelDiscriminationTree.iter idx
612 debug_print(lazy("K: " ^ NCicInverseRelIndexable.string_of_path k));
614 (fun t -> debug_print(lazy("\t"^ppterm status t)))
621 debug_print(lazy( "-----------------------------------------------"));
622 debug_print(lazy( (NCicPp.ppcontext ~metasenv:[] ~subst:[] ctx)));
623 debug_print(lazy( "||====> "));
627 let search_in_th gty th =
628 let c = ctx_of gty in
629 let rec aux acc = function
630 | [] -> (* Ncic_termSet.elements *) acc
633 let idx = List.assq k th in
634 let acc = Ncic_termSet.union acc
635 (InvRelDiscriminationTree.retrieve_unifiables idx gty)
638 with Not_found -> aux acc tl
640 aux Ncic_termSet.empty c
644 do_types : bool; (* solve goals in Type *)
645 last : bool; (* last goal: take first solution only *)
646 candidates: Ast.term list option;
654 {facts : th_cache; (* positive results *)
655 under_inspection : cic_term list * th_cache; (* to prune looping *)
656 unit_eq : NCicParamod.state;
660 let add_to_trace ~depth cache t =
663 debug_print ~depth (lazy ("Adding to trace: " ^ CicNotationPp.pp_term t));
664 {cache with trace = t::cache.trace}
665 | Ast.NCic _ (* local candidate *)
666 | _ -> (*not an application *) cache
669 (lazy ("Proof Trace: " ^ (String.concat ";"
670 (List.map CicNotationPp.pp_term tr))))
672 let remove_from_trace cache t =
675 (match cache.trace with
676 | _::tl -> {cache with trace = tl}
678 | Ast.NCic _ (* local candidate *)
679 | _ -> (*not an application *) cache *)
682 type goal = int * sort (* goal, depth, sort *)
683 type fail = goal * cic_term
684 type candidate = int * Ast.term (* unique candidate number, candidate *)
686 exception Gaveup of IntSet.t (* a sublist of unprovable conjunctive
687 atoms of the input goals *)
688 exception Proved of NTacStatus.tac_status * Ast.term list
690 (* let close_failures _ c = c;; *)
691 (* let prunable _ _ _ = false;; *)
692 (* let cache_examine cache gty = `Notfound;; *)
693 (* let put_in_subst s _ _ _ = s;; *)
694 (* let add_to_cache_and_del_from_orlist_if_green_cut _ _ c _ _ o f _ = c, o, f, false ;; *)
695 (* let cache_add_underinspection c _ _ = c;; *)
697 let init_cache ?(facts=[]) ?(under_inspection=[],[])
698 ?(unit_eq=NCicParamod.empty_state)
702 under_inspection = under_inspection;
706 let only signature _context candidate = true
708 (* TASSI: nel trie ci mettiamo solo il body, non il ty *)
710 NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate
712 let height = fast_height_of_term candidate_ty in
713 let rc = signature >= height in
715 debug_print (lazy ("Filtro: " ^ NCicPp.ppterm ~context:[] ~subst:[]
716 ~metasenv:[] candidate ^ ": " ^ string_of_int height))
718 debug_print (lazy ("Tengo: " ^ NCicPp.ppterm ~context:[] ~subst:[]
719 ~metasenv:[] candidate ^ ": " ^ string_of_int height));
724 let candidate_no = ref 0;;
726 let openg_no status = List.length (head_goals status#stack)
728 let sort_candidates status ctx candidates =
729 let _,_,metasenv,subst,_ = status#obj in
731 let status,ct = disambiguate status ctx ("",0,cand) None in
732 let status,t = term_of_cic_term status ct ctx in
733 let ty = NCicTypeChecker.typeof subst metasenv ctx t in
734 let res = branch status (mk_cic_term ctx ty) in
735 debug_print (lazy ("branch factor for: " ^ (ppterm status ct) ^ " = "
736 ^ (string_of_int res)));
739 let candidates = List.map (fun t -> branch t,t) candidates in
741 List.sort (fun (a,_) (b,_) -> a - b) candidates in
742 let candidates = List.map snd candidates in
743 debug_print (lazy ("candidates =\n" ^ (String.concat "\n"
744 (List.map CicNotationPp.pp_term candidates))));
747 let sort_new_elems l =
748 List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l
750 let try_candidate ?(smart=0) flags depth status eq_cache ctx t =
752 debug_print ~depth (lazy ("try " ^ CicNotationPp.pp_term t));
754 if smart= 0 then NTactics.apply_tac ("",0,t) status
755 else if smart = 1 then smart_apply_auto ("",0,t) eq_cache status
756 else (* smart = 2: both *)
757 try NTactics.apply_tac ("",0,t) status
758 with Error _ as exc ->
759 smart_apply_auto ("",0,t) eq_cache status
762 let og_no = openg_no status in
763 if (* og_no > flags.maxwidth || *)
764 ((depth + 1) = flags.maxdepth && og_no <> 0) then
765 (debug_print ~depth (lazy "pruned immediately"); None)
768 let status, cict = disambiguate status ctx ("",0,t) None in
769 let status,ct = term_of_cic_term status cict ctx in
770 let _,_,metasenv,subst,_ = status#obj in
771 let ty = NCicTypeChecker.typeof subst metasenv ctx ct in
772 let res = branch status (mk_cic_term ctx ty) in
773 if smart=1 && og_no > res then
774 (print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = "
775 ^ (string_of_int res) ^ " vs. " ^ (string_of_int og_no)));
776 print ~depth (lazy "strange application"); None)
779 Some ((!candidate_no,t),status))
780 with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
783 let sort_of subst metasenv ctx t =
784 let ty = NCicTypeChecker.typeof subst metasenv ctx t in
785 let metasenv',ty = NCicUnification.fix_sorts metasenv subst ty in
786 assert (metasenv = metasenv');
787 NCicTypeChecker.typeof subst metasenv ctx ty
790 let type0= NUri.uri_of_string ("cic:/matita/pts/Type0.univ")
793 let perforate_small subst metasenv context t =
794 let rec aux = function
795 | NCic.Appl (hd::tl) ->
797 let s = sort_of subst metasenv context t in
799 | NCic.Sort(NCic.Type [`Type,u])
800 when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0))
803 NCic.Appl (hd::List.map map tl)
809 let get_cands retrieve_for diff empty gty weak_gty =
810 let cands = retrieve_for gty in
812 | None -> cands, empty
814 let more_cands = retrieve_for weak_gty in
815 cands, diff more_cands cands
818 let get_candidates ?(smart=true) depth flags status cache signature gty =
819 let maxd = ((depth + 1) = flags.maxdepth) in
820 let universe = status#auto_cache in
821 let _,_,metasenv,subst,_ = status#obj in
822 let context = ctx_of gty in
823 let _, raw_gty = term_of_cic_term status gty context in
824 let raw_weak_gty, weak_gty =
830 let weak = perforate_small subst metasenv context raw_gty in
831 Some weak, Some (mk_cic_term context weak)
835 let global_cands, smart_global_cands =
836 match flags.candidates with
837 | Some l when (not maxd) -> l,[]
841 let to_ast = function
842 | NCic.Const r -> Ast.NRef r | _ -> assert false in
843 List.map to_ast (NDiscriminationTree.TermSet.elements s) in
846 (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
848 NDiscriminationTree.TermSet.diff
849 NDiscriminationTree.TermSet.empty
850 raw_gty raw_weak_gty in
852 let local_cands,smart_local_cands =
855 let _status, t = term_of_cic_term status t context
857 List.map to_ast (Ncic_termSet.elements s) in
860 (fun ty -> search_in_th ty cache)
861 Ncic_termSet.diff Ncic_termSet.empty gty weak_gty in
863 sort_candidates status context (global_cands@local_cands),
864 sort_candidates status context (smart_global_cands@smart_local_cands)
868 let get_candidates ?(smart=true) status cache signature gty =
869 let universe = status#auto_cache in
870 let _,_,metasenv,subst,_ = status#obj in
871 let context = ctx_of gty in
873 let _status, t = term_of_cic_term status t context
876 | NCic.Const r -> Ast.NRef r | _ -> assert false in
877 let _, raw_gty = term_of_cic_term status gty context in
879 NDiscriminationTree.DiscriminationTree.retrieve_unifiables
882 let local_cands = search_in_th gty cache in
883 debug_print (lazy ("candidates for" ^ NTacStatus.ppterm status gty));
884 debug_print (lazy ("local cands = " ^ (string_of_int (List.length (Ncic_termSet.elements local_cands)))));
885 let together global local =
887 (List.filter (only signature context)
888 (NDiscriminationTree.TermSet.elements global)) @
889 List.map t_ast (Ncic_termSet.elements local) in
890 let candidates = together cands local_cands in
891 let candidates = sort_candidates status context candidates in
892 let smart_candidates =
898 let weak_gty = perforate_small subst metasenv context raw_gty in
900 NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
901 (List.length tl)) in *)
903 NDiscriminationTree.DiscriminationTree.retrieve_unifiables
907 NDiscriminationTree.TermSet.diff more_cands cands in
908 let cic_weak_gty = mk_cic_term context weak_gty in
909 let more_local_cands = search_in_th cic_weak_gty cache in
910 let smart_local_cands =
911 Ncic_termSet.diff more_local_cands local_cands in
912 together smart_cands smart_local_cands
913 (* together more_cands more_local_cands *)
917 let smart_candidates = sort_candidates status context smart_candidates in
918 (* if smart then smart_candidates, []
919 else candidates, [] *)
920 candidates, smart_candidates
923 let get_candidates ?(smart=true) flags status cache signature gty =
924 match flags.candidates with
925 | None -> get_candidates ~smart status cache signature gty
929 let applicative_case depth signature status flags gty cache =
930 app_counter:= !app_counter+1;
931 let _,_,metasenv,subst,_ = status#obj in
932 let context = ctx_of gty in
933 let tcache = cache.facts in
935 let status, t = term_of_cic_term status gty context in
936 let t = NCicReduction.whd subst context t in
938 | NCic.Prod _ -> true, false
939 | _ -> false, NCicParamod.is_equation metasenv subst context t
941 debug_print(lazy (string_of_bool is_eq));
942 let candidates, smart_candidates =
943 get_candidates ~smart:(not is_eq) depth
944 flags status tcache signature gty in
946 (lazy ("candidates: " ^ string_of_int (List.length candidates)));
948 (lazy ("smart candidates: " ^
949 string_of_int (List.length smart_candidates)));
952 let smart_candidates = [] in *)
953 let sm = if is_eq then 0 else 2 in
954 let maxd = ((depth + 1) = flags.maxdepth) in
955 let only_one = flags.last && maxd in
956 debug_print (lazy ("only_one: " ^ (string_of_bool only_one)));
957 debug_print (lazy ("maxd: " ^ (string_of_bool maxd)));
961 if (only_one && (elems <> [])) then elems
963 if (maxd && not(is_prod) &
964 not(is_a_fact_ast status subst metasenv context cand))
965 then (debug_print (lazy "pruned: not a fact"); elems)
967 match try_candidate (~smart:sm)
968 flags depth status cache.unit_eq context cand with
970 | Some x -> x::elems)
974 if only_one && elems <> [] then elems
978 if (only_one && (elems <> [])) then elems
980 if (maxd && not(is_prod) &&
981 not(is_a_fact_ast status subst metasenv context cand))
982 then (debug_print (lazy "pruned: not a fact"); elems)
984 match try_candidate (~smart:1)
985 flags depth status cache.unit_eq context cand with
987 | Some x -> x::elems)
996 (* gty is supposed to be meta-closed *)
997 let is_subsumed depth status gty cache =
998 if cache=[] then false else (
999 debug_print ~depth (lazy("Subsuming " ^ (ppterm status gty)));
1000 let n,h,metasenv,subst,obj = status#obj in
1001 let ctx = ctx_of gty in
1002 let _ , target = term_of_cic_term status gty ctx in
1003 let target = NCicSubstitution.lift 1 target in
1004 (* candidates must only be searched w.r.t the given context *)
1007 let idx = List.assq ctx cache in
1008 Ncic_termSet.elements
1009 (InvRelDiscriminationTree.retrieve_generalizations idx gty)
1010 with Not_found -> []
1013 (lazy ("failure candidates: " ^ string_of_int (List.length candidates)));
1017 let _ , source = term_of_cic_term status t ctx in
1019 NCic.Prod("foo",source,target) in
1020 let metasenv,j,_,_ =
1021 NCicMetaSubst.mk_meta
1022 metasenv ctx ~with_type:implication `IsType in
1023 let status = status#set_obj (n,h,metasenv,subst,obj) in
1024 let status = status#set_stack [([1,Open j],[],[],`NoTag)] in
1026 let status = NTactics.intro_tac "foo" status in
1028 NTactics.apply_tac ("",0,Ast.NCic (NCic.Rel 1)) status
1030 if (head_goals status#stack = []) then raise Found
1035 with Found -> debug_print ~depth (lazy "success");true)
1038 let rec guess_name name ctx =
1039 if name = "_" then guess_name "auto" ctx else
1040 if not (List.mem_assoc name ctx) then name else
1041 guess_name (name^"'") ctx
1044 let is_prod status =
1045 let _, ctx, gty = current_goal status in
1046 let _, raw_gty = term_of_cic_term status gty ctx in
1048 | NCic.Prod (name,_,_) -> Some (guess_name name ctx)
1051 let intro ~depth status facts name =
1052 let status = NTactics.intro_tac name status in
1053 let _, ctx, ngty = current_goal status in
1054 let t = mk_cic_term ctx (NCic.Rel 1) in
1055 let status, keys = keys_of_term status t in
1056 let facts = List.fold_left (add_to_th t) facts keys in
1057 debug_print ~depth (lazy ("intro: "^ name));
1058 (* unprovability is not stable w.r.t introduction *)
1062 let rec intros_facts ~depth status facts =
1063 match is_prod status with
1066 intro ~depth status facts name
1067 in intros_facts ~depth status facts
1068 | _ -> status, facts
1071 let rec intros ~depth status cache =
1072 match is_prod status with
1074 let trace = cache.trace in
1076 intros_facts ~depth status cache.facts
1078 (* we reindex the equation from scratch *)
1080 index_local_equations status#eq_cache status in
1081 status, init_cache ~facts ~unit_eq () ~trace
1082 | _ -> status, cache
1085 let reduce ~depth status g =
1086 let n,h,metasenv,subst,o = status#obj in
1087 let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in
1088 let ty = NCicUntrusted.apply_subst subst ctx ty in
1089 let ty' = NCicReduction.whd ~subst ctx ty in
1093 (lazy ("reduced to: "^ NCicPp.ppterm ctx subst metasenv ty'));
1095 (g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv)
1097 let status = status#set_obj (n,h,metasenv,subst,o) in
1098 (* we merge to gain a depth level; the previous goal level should
1100 let status = NTactics.merge_tac status in
1102 [(!candidate_no,Ast.Ident("__whd",None)),status])
1105 let do_something signature flags status g depth gty cache =
1107 let l = reduce ~depth status g in
1108 (* if l <> [] then l,cache else *)
1109 (* backward aplications *)
1114 ((!candidate_no,Ast.Ident("__paramod",None)),s))
1115 (auto_eq_check cache.unit_eq status)
1118 if ((l1 <> []) && flags.last) then [] else
1119 applicative_case depth signature status flags gty cache
1120 (* fast paramodulation *)
1122 (* states in l1 have have an empty set of subgoals: no point to sort them *)
1124 (lazy ("alternatives = " ^ (string_of_int (List.length (l1@l@l2)))));
1125 (* l1 @ (sort_new_elems (l @ l2)), cache *)
1126 l1 @ (List.rev l2) @ l, cache
1129 let pp_goal = function
1130 | (_,Continuationals.Stack.Open i)
1131 | (_,Continuationals.Stack.Closed i) -> string_of_int i
1134 let pp_goals status l =
1138 let gty = get_goalty status i in
1139 NTacStatus.ppterm status gty)
1146 let compare = Pervasives.compare
1150 module MS = HTopoSort.Make(M)
1153 let sort_tac status =
1155 match status#stack with
1156 | [] -> assert false
1157 | (goals, t, k, tag) :: s ->
1158 let g = head_goals status#stack in
1160 (List.rev (MS.topological_sort g (deps status))) in
1161 debug_print (lazy ("old g = " ^
1162 String.concat "," (List.map string_of_int g)));
1163 debug_print (lazy ("sorted goals = " ^
1164 String.concat "," (List.map string_of_int sortedg)));
1165 let is_it i = function
1166 | (_,Continuationals.Stack.Open j )
1167 | (_,Continuationals.Stack.Closed j ) -> i = j
1170 List.map (fun i -> List.find (is_it i) goals) sortedg
1172 (sorted_goals, t, k, tag) :: s
1174 status#set_stack gstatus
1177 let clean_up_tac status =
1179 match status#stack with
1180 | [] -> assert false
1181 | (g, t, k, tag) :: s ->
1182 let is_open = function
1183 | (_,Continuationals.Stack.Open _) -> true
1184 | (_,Continuationals.Stack.Closed _) -> false
1186 let g' = List.filter is_open g in
1187 (g', t, k, tag) :: s
1189 status#set_stack gstatus
1192 let focus_tac focus status =
1194 match status#stack with
1195 | [] -> assert false
1196 | (g, t, k, tag) :: s ->
1197 let in_focus = function
1198 | (_,Continuationals.Stack.Open i)
1199 | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1201 let focus,others = List.partition in_focus g
1203 (* we need to mark it as a BranchTag, otherwise cannot merge later *)
1204 (focus,[],[],`BranchTag) :: (others, t, k, tag) :: s
1206 status#set_stack gstatus
1209 let deep_focus_tac level focus status =
1210 let in_focus = function
1211 | (_,Continuationals.Stack.Open i)
1212 | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1214 let rec slice level gs =
1215 if level = 0 then [],[],gs else
1217 | [] -> assert false
1218 | (g, t, k, tag) :: s ->
1219 let f,o,gs = slice (level-1) s in
1220 let f1,o1 = List.partition in_focus g
1222 (f1,[],[],`BranchTag)::f, (o1, t, k, tag)::o, gs
1225 let f,o,s = slice level status#stack in f@o@s
1227 status#set_stack gstatus
1230 let rec stack_goals level gs =
1231 if level = 0 then []
1233 | [] -> assert false
1235 let is_open = function
1236 | (_,Continuationals.Stack.Open i) -> Some i
1237 | (_,Continuationals.Stack.Closed _) -> None
1239 HExtlib.filter_map is_open g @ stack_goals (level-1) s
1242 let open_goals level status = stack_goals level status#stack
1245 let move_to_side level status =
1246 match status#stack with
1247 | [] -> assert false
1249 let is_open = function
1250 | (_,Continuationals.Stack.Open i) -> Some i
1251 | (_,Continuationals.Stack.Closed _) -> None
1253 let others = menv_closure status (stack_goals (level-1) tl) in
1254 List.for_all (fun i -> IntSet.mem i others)
1255 (HExtlib.filter_map is_open g)
1257 let rec auto_clusters ?(top=false)
1258 flags signature cache depth status : unit =
1259 debug_print ~depth (lazy ("entering auto clusters at depth " ^
1260 (string_of_int depth)));
1261 debug_print ~depth (pptrace cache.trace);
1262 (* ignore(Unix.select [] [] [] 0.01); *)
1263 let status = clean_up_tac status in
1264 let goals = head_goals status#stack in
1266 if depth = 0 then raise (Proved (status, cache.trace))
1268 let status = NTactics.merge_tac status in
1270 let l,tree = cache.under_inspection in
1272 | [] -> cache (* possible because of intros that cleans the cache *)
1273 | a::tl -> let tree = rm_from_th a tree a in
1274 {cache with under_inspection = tl,tree}
1276 auto_clusters flags signature cache (depth-1) status
1277 else if List.length goals < 2 then
1278 auto_main flags signature cache depth status
1280 let all_goals = open_goals (depth+1) status in
1281 debug_print ~depth (lazy ("goals = " ^
1282 String.concat "," (List.map string_of_int all_goals)));
1283 let classes = HExtlib.clusters (deps status) all_goals in
1286 if List.length gl > flags.maxwidth then
1287 (debug_print ~depth (lazy "FAIL GLOBAL WIDTH");
1288 raise (Gaveup IntSet.empty))
1290 if List.length classes = 1 then
1292 {flags with last = (List.length all_goals = 1)} in
1293 (* no need to cluster *)
1294 auto_main flags signature cache depth status
1296 let classes = if top then List.rev classes else classes in
1302 ("cluster:" ^ String.concat "," (List.map string_of_int l)))
1304 let status,trace,b =
1306 (fun (status,trace,b) gl ->
1307 let cache = {cache with trace = trace} in
1309 {flags with last = (List.length gl = 1)} in
1310 let lold = List.length status#stack in
1311 debug_print ~depth (lazy ("stack length = " ^
1312 (string_of_int lold)));
1313 let fstatus = deep_focus_tac (depth+1) gl status in
1315 debug_print ~depth (lazy ("focusing on" ^
1316 String.concat "," (List.map string_of_int gl)));
1317 auto_main flags signature cache depth fstatus; assert false
1319 | Proved(status,trace) ->
1320 let status = NTactics.merge_tac status in
1321 let lnew = List.length status#stack in
1322 assert (lold = lnew);
1324 | Gaveup _ when top -> (status,trace,b)
1326 (status,cache.trace,false) classes
1328 let rec final_merge n s =
1329 if n = 0 then s else final_merge (n-1) (NTactics.merge_tac s)
1330 in let status = final_merge depth status
1331 in if b then raise (Proved(status,trace)) else raise (Gaveup IntSet.empty)
1335 (* BRAND NEW VERSION *)
1336 auto_main flags signature cache depth status: unit =
1337 debug_print ~depth (lazy "entering auto main");
1338 debug_print ~depth (pptrace cache.trace);
1339 debug_print ~depth (lazy ("stack length = " ^
1340 (string_of_int (List.length status#stack))));
1341 (* ignore(Unix.select [] [] [] 0.01); *)
1342 let status = sort_tac (clean_up_tac status) in
1343 let goals = head_goals status#stack in
1345 | [] when depth = 0 -> raise (Proved (status,cache.trace))
1347 let status = NTactics.merge_tac status in
1349 let l,tree = cache.under_inspection in
1351 | [] -> cache (* possible because of intros that cleans the cache *)
1352 | a::tl -> let tree = rm_from_th a tree a in
1353 {cache with under_inspection = tl,tree}
1355 auto_clusters flags signature cache (depth-1) status
1357 if depth > 0 && move_to_side depth status
1359 let status = NTactics.merge_tac status in
1361 let l,tree = cache.under_inspection in
1363 | [] -> cache (* possible because of intros that cleans the cache*)
1364 | a::tl -> let tree = rm_from_th a tree a in
1365 {cache with under_inspection = tl,tree}
1367 auto_clusters flags signature cache (depth-1) status
1369 let ng = List.length goals in
1370 (* moved inside auto_clusters *)
1371 if ng > flags.maxwidth then
1372 (print ~depth (lazy "FAIL LOCAL WIDTH"); raise (Gaveup IntSet.empty))
1373 else if depth = flags.maxdepth then
1374 raise (Gaveup IntSet.empty)
1376 let status = NTactics.branch_tac ~force:true status in
1377 let status, cache = intros ~depth status cache in
1378 let g,gctx, gty = current_goal status in
1379 let ctx,ty = close status g in
1380 let closegty = mk_cic_term ctx ty in
1381 let status, gty = apply_subst status gctx gty in
1382 debug_print ~depth (lazy("Attacking goal " ^ (string_of_int g) ^" : "^ppterm status gty));
1383 if is_subsumed depth status closegty (snd cache.under_inspection) then
1384 (debug_print ~depth (lazy "SUBSUMED");
1385 raise (Gaveup IntSet.add g IntSet.empty))
1387 let new_sig = height_of_goal g status in
1388 if new_sig < signature then
1389 (debug_print (lazy ("news = " ^ (string_of_int new_sig)));
1390 debug_print (lazy ("olds = " ^ (string_of_int signature))));
1391 let alternatives, cache =
1392 do_something signature flags status g depth gty cache in
1394 let l,tree = cache.under_inspection in
1395 let l,tree = closegty::l, add_to_th closegty tree closegty in
1396 {cache with under_inspection = l,tree} in
1398 (fun ((_,t),status) ->
1400 (lazy ("(re)considering goal " ^
1401 (string_of_int g) ^" : "^ppterm status gty));
1402 debug_print (~depth:depth)
1403 (lazy ("Case: " ^ CicNotationPp.pp_term t));
1405 if t=Ast.Ident("__whd",None) then depth, cache
1406 else depth+1,loop_cache in
1407 let cache = add_to_trace ~depth cache t in
1409 auto_clusters flags signature cache depth status
1411 debug_print ~depth (lazy "Failed");
1414 raise (debug_print(lazy "no more candidates"); Gaveup IntSet.empty)
1417 let int name l def =
1418 try int_of_string (List.assoc name l)
1419 with Failure _ | Not_found -> def
1422 module AstSet = Set.Make(struct type t = Ast.term let compare = compare end)
1424 let cleanup_trace s trace =
1425 (* removing duplicates *)
1428 (fun acc t -> AstSet.add t acc)
1429 AstSet.empty trace in
1430 let trace = AstSet.elements trace_set
1431 (* filtering facts *)
1435 | Ast.NRef (NReference.Ref (u,_)) -> not (is_a_fact_obj s u)
1439 let auto_tac ~params:(univ,flags) status =
1440 let oldstatus = status in
1441 let status = (status:> NTacStatus.tac_status) in
1442 let goals = head_goals status#stack in
1443 let status, facts = mk_th_cache status goals in
1444 let unit_eq = index_local_equations status#eq_cache status in
1445 let cache = init_cache ~facts ~unit_eq () in
1446 (* pp_th status facts; *)
1448 NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
1450 NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
1451 String.concat "\n " (List.map (
1452 NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[])
1453 (NDiscriminationTree.TermSet.elements t))
1461 let status, res = disambiguate status [] t None in
1462 let _,res = term_of_cic_term status res (ctx_of res)
1464 in Some (List.map to_Ast l)
1466 let depth = int "depth" flags 3 in
1467 let size = int "size" flags 10 in
1468 let width = int "width" flags 4 (* (3+List.length goals)*) in
1470 (* let goals = List.map (fun i -> (i,P)) goals in *)
1471 let signature = height_of_goals status in
1474 candidates = candidates;
1478 timeout = Unix.gettimeofday() +. 3000.;
1481 let initial_time = Unix.gettimeofday() in
1486 ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1488 ("Applicative nodes:"^string_of_int !app_counter));
1489 raise (Error (lazy "auto gave up", None)))
1491 let _ = debug_print (lazy("\n\nRound "^string_of_int x^"\n")) in
1492 let flags = { flags with maxdepth = x }
1494 try auto_clusters (~top:true) flags signature cache 0 status;assert false
1496 try auto_main flags signature cache 0 status;assert false
1499 | Gaveup _ -> up_to (x+1) y
1500 | Proved (s,trace) ->
1501 debug_print (lazy ("proved at depth " ^ string_of_int x));
1502 let trace = cleanup_trace s trace in
1503 let _ = print (pptrace trace) in
1506 | (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
1509 let s = s#set_stack stack in
1510 oldstatus#set_status s
1512 let s = up_to depth depth in
1514 ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1516 ("Applicative nodes:"^string_of_int !app_counter));