(* ||M|| This file is part of HELM, an Hypertextual, Electronic ||A|| Library of Mathematics, developed at the Computer Science ||T|| Department, University of Bologna, Italy. ||I|| ||T|| HELM is free software; you can redistribute it and/or ||A|| modify it under the terms of the GNU General Public License \ / version 2 or (at your option) any later version. \ / This software is distributed as is, NO WARRANTY. V_______________________________________________________________ *) open Printf let debug = ref false let debug_print ?(depth=0) s = if !debug then prerr_endline (String.make depth '\t'^Lazy.force s) else () (* let print = debug_print *) let print ?(depth=0) s = prerr_endline (String.make depth '\t'^Lazy.force s) let debug_do f = if !debug then f () else () open Continuationals.Stack open NTacStatus module Ast = CicNotationPt let app_counter = ref 0 (* ======================= utility functions ========================= *) module IntSet = Set.Make(struct type t = int let compare = compare end) let get_sgoalty status g = let _,_,metasenv,subst,_ = status#obj in try let _, ctx, ty = NCicUtils.lookup_meta g metasenv in let ty = NCicUntrusted.apply_subst subst ctx ty in let ctx = NCicUntrusted.apply_subst_context ~fix_projections:true subst ctx in NTacStatus.mk_cic_term ctx ty with NCicUtils.Meta_not_found _ as exn -> fail ~exn (lazy "get_sgoalty") ;; let deps status g = let gty = get_sgoalty status g in metas_of_term status gty ;; let menv_closure status gl = let rec closure acc = function | [] -> acc | x::l when IntSet.mem x acc -> closure acc l | x::l -> closure (IntSet.add x acc) (deps status x @ l) in closure IntSet.empty gl ;; (* we call a "fact" an object whose hypothesis occur in the goal or in types of goal-variables *) let is_a_fact status ty = let status, ty, metas = saturate ~delta:0 status ty in debug_print (lazy ("saturated ty :" ^ (ppterm status ty))); let g_metas = metas_of_term status ty in let clos = menv_closure status g_metas in (* let _,_,metasenv,_,_ = status#obj in *) let menv = List.fold_left (fun acc m -> let _, m = term_of_cic_term status m (ctx_of m) in match m with | NCic.Meta(i,_) -> IntSet.add i acc | _ -> assert false) IntSet.empty metas in IntSet.subset menv clos;; let is_a_fact_obj s uri = let obj = NCicEnvironment.get_checked_obj uri in match obj with | (_,_,[],[],NCic.Constant(_,_,Some(t),ty,_)) -> is_a_fact s (mk_cic_term [] ty) (* aggiungere i costruttori *) | _ -> false let is_a_fact_ast status subst metasenv ctx cand = debug_print ~depth:0 (lazy ("------- checking " ^ CicNotationPp.pp_term cand)); let status, t = disambiguate status ctx ("",0,cand) None in let status,t = term_of_cic_term status t ctx in let ty = NCicTypeChecker.typeof subst metasenv ctx t in is_a_fact status (mk_cic_term ctx ty) let current_goal status = let open_goals = head_goals status#stack in assert (List.length open_goals = 1); let open_goal = List.hd open_goals in let gty = get_goalty status open_goal in let ctx = ctx_of gty in open_goal, ctx, gty (* =============================== paramod =========================== *) let solve fast status eq_cache goal = let f = if fast then NCicParamod.fast_eq_check else NCicParamod.paramod in let n,h,metasenv,subst,o = status#obj in let gname, ctx, gty = List.assoc goal metasenv in let gty = NCicUntrusted.apply_subst subst ctx gty in let build_status (pt, _, metasenv, subst) = try debug_print (lazy ("refining: "^(NCicPp.ppterm ctx subst metasenv pt))); let stamp = Unix.gettimeofday () in let metasenv, subst, pt, pty = NCicRefiner.typeof status (* (status#set_coerc_db NCicCoercion.empty_db) *) metasenv subst ctx pt None in debug_print (lazy ("refined: "^(NCicPp.ppterm ctx subst metasenv pt))); debug_print (lazy ("synt: "^(NCicPp.ppterm ctx subst metasenv pty))); let metasenv, subst = NCicUnification.unify status metasenv subst ctx gty pty (* the previous code is much less expensive than directly refining pt with expected type pty in prerr_endline ("exp: "^(NCicPp.ppterm ctx subst metasenv gty)); NCicRefiner.typeof (status#set_coerc_db NCicCoercion.empty_db) metasenv subst ctx pt (Some gty) *) in debug_print (lazy (Printf.sprintf "Refined in %fs" (Unix.gettimeofday() -. stamp))); let status = status#set_obj (n,h,metasenv,subst,o) in let metasenv = List.filter (fun j,_ -> j <> goal) metasenv in let subst = (goal,(gname,ctx,pt,pty)) :: subst in Some (status#set_obj (n,h,metasenv,subst,o)) with NCicRefiner.RefineFailure msg | NCicRefiner.Uncertain msg -> debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^ snd (Lazy.force msg))); None | NCicRefiner.AssertFailure msg -> debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^ Lazy.force msg)); None | _ -> None in HExtlib.filter_map build_status (f status metasenv subst ctx eq_cache (NCic.Rel ~-1,gty)) ;; let fast_eq_check eq_cache status goal = match solve true status eq_cache goal with | [] -> raise (Error (lazy "no proof found",None)) | s::_ -> s ;; let dist_fast_eq_check eq_cache s = NTactics.distribute_tac (fast_eq_check eq_cache) s ;; let auto_eq_check eq_cache status = try let s = dist_fast_eq_check eq_cache status in [s] with | Error _ -> [] ;; (* warning: ctx is supposed to be already instantiated w.r.t subst *) let index_local_equations eq_cache status = let open_goals = head_goals status#stack in let open_goal = List.hd open_goals in let ngty = get_goalty status open_goal in let ctx = ctx_of ngty in let c = ref 0 in List.fold_left (fun eq_cache _ -> c:= !c+1; let t = NCic.Rel !c in try let ty = NCicTypeChecker.typeof [] [] ctx t in if is_a_fact status (mk_cic_term ctx ty) then (debug_print(lazy("eq indexing " ^ (NCicPp.ppterm ctx [] [] ty))); NCicParamod.forward_infer_step eq_cache t ty) else (debug_print (lazy ("not a fact: " ^ (NCicPp.ppterm ctx [] [] ty))); eq_cache) with | NCicTypeChecker.TypeCheckerFailure _ | NCicTypeChecker.AssertFailure _ -> eq_cache) eq_cache ctx ;; let fast_eq_check_tac ~params s = let unit_eq = index_local_equations s#eq_cache s in dist_fast_eq_check unit_eq s ;; let paramod eq_cache status goal = match solve false status eq_cache goal with | [] -> raise (Error (lazy "no proof found",None)) | s::_ -> s ;; let paramod_tac ~params s = let unit_eq = index_local_equations s#eq_cache s in NTactics.distribute_tac (paramod unit_eq) s ;; (* let fast_eq_check_tac_all ~params eq_cache status = let g,_,_ = current_goal status in let allstates = fast_eq_check_all status eq_cache g in let pseudo_low_tac s _ _ = s in let pseudo_low_tactics = List.map pseudo_low_tac allstates in List.map (fun f -> NTactics.distribute_tac f status) pseudo_low_tactics ;; *) (* let demod status eq_cache goal = let n,h,metasenv,subst,o = status#obj in let gname, ctx, gty = List.assoc goal metasenv in let gty = NCicUntrusted.apply_subst subst ctx gty in let demod_tac ~params s = let unit_eq = index_local_equations s#eq_cache s in dist_fast_eq_check unit_eq s *) (*************** subsumption ****************) let close_wrt_context = List.fold_left (fun ty ctx_entry -> match ctx_entry with | name, NCic.Decl t -> NCic.Prod(name,t,ty) | name, NCic.Def(bo, _) -> NCicSubstitution.subst bo ty) ;; let args_for_context ?(k=1) ctx = let _,args = List.fold_left (fun (n,l) ctx_entry -> match ctx_entry with | name, NCic.Decl t -> n+1,NCic.Rel(n)::l | name, NCic.Def(bo, _) -> n+1,l) (k,[]) ctx in args let constant_for_meta ctx ty i = let name = "cic:/foo"^(string_of_int i)^".con" in let uri = NUri.uri_of_string name in let ty = close_wrt_context ty ctx in (* prerr_endline (NCicPp.ppterm [] [] [] ty); *) let attr = (`Generated,`Definition,`Local) in let obj = NCic.Constant([],name,None,ty,attr) in (* Constant of relevance * string * term option * term * c_attr *) (uri,0,[],[],obj) (* not used *) let refresh metasenv = List.fold_left (fun (metasenv,subst) (i,(iattr,ctx,ty)) -> let ikind = NCicUntrusted.kind_of_meta iattr in let metasenv,j,instance,ty = NCicMetaSubst.mk_meta ~attrs:iattr metasenv ctx ~with_type:ty ikind in let s_entry = i,(iattr, ctx, instance, ty) in let metasenv = List.filter (fun x,_ -> i <> x) metasenv in metasenv,s_entry::subst) (metasenv,[]) metasenv (* close metasenv returns a ground instance of all the metas in the metasenv, insantiatied with axioms, and the list of these axioms *) let close_metasenv metasenv subst = (* let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in *) let metasenv = NCicUntrusted.sort_metasenv subst metasenv in List.fold_left (fun (subst,objs) (i,(iattr,ctx,ty)) -> let ty = NCicUntrusted.apply_subst subst ctx ty in let ctx = NCicUntrusted.apply_subst_context ~fix_projections:true subst ctx in let (uri,_,_,_,obj) as okind = constant_for_meta ctx ty i in try NCicEnvironment.check_and_add_obj okind; let iref = NReference.reference_of_spec uri NReference.Decl in let iterm = let args = args_for_context ctx in if args = [] then NCic.Const iref else NCic.Appl(NCic.Const iref::args) in (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *) let s_entry = i, ([], ctx, iterm, ty) in s_entry::subst,okind::objs with _ -> assert false) (subst,[]) metasenv ;; let ground_instances status gl = let _,_,metasenv,subst,_ = status#obj in let subset = menv_closure status gl in let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in (* let submenv = metasenv in *) let subst, objs = close_metasenv submenv subst in try List.iter (fun i -> let (_, ctx, t, _) = List.assoc i subst in debug_print (lazy (NCicPp.ppterm ctx [] [] t)); List.iter (fun (uri,_,_,_,_) as obj -> NCicEnvironment.invalidate_item (`Obj (uri, obj))) objs; ()) gl with Not_found -> assert false (* (ctx,t) *) ;; let replace_meta i args target = let rec aux k = function (* TODO: local context *) | NCic.Meta (j,lc) when i = j -> (match args with | [] -> NCic.Rel 1 | _ -> let args = List.map (NCicSubstitution.subst_meta lc) args in NCic.Appl(NCic.Rel k::args)) | NCic.Meta (j,lc) as m -> (match lc with _,NCic.Irl _ -> m | n,NCic.Ctx l -> NCic.Meta (i,(0,NCic.Ctx (List.map (fun t -> aux k (NCicSubstitution.lift n t)) l)))) | t -> NCicUtils.map (fun _ k -> k+1) k aux t in aux 1 target ;; let close_wrt_metasenv subst = List.fold_left (fun ty (i,(iattr,ctx,mty)) -> let mty = NCicUntrusted.apply_subst subst ctx mty in let ctx = NCicUntrusted.apply_subst_context ~fix_projections:true subst ctx in let cty = close_wrt_context mty ctx in let name = "foo"^(string_of_int i) in let ty = NCicSubstitution.lift 1 ty in let args = args_for_context ~k:1 ctx in (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *) let ty = replace_meta i args ty in NCic.Prod(name,cty,ty)) ;; let close status g = let _,_,metasenv,subst,_ = status#obj in let subset = menv_closure status [g] in let subset = IntSet.remove g subset in let elems = IntSet.elements subset in let _, ctx, ty = NCicUtils.lookup_meta g metasenv in let ty = NCicUntrusted.apply_subst subst ctx ty in debug_print (lazy ("metas in " ^ (NCicPp.ppterm ctx [] metasenv ty))); debug_print (lazy (String.concat ", " (List.map string_of_int elems))); let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in let submenv = List.rev (NCicUntrusted.sort_metasenv subst submenv) in (* let submenv = metasenv in *) let ty = close_wrt_metasenv subst ty submenv in debug_print (lazy (NCicPp.ppterm ctx [] [] ty)); ctx,ty ;; (* =================================== auto =========================== *) (****************** AUTO ******************** let calculate_timeout flags = if flags.timeout = 0. then (debug_print (lazy "AUTO WITH NO TIMEOUT"); {flags with timeout = infinity}) else flags ;; let is_equational_case goalty flags = let ensure_equational t = if is_an_equational_goal t then true else false in (flags.use_paramod && is_an_equational_goal goalty) || (flags.use_only_paramod && ensure_equational goalty) ;; type menv = Cic.metasenv type subst = Cic.substitution type goal = ProofEngineTypes.goal * int * AutoTypes.sort let candidate_no = ref 0;; type candidate = int * Cic.term Lazy.t type cache = AutoCache.cache type fail = (* the goal (mainly for depth) and key of the goal *) goal * AutoCache.cache_key type op = (* goal has to be proved *) | D of goal (* goal has to be cached as a success obtained using candidate as the first * step *) | S of goal * AutoCache.cache_key * candidate * int type elem = (* menv, subst, size, operations done (only S), operations to do, failures to cache if any op fails *) menv * subst * int * op list * op list * fail list type status = (* list of computations that may lead to the solution: all op list will * end with the same (S(g,_)) *) elem list type auto_result = (* menv, subst, alternatives, tables, cache *) | Proved of menv * subst * elem list * AutomationCache.tables * cache | Gaveup of AutomationCache.tables * cache (* the status exported to the external observer *) type auto_status = (* context, (goal,candidate) list, and_list, history *) Cic.context * (int * Cic.term * bool * int * (int * Cic.term Lazy.t) list) list * (int * Cic.term * int) list * Cic.term Lazy.t list let d_prefix l = let rec aux acc = function | (D g)::tl -> aux (acc@[g]) tl | _ -> acc in aux [] l ;; let calculate_goal_ty (goalno,_,_) s m = try let _,cc,goalty = CicUtil.lookup_meta goalno m in (* XXX applicare la subst al contesto? *) Some (cc, CicMetaSubst.apply_subst s goalty) with CicUtil.Meta_not_found i when i = goalno -> None ;; let calculate_closed_goal_ty (goalno,_,_) s = try let cc,_,goalty = List.assoc goalno s in (* XXX applicare la subst al contesto? *) Some (cc, CicMetaSubst.apply_subst s goalty) with Not_found -> None ;; let pp_status ctx status = if debug then let names = Utils.names_of_context ctx in let pp x = let x = ProofEngineReduction.replace ~equality:(fun a b -> match b with Cic.Meta _ -> true | _ -> false) ~what:[Cic.Rel 1] ~with_what:[Cic.Implicit None] ~where:x in CicPp.pp x names in let string_of_do m s (gi,_,_ as g) d = match calculate_goal_ty g s m with | Some (_,gty) -> Printf.sprintf "D(%d, %s, %d)" gi (pp gty) d | None -> Printf.sprintf "D(%d, _, %d)" gi d in let string_of_s m su k (ci,ct) gi = Printf.sprintf "S(%d, %s, %s, %d)" gi (pp k) (pp (Lazy.force ct)) ci in let string_of_ol m su l = String.concat " | " (List.map (function | D (g,d,s) -> string_of_do m su (g,d,s) d | S ((gi,_,_),k,c,_) -> string_of_s m su k c gi) l) in let string_of_fl m s fl = String.concat " | " (List.map (fun ((i,_,_),ty) -> Printf.sprintf "(%d, %s)" i (pp ty)) fl) in let rec aux = function | [] -> () | (m,s,_,_,ol,fl)::tl -> Printf.eprintf "< [%s] ;;; [%s]>\n" (string_of_ol m s ol) (string_of_fl m s fl); aux tl in Printf.eprintf "-------------------------- status -------------------\n"; aux status; Printf.eprintf "-----------------------------------------------------\n"; ;; let auto_status = ref [] ;; let auto_context = ref [];; let in_pause = ref false;; let pause b = in_pause := b;; let cond = Condition.create ();; let mutex = Mutex.create ();; let hint = ref None;; let prune_hint = ref [];; let step _ = Condition.signal cond;; let give_hint n = hint := Some n;; let give_prune_hint hint = prune_hint := hint :: !prune_hint ;; let check_pause _ = if !in_pause then begin Mutex.lock mutex; Condition.wait cond mutex; Mutex.unlock mutex end ;; let get_auto_status _ = let status = !auto_status in let and_list,elems,last = match status with | [] -> [],[],[] | (m,s,_,don,gl,fail)::tl -> let and_list = HExtlib.filter_map (fun (id,d,_ as g) -> match calculate_goal_ty g s m with | Some (_,x) -> Some (id,x,d) | None -> None) (d_goals gl) in let rows = (* these are the S goalsin the or list *) let orlist = List.map (fun (m,s,_,don,gl,fail) -> HExtlib.filter_map (function S (g,k,c,_) -> Some (g,k,c) | _ -> None) (List.rev don @ gl)) status in (* this function eats id from a list l::[id,x] returning x, l *) let eat_tail_if_eq id l = let rec aux (s, l) = function | [] -> s, l | ((id1,_,_),k1,c)::tl when id = id1 -> (match s with | None -> aux (Some c,l) tl | Some _ -> assert false) | ((id1,_,_),k1,c as e)::tl -> aux (s, e::l) tl in let c, l = aux (None, []) l in c, List.rev l in let eat_in_parallel id l = let rec aux (b,eaten, new_l as acc) l = match l with | [] -> acc | l::tl -> match eat_tail_if_eq id l with | None, l -> aux (b@[false], eaten, new_l@[l]) tl | Some t,l -> aux (b@[true],eaten@[t], new_l@[l]) tl in aux ([],[],[]) l in let rec eat_all rows l = match l with | [] -> rows | elem::or_list -> match List.rev elem with | ((to_eat,depth,_),k,_)::next_lunch -> let b, eaten, l = eat_in_parallel to_eat l in let eaten = HExtlib.list_uniq eaten in let eaten = List.rev eaten in let b = true (* List.hd (List.rev b) *) in let rows = rows @ [to_eat,k,b,depth,eaten] in eat_all rows l | [] -> eat_all rows or_list in eat_all [] (List.rev orlist) in let history = HExtlib.filter_map (function (S (_,_,(_,c),_)) -> Some c | _ -> None) gl in (* let rows = List.filter (fun (_,l) -> l <> []) rows in *) and_list, rows, history in !auto_context, elems, and_list, last ;; (* Works if there is no dependency over proofs *) let is_a_green_cut goalty = CicUtil.is_meta_closed goalty ;; let rec first_s = function | (D _)::tl -> first_s tl | (S (g,k,c,s))::tl -> Some ((g,k,c,s),tl) | [] -> None ;; let list_union l1 l2 = (* TODO ottimizzare compare *) HExtlib.list_uniq (List.sort compare (l1 @ l1)) ;; let rec eq_todo l1 l2 = match l1,l2 with | (D g1) :: tl1,(D g2) :: tl2 when g1=g2 -> eq_todo tl1 tl2 | (S (g1,k1,(c1,lt1),i1)) :: tl1, (S (g2,k2,(c2,lt2),i2)) :: tl2 when i1 = i2 && g1 = g2 && k1 = k2 && c1 = c2 -> if Lazy.force lt1 = Lazy.force lt2 then eq_todo tl1 tl2 else false | [],[] -> true | _ -> false ;; let eat_head todo id fl orlist = let rec aux acc = function | [] -> [], acc | (m, s, _, _, todo1, fl1)::tl as orlist -> let rec aux1 todo1 = match first_s todo1 with | None -> orlist, acc | Some (((gno,_,_),_,_,_), todo11) -> (* TODO confronto tra todo da ottimizzare *) if gno = id && eq_todo todo11 todo then aux (list_union fl1 acc) tl else aux1 todo11 in aux1 todo1 in aux fl orlist ;; let close_proof p ty menv context = let metas = List.map fst (CicUtil.metas_of_term p @ CicUtil.metas_of_term ty) in let menv = List.filter (fun (i,_,_) -> List.exists ((=)i) metas) menv in naif_closure p menv context ;; (* XXX capire bene quando aggiungere alla cache *) let add_to_cache_and_del_from_orlist_if_green_cut g s m cache key todo orlist fl ctx size minsize = let cache = cache_remove_underinspection cache key in (* prima per fare la irl usavamo il contesto vero e proprio e non quello * canonico! XXX *) match calculate_closed_goal_ty g s with | None -> assert false | Some (canonical_ctx , gty) -> let goalno,depth,sort = g in let irl = mk_irl canonical_ctx in let goal = Cic.Meta(goalno, irl) in let proof = CicMetaSubst.apply_subst s goal in let green_proof, closed_proof = let b = is_a_green_cut proof in if not b then b, (* close_proof proof gty m ctx *) proof else b, proof in debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm key)); if is_a_green_cut key then (* if the initia goal was closed, we cut alternatives *) let _ = debug_print (lazy ("MANGIO: " ^ string_of_int goalno)) in let orlist, fl = eat_head todo goalno fl orlist in let cache = if size < minsize then (debug_print (lazy ("NO CACHE: 2 (size <= minsize)"));cache) else (* if the proof is closed we cache it *) if green_proof then cache_add_success cache key proof else (* cache_add_success cache key closed_proof *) (debug_print (lazy ("NO CACHE: (no gree proof)"));cache) in cache, orlist, fl, true else let cache = debug_print (lazy ("TENTATIVE CACHE: " ^ CicPp.ppterm gty)); if size < minsize then (debug_print (lazy ("NO CACHE: (size <= minsize)")); cache) else (* if the substituted goal and the proof are closed we cache it *) if is_a_green_cut gty then if green_proof then cache_add_success cache gty proof else (* cache_add_success cache gty closed_proof *) (debug_print (lazy ("NO CACHE: (no green proof (gty))"));cache) else (* try let ty, _ = CicTypeChecker.type_of_aux' ~subst:s m ctx closed_proof CicUniv.oblivion_ugraph in if is_a_green_cut ty then cache_add_success cache ty closed_proof else cache with | CicTypeChecker.TypeCheckerFailure _ ->*) (debug_print (lazy ("NO CACHE: (no green gty )"));cache) in cache, orlist, fl, false ;; let close_failures (fl : fail list) (cache : cache) = List.fold_left (fun cache ((gno,depth,_),gty) -> if CicUtil.is_meta_closed gty then ( debug_print (lazy ("FAIL: INDUCED: " ^ string_of_int gno)); cache_add_failure cache gty depth) else cache) cache fl ;; let put_in_subst subst metasenv (goalno,_,_) canonical_ctx t ty = let entry = goalno, (canonical_ctx, t,ty) in assert_subst_are_disjoint subst [entry]; let subst = entry :: subst in let metasenv = CicMetaSubst.apply_subst_metasenv subst metasenv in subst, metasenv ;; let mk_fake_proof metasenv subst (goalno,_,_) goalty context = None,metasenv,subst ,(lazy (Cic.Meta(goalno,mk_irl context))),goalty, [] ;; let equational_case tables cache depth fake_proof goalno goalty subst context flags = let active,passive,bag = tables in let ppterm = ppterm context in let status = (fake_proof,goalno) in if flags.use_only_paramod then begin debug_print (lazy ("PARAMODULATION SU: " ^ string_of_int goalno ^ " " ^ ppterm goalty )); let goal_steps, saturation_steps, timeout = max_int,max_int,flags.timeout in match Saturation.given_clause bag status active passive goal_steps saturation_steps timeout with | None, active, passive, bag -> [], (active,passive,bag), cache, flags | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active, passive,bag -> assert_subst_are_disjoint subst subst'; let subst = subst@subst' in let open_goals = order_new_goals metasenv subst open_goals ppterm in let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in incr candidate_no; [(!candidate_no,proof),metasenv,subst,open_goals], (active,passive,bag), cache, flags end else begin debug_print (lazy ("NARROWING DEL GOAL: " ^ string_of_int goalno ^ " " ^ ppterm goalty )); let goal_steps, saturation_steps, timeout = 1,0,flags.timeout in match Saturation.solve_narrowing bag status active passive goal_steps with | None, active, passive, bag -> [], (active,passive,bag), cache, flags | Some(subst',(_,metasenv,_subst,proof,_, _),open_goals),active, passive,bag -> assert_subst_are_disjoint subst subst'; let subst = subst@subst' in let open_goals = order_new_goals metasenv subst open_goals ppterm in let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in incr candidate_no; [(!candidate_no,proof),metasenv,subst,open_goals], (active,passive,bag), cache, flags end (* begin let params = ([],["use_context","false"]) in let automation_cache = { AutomationCache.tables = tables ; AutomationCache.univ = Universe.empty; } in try let ((_,metasenv,subst,_,_,_),open_goals) = solve_rewrite ~params ~automation_cache (fake_proof, goalno) in let proof = lazy (Cic.Meta (-1,[])) in [(!candidate_no,proof),metasenv,subst,[]],tables, cache, flags with ProofEngineTypes.Fail _ -> [], tables, cache, flags (* let res = Saturation.all_subsumed bag status active passive in let res' = List.map (fun (subst',(_,metasenv,_subst,proof,_, _),open_goals) -> assert_subst_are_disjoint subst subst'; let subst = subst@subst' in let open_goals = order_new_goals metasenv subst open_goals ppterm in let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in incr candidate_no; (!candidate_no,proof),metasenv,subst,open_goals) res in res', (active,passive,bag), cache, flags *) end *) ;; let sort_new_elems = List.sort (fun (_,_,_,l1) (_,_,_,l2) -> let p1 = List.length (prop_only l1) in let p2 = List.length (prop_only l2) in if p1 = p2 then List.length l1 - List.length l2 else p1-p2) ;; let try_candidate dbd goalty tables subst fake_proof goalno depth context cand = let ppterm = ppterm context in try let actives, passives, bag = tables in let (_,metasenv,subst,_,_,_), open_goals = ProofEngineTypes.apply_tactic (PrimitiveTactics.apply_tac ~term:cand) (fake_proof,goalno) in let tables = actives, passives, Equality.push_maxmeta bag (max (Equality.maxmeta bag) (CicMkImplicit.new_meta metasenv subst)) in debug_print (lazy (" OK: " ^ ppterm cand)); let metasenv = CicRefine.pack_coercion_metasenv metasenv in let open_goals = order_new_goals metasenv subst open_goals ppterm in let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in incr candidate_no; Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables with | ProofEngineTypes.Fail s -> None,tables | CicUnification.Uncertain s -> None,tables ;; let applicative_case dbd tables depth subst fake_proof goalno goalty metasenv context signature universe cache flags = (* let goalty_aux = match goalty with | Cic.Appl (hd::tl) -> Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl)) | _ -> goalty in *) let goalty_aux = goalty in let candidates = get_candidates flags.skip_trie_filtering universe cache goalty_aux in (* if the goal is an equality we skip the congruence theorems let candidates = if is_equational_case goalty flags then List.filter not_default_eq_term candidates else candidates in *) let candidates = List.filter (only signature context metasenv) candidates in let tables, elems = List.fold_left (fun (tables,elems) cand -> match try_candidate dbd goalty tables subst fake_proof goalno depth context cand with | None, tables -> tables, elems | Some x, tables -> tables, x::elems) (tables,[]) candidates in let elems = sort_new_elems elems in elems, tables, cache ;; let try_smart_candidate dbd goalty tables subst fake_proof goalno depth context cand = let ppterm = ppterm context in try let params = ([],[]) in let automation_cache = { AutomationCache.tables = tables ; AutomationCache.univ = Universe.empty; } in debug_print (lazy ("candidato per " ^ string_of_int goalno ^ ": " ^ CicPp.ppterm cand)); (* let (_,metasenv,subst,_,_,_) = fake_proof in prerr_endline ("metasenv:\n" ^ CicMetaSubst.ppmetasenv [] metasenv); prerr_endline ("subst:\n" ^ CicMetaSubst.ppsubst ~metasenv subst); *) let ((_,metasenv,subst,_,_,_),open_goals) = apply_smart ~dbd ~term:cand ~params ~automation_cache (fake_proof, goalno) in let metasenv = CicRefine.pack_coercion_metasenv metasenv in let open_goals = order_new_goals metasenv subst open_goals ppterm in let open_goals = List.map (fun (x,sort) -> x,depth-1,sort) open_goals in incr candidate_no; Some ((!candidate_no,lazy cand),metasenv,subst,open_goals), tables with | ProofEngineTypes.Fail s -> None,tables | CicUnification.Uncertain s -> None,tables ;; let smart_applicative_case dbd tables depth subst fake_proof goalno goalty metasenv context signature universe cache flags = let goalty_aux = match goalty with | Cic.Appl (hd::tl) -> Cic.Appl (hd :: HExtlib.mk_list (Cic.Meta (0,[])) (List.length tl)) | _ -> goalty in let smart_candidates = get_candidates flags.skip_trie_filtering universe cache goalty_aux in let candidates = get_candidates flags.skip_trie_filtering universe cache goalty in let smart_candidates = List.filter (fun x -> not(List.mem x candidates)) smart_candidates in let debug_msg = (lazy ("smart_candidates" ^ " = " ^ (String.concat "\n" (List.map CicPp.ppterm smart_candidates)))) in debug_print debug_msg; let candidates = List.filter (only signature context metasenv) candidates in let smart_candidates = List.filter (only signature context metasenv) smart_candidates in (* let penalty cand depth = if only signature context metasenv cand then depth else ((prerr_endline ( "penalizzo " ^ CicPp.ppterm cand));depth -1) in *) let tables, elems = List.fold_left (fun (tables,elems) cand -> match try_candidate dbd goalty tables subst fake_proof goalno depth context cand with | None, tables -> (* if normal application fails we try to be smart *) (match try_smart_candidate dbd goalty tables subst fake_proof goalno depth context cand with | None, tables -> tables, elems | Some x, tables -> tables, x::elems) | Some x, tables -> tables, x::elems) (tables,[]) candidates in let tables, smart_elems = List.fold_left (fun (tables,elems) cand -> match try_smart_candidate dbd goalty tables subst fake_proof goalno depth context cand with | None, tables -> tables, elems | Some x, tables -> tables, x::elems) (tables,[]) smart_candidates in let elems = sort_new_elems (elems @ smart_elems) in elems, tables, cache ;; let equational_and_applicative_case dbd signature universe flags m s g gty tables cache context = let goalno, depth, sort = g in let fake_proof = mk_fake_proof m s g gty context in if is_equational_case gty flags then let elems,tables,cache, flags = equational_case tables cache depth fake_proof goalno gty s context flags in let more_elems, tables, cache = if flags.use_only_paramod then [],tables, cache else applicative_case dbd tables depth s fake_proof goalno gty m context signature universe cache flags in elems@more_elems, tables, cache, flags else let elems, tables, cache = match LibraryObjects.eq_URI () with | Some _ -> smart_applicative_case dbd tables depth s fake_proof goalno gty m context signature universe cache flags | None -> applicative_case dbd tables depth s fake_proof goalno gty m context signature universe cache flags in elems, tables, cache, flags ;; let rec condition_for_hint i = function | [] -> false | S (_,_,(j,_),_):: tl -> j <> i (* && condition_for_hint i tl *) | _::tl -> condition_for_hint i tl ;; let prunable_for_size flags s m todo = let rec aux b = function | (S _)::tl -> aux b tl | (D (_,_,T))::tl -> aux b tl | (D g)::tl -> (match calculate_goal_ty g s m with | None -> aux b tl | Some (canonical_ctx, gty) -> let gsize, _ = Utils.weight_of_term ~consider_metas:false ~count_metas_occurrences:true gty in let newb = b || gsize > flags.maxgoalsizefactor in aux newb tl) | [] -> b in aux false todo (* let prunable ty todo = let rec aux b = function | (S(_,k,_,_))::tl -> aux (b || Equality.meta_convertibility k ty) tl | (D (_,_,T))::tl -> aux b tl | D _::_ -> false | [] -> b in aux false todo ;; *) let prunable menv subst ty todo = let rec aux = function | (S(_,k,_,_))::tl -> (match Equality.meta_convertibility_subst k ty menv with | None -> aux tl | Some variant -> no_progress variant tl (* || aux tl*)) | (D (_,_,T))::tl -> aux tl | _ -> false and no_progress variant = function | [] -> (*prerr_endline "++++++++++++++++++++++++ no_progress";*) true | D ((n,_,P) as g)::tl -> (match calculate_goal_ty g subst menv with | None -> no_progress variant tl | Some (_, gty) -> (match calculate_goal_ty g variant menv with | None -> assert false | Some (_, gty') -> if gty = gty' then no_progress variant tl (* (prerr_endline (string_of_int n); prerr_endline (CicPp.ppterm gty); prerr_endline (CicPp.ppterm gty'); prerr_endline "---------- subst"; prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv subst); prerr_endline "---------- variant"; prerr_endline (CicMetaSubst.ppsubst ~metasenv:menv variant); prerr_endline "---------- menv"; prerr_endline (CicMetaSubst.ppmetasenv [] menv); no_progress variant tl) *) else false)) | _::tl -> no_progress variant tl in aux todo ;; let condition_for_prune_hint prune (m, s, size, don, todo, fl) = let s = HExtlib.filter_map (function S (_,_,(c,_),_) -> Some c | _ -> None) todo in List.for_all (fun i -> List.for_all (fun j -> i<>j) prune) s ;; let filter_prune_hint c l = let prune = !prune_hint in prune_hint := []; (* possible race... *) if prune = [] then c,l else cache_reset_underinspection c, List.filter (condition_for_prune_hint prune) l ;; let auto_all_solutions dbd tables universe cache context metasenv gl flags = let signature = List.fold_left (fun set g -> MetadataConstraints.UriManagerSet.union set (MetadataQuery.signature_of metasenv g) ) MetadataConstraints.UriManagerSet.empty gl in let goals = order_new_goals metasenv [] gl CicPp.ppterm in let goals = List.map (fun (x,s) -> D (x,flags.maxdepth,s)) goals in let elems = [metasenv,[],1,[],goals,[]] in let rec aux tables solutions cache elems flags = match auto_main dbd tables context flags signature universe cache elems with | Gaveup (tables,cache) -> solutions,cache, tables | Proved (metasenv,subst,others,tables,cache) -> if Unix.gettimeofday () > flags.timeout then ((subst,metasenv)::solutions), cache, tables else aux tables ((subst,metasenv)::solutions) cache others flags in let rc = aux tables [] cache elems flags in match rc with | [],cache,tables -> [],cache,tables | solutions, cache,tables -> let solutions = HExtlib.filter_map (fun (subst,newmetasenv) -> let opened = ProofEngineHelpers.compare_metasenvs ~oldmetasenv:metasenv ~newmetasenv in if opened = [] then Some subst else None) solutions in solutions,cache,tables ;; (******************* AUTO ***************) let auto dbd flags metasenv tables universe cache context metasenv gl = let initial_time = Unix.gettimeofday() in let signature = List.fold_left (fun set g -> MetadataConstraints.UriManagerSet.union set (MetadataQuery.signature_of metasenv g) ) MetadataConstraints.UriManagerSet.empty gl in let goals = order_new_goals metasenv [] gl CicPp.ppterm in let goals = List.map (fun (x,s) -> D(x,flags.maxdepth,s)) goals in let elems = [metasenv,[],1,[],goals,[]] in match auto_main dbd tables context flags signature universe cache elems with | Proved (metasenv,subst,_, tables,cache) -> debug_print(lazy ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); Some (subst,metasenv), cache | Gaveup (tables,cache) -> debug_print(lazy ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); None,cache ;; let auto_tac ~(dbd:HSql.dbd) ~params:(univ,params) ~automation_cache (proof, goal) = let flags = flags_of_params params () in let use_library = flags.use_library in let universe, tables, cache = init_cache_and_tables ~dbd ~use_library ~use_context:(not flags.skip_context) automation_cache univ (proof, goal) in let _,metasenv,subst,_,_, _ = proof in let _,context,goalty = CicUtil.lookup_meta goal metasenv in let signature = MetadataQuery.signature_of metasenv goal in let signature = List.fold_left (fun set t -> let ty, _ = CicTypeChecker.type_of_aux' metasenv context t CicUniv.oblivion_ugraph in MetadataConstraints.UriManagerSet.union set (MetadataConstraints.constants_of ty) ) signature univ in let tables,cache = if flags.close_more then close_more tables context (proof, goal) (auto_all_solutions dbd) signature universe cache else tables,cache in let initial_time = Unix.gettimeofday() in let (_,oldmetasenv,_,_,_, _) = proof in hint := None; let elem = metasenv,subst,1,[],[D (goal,flags.maxdepth,P)],[] in match auto_main dbd tables context flags signature universe cache [elem] with | Proved (metasenv,subst,_, tables,cache) -> debug_print (lazy ("TIME:"^string_of_float(Unix.gettimeofday()-.initial_time))); let proof,metasenv = ProofEngineHelpers.subst_meta_and_metasenv_in_proof proof goal subst metasenv in let opened = ProofEngineHelpers.compare_metasenvs ~oldmetasenv ~newmetasenv:metasenv in proof,opened | Gaveup (tables,cache) -> debug_print (lazy ("TIME:"^ string_of_float(Unix.gettimeofday()-.initial_time))); raise (ProofEngineTypes.Fail (lazy "Auto gave up")) ;; *) (****************** smart application ********************) let smart_apply t unit_eq status g = let n,h,metasenv,subst,o = status#obj in let gname, ctx, gty = List.assoc g metasenv in (* let ggty = mk_cic_term context gty in *) let status, t = disambiguate status ctx t None in let status,t = term_of_cic_term status t ctx in let ty = NCicTypeChecker.typeof subst metasenv ctx t in let ty,metasenv,args = NCicMetaSubst.saturate metasenv subst ctx ty 0 in let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in let status = status#set_obj (n,h,metasenv,subst,o) in let pterm = if args=[] then t else NCic.Appl(t::args) in let eq_coerc = let uri = NUri.uri_of_string "cic:/matita/ng/Plogic/equality/eq_coerc.con" in let ref = NReference.reference_of_spec uri (NReference.Def(2)) in NCic.Const ref in let smart = NCic.Appl[eq_coerc;ty;NCic.Implicit `Type;pterm;inst] in let smart = mk_cic_term ctx smart in try let status = instantiate status g smart in let _,_,metasenv,subst,_ = status#obj in let _,ctx,jty = List.assoc j metasenv in let jty = NCicUntrusted.apply_subst subst ctx jty in debug_print(lazy("goal " ^ (NCicPp.ppterm ctx [] [] jty))); fast_eq_check unit_eq status j with | Error _ as e -> debug_print (lazy "error"); raise e let smart_apply_tac t s = let unit_eq = index_local_equations s#eq_cache s in NTactics.distribute_tac (smart_apply t unit_eq) s let smart_apply_auto t eq_cache = NTactics.distribute_tac (smart_apply t eq_cache) (****************** types **************) type th_cache = (NCic.context * InvRelDiscriminationTree.t) list let keys_of_term status t = let status, orig_ty = typeof status (ctx_of t) t in let _, ty, _ = saturate ~delta:max_int status orig_ty in let keys = [ty] in let keys = let _, ty = term_of_cic_term status ty (ctx_of ty) in match ty with | NCic.Const (NReference.Ref (_,NReference.Def h)) | NCic.Appl (NCic.Const(NReference.Ref(_,NReference.Def h))::_) when h > 0 -> let _,ty,_= saturate status ~delta:(h-1) orig_ty in ty::keys | _ -> keys in status, keys ;; let mk_th_cache status gl = List.fold_left (fun (status, acc) g -> let gty = get_goalty status g in let ctx = ctx_of gty in debug_print(lazy("th cache for: "^ppterm status gty)); debug_print(lazy("th cache in: "^ppcontext status ctx)); if List.mem_assq ctx acc then status, acc else let idx = InvRelDiscriminationTree.empty in let status,_,idx = List.fold_left (fun (status, i, idx) _ -> let t = mk_cic_term ctx (NCic.Rel i) in debug_print(lazy("indexing: "^ppterm status t)); let status, keys = keys_of_term status t in let idx = List.fold_left (fun idx k -> InvRelDiscriminationTree.index idx k t) idx keys in status, i+1, idx) (status, 1, idx) ctx in status, (ctx, idx) :: acc) (status,[]) gl ;; let add_to_th t c ty = let key_c = ctx_of t in if not (List.mem_assq key_c c) then (key_c ,InvRelDiscriminationTree.index InvRelDiscriminationTree.empty ty t ) :: c else let rec replace = function | [] -> [] | (x, idx) :: tl when x == key_c -> (x, InvRelDiscriminationTree.index idx ty t) :: tl | x :: tl -> x :: replace tl in replace c ;; let pp_idx status idx = InvRelDiscriminationTree.iter idx (fun k set -> debug_print(lazy("K: " ^ NCicInverseRelIndexable.string_of_path k)); Ncic_termSet.iter (fun t -> debug_print(lazy("\t"^ppterm status t))) set) ;; let pp_th status = List.iter (fun ctx, idx -> debug_print(lazy( "-----------------------------------------------")); debug_print(lazy( (NCicPp.ppcontext ~metasenv:[] ~subst:[] ctx))); debug_print(lazy( "||====> ")); pp_idx status idx) ;; let search_in_th gty th = let c = ctx_of gty in let rec aux acc = function | [] -> (* Ncic_termSet.elements *) acc | (_::tl) as k -> try let idx = List.assq k th in let acc = Ncic_termSet.union acc (InvRelDiscriminationTree.retrieve_unifiables idx gty) in aux acc tl with Not_found -> aux acc tl in aux Ncic_termSet.empty c ;; type flags = { do_types : bool; (* solve goals in Type *) last : bool; (* last goal: take first solution only *) maxwidth : int; maxsize : int; maxdepth : int; timeout : float; } type cache = {facts : th_cache; (* positive results *) under_inspection : th_cache; (* to prune looping *) unit_eq : NCicParamod.state } type sort = T | P type goal = int * sort (* goal, depth, sort *) type fail = goal * cic_term type candidate = int * Ast.term (* unique candidate number, candidate *) exception Gaveup of IntSet.t (* a sublist of unprovable conjunctive atoms of the input goals *) exception Proved of NTacStatus.tac_status let height_of_ref (NReference.Ref (uri, x)) = match x with | NReference.Decl | NReference.Ind _ | NReference.Con _ | NReference.CoFix _ -> let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in height | NReference.Def h -> h | NReference.Fix (_,_,h) -> h ;; let fast_height_of_term t = let h = ref 0 in let rec aux = function NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l | NCic.Meta _ -> () | NCic.Rel _ | NCic.Sort _ -> () | NCic.Implicit _ -> assert false | NCic.Const nref as t -> (* prerr_endline (NCicPp.ppterm ~metasenv:[] ~subst:[] ~context:[] t ^ ":" ^ string_of_int (height_of_ref nref)); *) h := max !h (height_of_ref nref) | NCic.Prod (_,t1,t2) | NCic.Lambda (_,t1,t2) -> aux t1; aux t2 | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t | NCic.Appl l -> List.iter aux l | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl in aux t; !h ;; let height_of_goals status = let open_goals = head_goals status#stack in assert (List.length open_goals > 0); let h = ref 0 in List.iter (fun open_goal -> let ty = get_goalty status open_goal in let context = ctx_of ty in let _, ty = term_of_cic_term status ty (ctx_of ty) in h := max !h (fast_height_of_term ty); List.iter (function | _, NCic.Decl ty -> h := max !h (fast_height_of_term ty) | _, NCic.Def (bo,ty) -> h := max !h (fast_height_of_term ty); h := max !h (fast_height_of_term bo); ) context) open_goals; prerr_endline ("altezza sequente: " ^ string_of_int !h); !h ;; (* let close_failures _ c = c;; *) (* let prunable _ _ _ = false;; *) (* let cache_examine cache gty = `Notfound;; *) (* let put_in_subst s _ _ _ = s;; *) (* let add_to_cache_and_del_from_orlist_if_green_cut _ _ c _ _ o f _ = c, o, f, false ;; *) (* let cache_add_underinspection c _ _ = c;; *) let init_cache ?(facts=[]) ?(under_inspection=[]) ?(unit_eq=NCicParamod.empty_state) _ = {facts = facts; under_inspection = under_inspection; unit_eq = unit_eq } let only signature _context candidate = (* TASSI: nel trie ci mettiamo solo il body, non il ty *) let candidate_ty = NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate in let height = fast_height_of_term candidate_ty in let rc = signature >= height in if rc = false then prerr_endline ("Filtro: " ^ NCicPp.ppterm ~context:[] ~subst:[] ~metasenv:[] candidate ^ ": " ^ string_of_int height) else prerr_endline ("Tengo: " ^ NCicPp.ppterm ~context:[] ~subst:[] ~metasenv:[] candidate ^ ": " ^ string_of_int height); rc ;; let candidate_no = ref 0;; let openg_no status = List.length (head_goals status#stack) let sort_new_elems l = List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l let try_candidate ?(smart=0) flags depth status eq_cache t = try debug_print ~depth (lazy ("------------ try " ^ CicNotationPp.pp_term t)); let status = if smart= 0 then NTactics.apply_tac ("",0,t) status else if smart = 1 then smart_apply_auto ("",0,t) eq_cache status else (* smart = 2: both *) try NTactics.apply_tac ("",0,t) status with Error _ -> smart_apply_auto ("",0,t) eq_cache status in let og_no = openg_no status in if (* og_no > flags.maxwidth || *) ((depth + 1) = flags.maxdepth && og_no <> 0) then (debug_print ~depth (lazy "pruned immediately"); None) else (incr candidate_no; Some ((!candidate_no,t),status)) with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None ;; let get_candidates ?(smart=true) status cache signature gty = let universe = status#auto_cache in let context = ctx_of gty in let t_ast t = let _status, t = term_of_cic_term status t context in Ast.NCic t in let c_ast = function | NCic.Const r -> Ast.NRef r | _ -> assert false in let _, raw_gty = term_of_cic_term status gty context in let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables universe raw_gty in let local_cands = search_in_th gty cache in let together global local = List.map c_ast (List.filter (only signature context) (NDiscriminationTree.TermSet.elements global)) @ List.map t_ast (Ncic_termSet.elements local) in let candidates = together cands local_cands in let smart_candidates = if smart then match raw_gty with | NCic.Appl (hd::tl) -> let weak_gty = NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0))) (List.length tl)) in let more_cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables universe weak_gty in let smart_cands = NDiscriminationTree.TermSet.diff more_cands cands in let cic_weak_gty = mk_cic_term context weak_gty in let more_local_cands = search_in_th cic_weak_gty cache in let smart_local_cands = Ncic_termSet.diff more_local_cands local_cands in together smart_cands smart_local_cands | _ -> [] else [] in candidates, smart_candidates ;; let applicative_case depth signature status flags gty (cache:cache) = app_counter:= !app_counter+1; let _,_,metasenv,subst,_ = status#obj in let context = ctx_of gty in let tcache = cache.facts in let is_eq = let status, t = term_of_cic_term status gty context in NCicParamod.is_equation metasenv subst context t in debug_print(lazy (string_of_bool is_eq)); let candidates, smart_candidates = get_candidates ~smart:(not is_eq) status tcache signature gty in debug_print ~depth (lazy ("candidates: " ^ string_of_int (List.length candidates))); debug_print ~depth (lazy ("smart candidates: " ^ string_of_int (List.length smart_candidates))); (* let sm = 0 in let smart_candidates = [] in *) let sm = if is_eq then 0 else 2 in let maxd = ((depth + 1) = flags.maxdepth) in let only_one = flags.last && maxd in debug_print (lazy ("only_one: " ^ (string_of_bool only_one))); debug_print (lazy ("maxd: " ^ (string_of_bool maxd))); let elems = List.fold_left (fun elems cand -> if (only_one && (elems <> [])) then elems else if (maxd && not(is_a_fact_ast status subst metasenv context cand)) then (debug_print (lazy "pruned: not a fact"); elems) else match try_candidate (~smart:sm) flags depth status cache.unit_eq cand with | None -> elems | Some x -> x::elems) [] candidates in let more_elems = if only_one && elems <> [] then elems else List.fold_left (fun elems cand -> if (only_one && (elems <> [])) then elems else if (maxd && not(is_a_fact_ast status subst metasenv context cand)) then (debug_print (lazy "pruned: not a fact"); elems) else match try_candidate (~smart:1) flags depth status cache.unit_eq cand with | None -> elems | Some x -> x::elems) [] smart_candidates in elems@more_elems ;; exception Found ;; (* gty is supposed to be meta-closed *) let is_subsumed depth status gty cache = if cache=[] then false else ( debug_print ~depth (lazy("Subsuming " ^ (ppterm status gty))); let n,h,metasenv,subst,obj = status#obj in let ctx = ctx_of gty in let _ , target = term_of_cic_term status gty ctx in let target = NCicSubstitution.lift 1 target in (* candidates must only be searched w.r.t the given context *) let candidates = try let idx = List.assq ctx cache in Ncic_termSet.elements (InvRelDiscriminationTree.retrieve_generalizations idx gty) with Not_found -> [] in debug_print ~depth (lazy ("failure candidates: " ^ string_of_int (List.length candidates))); try List.iter (fun t -> let _ , source = term_of_cic_term status t ctx in let implication = NCic.Prod("foo",source,target) in let metasenv,j,_,_ = NCicMetaSubst.mk_meta metasenv ctx ~with_type:implication `IsType in let status = status#set_obj (n,h,metasenv,subst,obj) in let status = status#set_stack [([1,Open j],[],[],`NoTag)] in try let status = NTactics.intro_tac "foo" status in let status = NTactics.apply_tac ("",0,Ast.NCic (NCic.Rel 1)) status in if (head_goals status#stack = []) then raise Found else () with | Error _ -> ()) candidates;false with Found -> debug_print ~depth (lazy "success");true) ;; let rec guess_name name ctx = if name = "_" then guess_name "auto" ctx else if not (List.mem_assoc name ctx) then name else guess_name (name^"'") ctx ;; let is_prod status = let _, ctx, gty = current_goal status in let _, raw_gty = term_of_cic_term status gty ctx in match raw_gty with | NCic.Prod (name,_,_) -> Some (guess_name name ctx) | _ -> None let intro ~depth status facts name = let status = NTactics.intro_tac name status in let _, ctx, ngty = current_goal status in let t = mk_cic_term ctx (NCic.Rel 1) in let status, keys = keys_of_term status t in let facts = List.fold_left (add_to_th t) facts keys in debug_print ~depth (lazy ("intro: "^ name)); (* unprovability is not stable w.r.t introduction *) status, facts ;; let rec intros_facts ~depth status facts = match is_prod status with | Some(name) -> let status,facts = intro ~depth status facts name in intros_facts ~depth status facts | _ -> status, facts ;; let rec intros ~depth status (cache:cache) = match is_prod status with | Some _ -> let status,facts = intros_facts ~depth status cache.facts in (* we reindex the equation from scratch *) let unit_eq = index_local_equations status#eq_cache status in (* under_inspection must be set to empty *) status, init_cache ~facts ~unit_eq () | _ -> status, cache ;; let reduce ~depth status g = let n,h,metasenv,subst,o = status#obj in let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in let ty = NCicUntrusted.apply_subst subst ctx ty in let ty' = NCicReduction.whd ~subst ctx ty in if ty = ty' then [] else (debug_print ~depth (lazy ("reduced to: "^ NCicPp.ppterm ctx subst metasenv ty')); let metasenv = (g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv) in let status = status#set_obj (n,h,metasenv,subst,o) in incr candidate_no; [(!candidate_no,Ast.Ident("__whd",None)),status]) ;; let do_something signature flags status g depth gty cache = (* whd *) let l = reduce ~depth status g in (* backward aplications *) let l1 = List.map (fun s -> incr candidate_no; ((!candidate_no,Ast.Ident("__paramod",None)),s)) (auto_eq_check cache.unit_eq status) in let l2 = if (l1 <> []) then [] else applicative_case depth signature status flags gty cache (* fast paramodulation *) in (* states in l1 have have an empty set of subgoals: no point to sort them *) l1 @ (sort_new_elems (l@l2)), cache ;; let pp_goal = function | (_,Continuationals.Stack.Open i) | (_,Continuationals.Stack.Closed i) -> string_of_int i ;; let pp_goals status l = String.concat ", " (List.map (fun i -> let gty = get_goalty status i in NTacStatus.ppterm status gty) l) ;; module M = struct type t = int let compare = Pervasives.compare end ;; module MS = HTopoSort.Make(M) ;; let sort_tac status = let gstatus = match status#stack with | [] -> assert false | (goals, t, k, tag) :: s -> let g = head_goals status#stack in let sortedg = (List.rev (MS.topological_sort g (deps status))) in debug_print (lazy ("old g = " ^ String.concat "," (List.map string_of_int g))); debug_print (lazy ("sorted goals = " ^ String.concat "," (List.map string_of_int sortedg))); let is_it i = function | (_,Continuationals.Stack.Open j ) | (_,Continuationals.Stack.Closed j ) -> i = j in let sorted_goals = List.map (fun i -> List.find (is_it i) goals) sortedg in (sorted_goals, t, k, tag) :: s in status#set_stack gstatus ;; let clean_up_tac status = let gstatus = match status#stack with | [] -> assert false | (g, t, k, tag) :: s -> let is_open = function | (_,Continuationals.Stack.Open _) -> true | (_,Continuationals.Stack.Closed _) -> false in let g' = List.filter is_open g in (g', t, k, tag) :: s in status#set_stack gstatus ;; let focus_tac focus status = let gstatus = match status#stack with | [] -> assert false | (g, t, k, tag) :: s -> let in_focus = function | (_,Continuationals.Stack.Open i) | (_,Continuationals.Stack.Closed i) -> List.mem i focus in let focus,others = List.partition in_focus g in (* we need to mark it as a BranchTag, otherwise cannot merge later *) (focus,[],[],`BranchTag) :: (others, t, k, tag) :: s in status#set_stack gstatus ;; let rec auto_clusters ?(top=false) flags signature cache depth status : unit = debug_print ~depth (lazy "entering auto clusters"); (* ignore(Unix.select [] [] [] 0.01); *) let status = clean_up_tac status in let goals = head_goals status#stack in if goals = [] then raise (Proved status) else if depth = flags.maxdepth then raise (Gaveup IntSet.empty) else if List.length goals < 2 then auto_main flags signature cache depth status else debug_print ~depth (lazy ("goals = " ^ String.concat "," (List.map string_of_int goals))); let classes = HExtlib.clusters (deps status) goals in let classes = if top then List.rev classes else classes in debug_print ~depth (lazy (String.concat "\n" (List.map (fun l -> ("cluster:" ^ String.concat "," (List.map string_of_int l))) classes))); let status,b = List.fold_left (fun (status,b) gl -> let status = focus_tac gl status in try debug_print ~depth (lazy ("focusing on" ^ String.concat "," (List.map string_of_int gl))); auto_main flags signature cache depth status; assert false with | Proved(status) -> (NTactics.merge_tac status,true) | Gaveup _ when top -> (NTactics.merge_tac status,b) ) (status,false) classes in if b then raise (Proved status) else raise (Gaveup IntSet.empty) and (* the goals returned upon failure are an unsatisfiable subset of the initial head goals in the stack *) auto_main flags signature (cache:cache) depth status: unit = debug_print ~depth (lazy "entering auto main"); (* ignore(Unix.select [] [] [] 0.01); *) let status = sort_tac (clean_up_tac status) in let goals = head_goals status#stack in match goals with | [] -> raise (Proved status) | orig::_ -> let ng = List.length goals in if ng > flags.maxwidth then (debug_print (lazy "FAIL WIDTH"); raise (Gaveup IntSet.empty)) else let branch = ng>1 in if depth = flags.maxdepth then raise (Gaveup IntSet.empty) else let status = if branch then NTactics.branch_tac status else status in let status, cache = intros ~depth status cache in let g,gctx, gty = current_goal status in let ctx,ty = close status g in let closegty = mk_cic_term ctx ty in let status, gty = apply_subst status gctx gty in debug_print ~depth (lazy("Attacking goal " ^ (string_of_int g) ^" : "^ppterm status gty)); if is_subsumed depth status closegty cache.under_inspection then (debug_print (lazy "SUBSUMED"); raise (Gaveup IntSet.add g IntSet.empty)) else let do_flags = {flags with last = flags.last && (not branch)} in let alternatives, cache = do_something signature do_flags status g depth gty cache in let loop_cache = let under_inspection = add_to_th closegty cache.under_inspection closegty in {cache with under_inspection = under_inspection} in let unsat = List.fold_left (* the underscore information does not need to be returned by do_something *) (fun unsat ((_,t),status) -> let depth',looping_cache = if t=Ast.Ident("__whd",None) then depth,cache else depth+1, loop_cache in debug_print (~depth:depth') (lazy ("Case: " ^ CicNotationPp.pp_term t)); let flags' = {flags with maxwidth = flags.maxwidth - ng +1} in (* sistemare *) let flags' = {flags' with last = flags'.last && (not branch)} in debug_print (lazy ("auto last: " ^ (string_of_bool flags'.last))); try auto_clusters flags' signature loop_cache depth' status; unsat with | Proved status -> debug_print (~depth:depth') (lazy "proved"); if branch then let status = NTactics.merge_tac status in (* old cache, here *) let flags = {flags with maxwidth = flags.maxwidth - 1} in try auto_clusters flags signature cache depth status; assert false with Gaveup f -> debug_print ~depth (lazy ("Unsat1 at depth " ^ (string_of_int depth) ^ ": " ^ (pp_goals status (IntSet.elements f)))); (* TODO: cache failures *) IntSet.union f unsat else raise (Proved status) | Gaveup f -> debug_print (~depth:depth') (lazy ("Unsat2 at depth " ^ (string_of_int depth') ^ ": " ^ (pp_goals status (IntSet.elements f)))); (* TODO: cache local failures *) unsat) IntSet.empty alternatives in raise (Gaveup IntSet.add orig unsat) ;; let int name l def = try int_of_string (List.assoc name l) with Failure _ | Not_found -> def ;; let auto_tac ~params:(_univ,flags) status = let oldstatus = status in let status = (status:> NTacStatus.tac_status) in let goals = head_goals status#stack in let status, facts = mk_th_cache status goals in let unit_eq = index_local_equations status#eq_cache status in let cache = init_cache ~facts ~unit_eq () in (* pp_th status facts; *) (* NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t -> debug_print (lazy( NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^ String.concat "\n " (List.map ( NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[]) (NDiscriminationTree.TermSet.elements t)) ))); *) let depth = int "depth" flags 3 in let size = int "size" flags 10 in let width = int "width" flags 4 (* (3+List.length goals)*) in (* XXX fix sort *) (* let goals = List.map (fun i -> (i,P)) goals in *) let signature = height_of_goals status in let flags = { last = true; maxwidth = width; maxsize = size; maxdepth = depth; timeout = Unix.gettimeofday() +. 3000.; do_types = false; } in let initial_time = Unix.gettimeofday() in app_counter:= 0; let rec up_to x y = if x > y then (print(lazy ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time))); debug_print(lazy ("Applicative nodes:"^string_of_int !app_counter)); raise (Error (lazy "auto gave up", None))) else let _ = debug_print (lazy("\n\nRound "^string_of_int x^"\n")) in let flags = { flags with maxdepth = x } in try auto_clusters (~top:true) flags signature cache 0 status;assert false with | Gaveup _ -> up_to (x+1) y | Proved s -> debug_print (lazy ("proved at depth " ^ string_of_int x)); let stack = match s#stack with | (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest | _ -> assert false in let s = s#set_stack stack in oldstatus#set_status s in let s = up_to depth depth in debug_print(lazy ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time))); debug_print(lazy ("Applicative nodes:"^string_of_int !app_counter)); s ;;