helm/software/components/ng_tactics/nnAuto.ml

   1 (*
   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.
   5     ||I||
   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_______________________________________________________________ *)
  11
  12 open Printf
  13
  14 let debug = ref false
  15 let print ?(depth=0) s =
  16   prerr_endline (String.make depth '\t'^Lazy.force s)
  17 let debug_print ?(depth=0) s =
  18   if !debug then print ~depth s else ()
  19
  20 let debug_do f = if !debug then f () else ()
  21
  22 open Continuationals.Stack
  23 open NTacStatus
  24 module Ast = CicNotationPt
  25 let app_counter = ref 0
  26
  27 (* ======================= utility functions ========================= *)
  28 module IntSet = Set.Make(struct type t = int let compare = compare end)
  29
  30 let get_sgoalty status g =
  31  let _,_,metasenv,subst,_ = status#obj in
  32  try
  33    let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
  34    let ty = NCicUntrusted.apply_subst subst ctx ty in
  35    let ctx = NCicUntrusted.apply_subst_context
  36      ~fix_projections:true subst ctx
  37    in
  38      NTacStatus.mk_cic_term ctx ty
  39  with NCicUtils.Meta_not_found _ as exn -> fail ~exn (lazy "get_sgoalty")
  40 ;;
  41
  42 let deps status g =
  43   let gty = get_sgoalty status g in
  44   metas_of_term status gty
  45 ;;
  46
  47 let menv_closure status gl =
  48   let rec closure acc = function
  49     | [] -> acc
  50     | x::l when IntSet.mem x acc -> closure acc l
  51     | x::l -> closure (IntSet.add x acc) (deps status x @ l)
  52   in closure IntSet.empty gl
  53 ;;
  54
  55 (* we call a "fact" an object whose hypothesis occur in the goal
  56    or in types of goal-variables *)
  57 let is_a_fact status ty =
  58   let status, ty, metas = saturate ~delta:0 status ty in
  59   debug_print (lazy ("saturated ty :" ^ (ppterm status ty)));
  60   let g_metas = metas_of_term status ty in
  61   let clos = menv_closure status g_metas in
  62   (* let _,_,metasenv,_,_ = status#obj in *)
  63   let menv =
  64     List.fold_left
  65       (fun acc m ->
  66          let _, m = term_of_cic_term status m (ctx_of m) in
  67          match m with
  68          | NCic.Meta(i,_) -> IntSet.add i acc
  69          | _ -> assert false)
  70       IntSet.empty metas
  71   in IntSet.subset menv clos;;
  72
  73 let is_a_fact_obj s uri =
  74   let obj = NCicEnvironment.get_checked_obj uri in
  75   match obj with
  76     | (_,_,[],[],NCic.Constant(_,_,Some(t),ty,_)) ->
  77         is_a_fact s (mk_cic_term [] ty)
  78 (* aggiungere i costruttori *)
  79     | _ -> false
  80
  81 let is_a_fact_ast status subst metasenv ctx cand =
  82  debug_print ~depth:0
  83    (lazy ("------- checking " ^ CicNotationPp.pp_term cand));
  84  let status, t = disambiguate status ctx ("",0,cand) None in
  85  let status,t = term_of_cic_term status t ctx in
  86  let ty = NCicTypeChecker.typeof subst metasenv ctx t in
  87    is_a_fact status (mk_cic_term ctx ty)
  88
  89 let current_goal status =
  90   let open_goals = head_goals status#stack in
  91   assert (List.length open_goals  = 1);
  92   let open_goal = List.hd open_goals in
  93   let gty = get_goalty status open_goal in
  94   let ctx = ctx_of gty in
  95     open_goal, ctx, gty
  96
  97 let height_of_ref (NReference.Ref (uri, x)) =
  98   match x with
  99   | NReference.Decl
 100   | NReference.Ind _
 101   | NReference.Con _
 102   | NReference.CoFix _ ->
 103       let _,height,_,_,_ = NCicEnvironment.get_checked_obj uri in
 104       height
 105   | NReference.Def h -> h
 106   | NReference.Fix (_,_,h) -> h
 107 ;;
 108
 109 (*************************** height functions ********************************)
 110 let fast_height_of_term t =
 111  let h = ref 0 in
 112  let rec aux =
 113   function
 114      NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l
 115    | NCic.Meta _ -> ()
 116    | NCic.Rel _
 117    | NCic.Sort _ -> ()
 118    | NCic.Implicit _ -> assert false
 119    | NCic.Const nref as t ->
 120 (*
 121                    prerr_endline (NCicPp.ppterm ~metasenv:[] ~subst:[]
 122                    ~context:[] t ^ ":" ^ string_of_int (height_of_ref nref));
 123 *)
 124        h := max !h (height_of_ref nref)
 125    | NCic.Prod (_,t1,t2)
 126    | NCic.Lambda (_,t1,t2) -> aux t1; aux t2
 127    | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
 128    | NCic.Appl l -> List.iter aux l
 129    | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
 130  in
 131   aux t; !h
 132 ;;
 133
 134 let height_of_goal g status =
 135   let ty = get_goalty status g in
 136   let context = ctx_of ty in
 137   let _, ty = term_of_cic_term status ty (ctx_of ty) in
 138   let h = ref (fast_height_of_term ty) in
 139   List.iter
 140     (function
 141        | _, NCic.Decl ty -> h := max !h (fast_height_of_term ty)
 142        | _, NCic.Def (bo,ty) ->
 143            h := max !h (fast_height_of_term ty);
 144            h := max !h (fast_height_of_term bo);
 145     )
 146     context;
 147   !h
 148 ;;
 149
 150 let height_of_goals status =
 151   let open_goals = head_goals status#stack in
 152   assert (List.length open_goals > 0);
 153   let h = ref 1 in
 154   List.iter
 155     (fun open_goal ->
 156        h := max !h (height_of_goal open_goal status))
 157      open_goals;
 158   debug_print (lazy ("altezza sequente: " ^ string_of_int !h));
 159   !h
 160 ;;
 161
 162 (* =============================== paramod =========================== *)
 163 let solve fast status eq_cache goal =
 164   let f =
 165     if fast then NCicParamod.fast_eq_check
 166     else NCicParamod.paramod in
 167   let n,h,metasenv,subst,o = status#obj in
 168   let gname, ctx, gty = List.assoc goal metasenv in
 169   let gty = NCicUntrusted.apply_subst subst ctx gty in
 170   let build_status (pt, _, metasenv, subst) =
 171     try
 172       debug_print (lazy ("refining: "^(NCicPp.ppterm ctx subst metasenv pt)));
 173       let stamp = Unix.gettimeofday () in
 174       let metasenv, subst, pt, pty =
 175         (* NCicRefiner.typeof status
 176           (* (status#set_coerc_db NCicCoercion.empty_db) *)
 177           metasenv subst ctx pt None in
 178           print (lazy ("refined: "^(NCicPp.ppterm ctx subst metasenv pt)));
 179           debug_print (lazy ("synt: "^(NCicPp.ppterm ctx subst metasenv pty)));
 180           let metasenv, subst =
 181             NCicUnification.unify status metasenv subst ctx gty pty *)
 182         NCicRefiner.typeof
 183           (status#set_coerc_db NCicCoercion.empty_db)
 184           metasenv subst ctx pt (Some gty)
 185         in
 186           debug_print (lazy (Printf.sprintf "Refined in %fs"
 187                      (Unix.gettimeofday() -. stamp)));
 188           let status = status#set_obj (n,h,metasenv,subst,o) in
 189           let metasenv = List.filter (fun j,_ -> j <> goal) metasenv in
 190           let subst = (goal,(gname,ctx,pt,pty)) :: subst in
 191             Some (status#set_obj (n,h,metasenv,subst,o))
 192     with
 193         NCicRefiner.RefineFailure msg
 194       | NCicRefiner.Uncertain msg ->
 195           debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^
 196                         snd (Lazy.force msg))); None
 197       | NCicRefiner.AssertFailure msg ->
 198           debug_print (lazy ("WARNING: refining in fast_eq_check failed" ^
 199                         Lazy.force msg)); None
 200       | _ -> None
 201     in
 202     HExtlib.filter_map build_status
 203       (f status metasenv subst ctx eq_cache (NCic.Rel ~-1,gty))
 204 ;;
 205
 206 let fast_eq_check eq_cache status goal =
 207   match solve true status eq_cache goal with
 208   | [] -> raise (Error (lazy "no proof found",None))
 209   | s::_ -> s
 210 ;;
 211
 212 let dist_fast_eq_check eq_cache s =
 213   NTactics.distribute_tac (fast_eq_check eq_cache) s
 214 ;;
 215
 216 let auto_eq_check eq_cache status =
 217   try
 218     let s = dist_fast_eq_check eq_cache status in
 219       [s]
 220   with
 221     | Error _ -> []
 222 ;;
 223
 224 (* warning: ctx is supposed to be already instantiated w.r.t subst *)
 225 let index_local_equations eq_cache status =
 226   debug_print (lazy "indexing equations");
 227   let open_goals = head_goals status#stack in
 228   let open_goal = List.hd open_goals in
 229   let ngty = get_goalty status open_goal in
 230   let ctx = ctx_of ngty in
 231   let c = ref 0 in
 232   List.fold_left
 233     (fun eq_cache _ ->
 234        c:= !c+1;
 235        let t = NCic.Rel !c in
 236          try
 237            let ty = NCicTypeChecker.typeof [] [] ctx t in
 238            if is_a_fact status (mk_cic_term ctx ty) then
 239              (debug_print(lazy("eq indexing " ^ (NCicPp.ppterm ctx [] [] ty)));
 240               NCicParamod.forward_infer_step eq_cache t ty)
 241            else
 242              (debug_print (lazy ("not a fact: " ^ (NCicPp.ppterm ctx [] [] ty)));
 243               eq_cache)
 244          with
 245            | NCicTypeChecker.TypeCheckerFailure _
 246            | NCicTypeChecker.AssertFailure _ -> eq_cache)
 247     eq_cache ctx
 248 ;;
 249
 250 let fast_eq_check_tac ~params s =
 251   let unit_eq = index_local_equations s#eq_cache s in
 252   dist_fast_eq_check unit_eq s
 253 ;;
 254
 255 let paramod eq_cache status goal =
 256   match solve false status eq_cache goal with
 257   | [] -> raise (Error (lazy "no proof found",None))
 258   | s::_ -> s
 259 ;;
 260
 261 let paramod_tac ~params s =
 262   let unit_eq = index_local_equations s#eq_cache s in
 263   NTactics.distribute_tac (paramod unit_eq) s
 264 ;;
 265
 266 (*
 267 let fast_eq_check_tac_all  ~params eq_cache status =
 268   let g,_,_ = current_goal status in
 269   let allstates = fast_eq_check_all status eq_cache g in
 270   let pseudo_low_tac s _ _ = s in
 271   let pseudo_low_tactics =
 272     List.map pseudo_low_tac allstates
 273   in
 274     List.map (fun f -> NTactics.distribute_tac f status) pseudo_low_tactics
 275 ;;
 276 *)
 277
 278 (*
 279 let demod status eq_cache goal =
 280   let n,h,metasenv,subst,o = status#obj in
 281   let gname, ctx, gty = List.assoc goal metasenv in
 282   let gty = NCicUntrusted.apply_subst subst ctx gty in
 283
 284 let demod_tac ~params s =
 285   let unit_eq = index_local_equations s#eq_cache s in
 286   dist_fast_eq_check unit_eq s
 287 *)
 288
 289 (*************** subsumption ****************)
 290
 291 let close_wrt_context =
 292   List.fold_left
 293     (fun ty ctx_entry ->
 294         match ctx_entry with
 295        | name, NCic.Decl t -> NCic.Prod(name,t,ty)
 296        | name, NCic.Def(bo, _) -> NCicSubstitution.subst bo ty)
 297 ;;
 298
 299 let args_for_context ?(k=1) ctx =
 300   let _,args =
 301     List.fold_left
 302       (fun (n,l) ctx_entry ->
 303          match ctx_entry with
 304            | name, NCic.Decl t -> n+1,NCic.Rel(n)::l
 305            | name, NCic.Def(bo, _) -> n+1,l)
 306       (k,[]) ctx in
 307     args
 308
 309 let constant_for_meta ctx ty i =
 310   let name = "cic:/foo"^(string_of_int i)^".con" in
 311   let uri = NUri.uri_of_string name in
 312   let ty = close_wrt_context ty ctx in
 313   (* prerr_endline (NCicPp.ppterm [] [] [] ty); *)
 314   let attr = (`Generated,`Definition,`Local) in
 315   let obj = NCic.Constant([],name,None,ty,attr) in
 316     (* Constant  of relevance * string * term option * term * c_attr *)
 317     (uri,0,[],[],obj)
 318
 319 (* not used *)
 320 let refresh metasenv =
 321   List.fold_left
 322     (fun (metasenv,subst) (i,(iattr,ctx,ty)) ->
 323        let ikind = NCicUntrusted.kind_of_meta iattr in
 324        let metasenv,j,instance,ty =
 325          NCicMetaSubst.mk_meta ~attrs:iattr
 326            metasenv ctx ~with_type:ty ikind in
 327        let s_entry = i,(iattr, ctx, instance, ty) in
 328        let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
 329          metasenv,s_entry::subst)
 330       (metasenv,[]) metasenv
 331
 332 (* close metasenv returns a ground instance of all the metas in the
 333 metasenv, insantiatied with axioms, and the list of these axioms *)
 334 let close_metasenv metasenv subst =
 335   (*
 336   let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
 337   *)
 338   let metasenv = NCicUntrusted.sort_metasenv subst metasenv in
 339     List.fold_left
 340       (fun (subst,objs) (i,(iattr,ctx,ty)) ->
 341          let ty = NCicUntrusted.apply_subst subst ctx ty in
 342          let ctx =
 343            NCicUntrusted.apply_subst_context ~fix_projections:true
 344              subst ctx in
 345          let (uri,_,_,_,obj) as okind =
 346            constant_for_meta ctx ty i in
 347          try
 348            NCicEnvironment.check_and_add_obj okind;
 349            let iref = NReference.reference_of_spec uri NReference.Decl in
 350            let iterm =
 351              let args = args_for_context ctx in
 352                if args = [] then NCic.Const iref
 353                else NCic.Appl(NCic.Const iref::args)
 354            in
 355            (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
 356            let s_entry = i, ([], ctx, iterm, ty)
 357            in s_entry::subst,okind::objs
 358          with _ -> assert false)
 359       (subst,[]) metasenv
 360 ;;
 361
 362 let ground_instances status gl =
 363   let _,_,metasenv,subst,_ = status#obj in
 364   let subset = menv_closure status gl in
 365   let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
 366 (*
 367   let submenv = metasenv in
 368 *)
 369   let subst, objs = close_metasenv submenv subst in
 370   try
 371     List.iter
 372       (fun i ->
 373          let (_, ctx, t, _) = List.assoc i subst in
 374            debug_print (lazy (NCicPp.ppterm ctx [] [] t));
 375            List.iter
 376              (fun (uri,_,_,_,_) as obj ->
 377                 NCicEnvironment.invalidate_item (`Obj (uri, obj)))
 378              objs;
 379            ())
 380       gl
 381   with
 382       Not_found -> assert false
 383   (* (ctx,t) *)
 384 ;;
 385
 386 let replace_meta i args target =
 387   let rec aux k = function
 388     (* TODO: local context *)
 389     | NCic.Meta (j,lc) when i = j ->
 390         (match args with
 391            | [] -> NCic.Rel 1
 392            | _ -> let args =
 393                List.map (NCicSubstitution.subst_meta lc) args in
 394                NCic.Appl(NCic.Rel k::args))
 395     | NCic.Meta (j,lc) as m ->
 396         (match lc with
 397            _,NCic.Irl _ -> m
 398          | n,NCic.Ctx l ->
 399             NCic.Meta
 400              (i,(0,NCic.Ctx
 401                  (List.map (fun t ->
 402                    aux k (NCicSubstitution.lift n t)) l))))
 403     | t -> NCicUtils.map (fun _ k -> k+1) k aux t
 404  in
 405    aux 1 target
 406 ;;
 407
 408 let close_wrt_metasenv subst =
 409   List.fold_left
 410     (fun ty (i,(iattr,ctx,mty)) ->
 411        let mty = NCicUntrusted.apply_subst subst ctx mty in
 412        let ctx =
 413          NCicUntrusted.apply_subst_context ~fix_projections:true
 414            subst ctx in
 415        let cty = close_wrt_context mty ctx in
 416        let name = "foo"^(string_of_int i) in
 417        let ty = NCicSubstitution.lift 1 ty in
 418        let args = args_for_context ~k:1 ctx in
 419          (* prerr_endline (NCicPp.ppterm ctx [] [] iterm); *)
 420        let ty = replace_meta i args ty
 421        in
 422        NCic.Prod(name,cty,ty))
 423 ;;
 424
 425 let close status g =
 426   let _,_,metasenv,subst,_ = status#obj in
 427   let subset = menv_closure status [g] in
 428   let subset = IntSet.remove g subset in
 429   let elems = IntSet.elements subset in
 430   let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
 431   let ty = NCicUntrusted.apply_subst subst ctx ty in
 432   debug_print (lazy ("metas in " ^ (NCicPp.ppterm ctx [] metasenv ty)));
 433   debug_print (lazy (String.concat ", " (List.map string_of_int elems)));
 434   let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
 435   let submenv = List.rev (NCicUntrusted.sort_metasenv subst submenv) in
 436 (*
 437     let submenv = metasenv in
 438 *)
 439   let ty = close_wrt_metasenv subst ty submenv in
 440     debug_print (lazy (NCicPp.ppterm ctx [] [] ty));
 441     ctx,ty
 442 ;;
 443
 444 (****************** smart application ********************)
 445
 446 let saturate_to_ref metasenv subst ctx nref ty =
 447   let height = height_of_ref nref in
 448   let rec aux metasenv ty args =
 449     let ty,metasenv,moreargs =
 450       NCicMetaSubst.saturate ~delta:height metasenv subst ctx ty 0 in
 451     match ty with
 452       | NCic.Const(NReference.Ref (_,NReference.Def _) as nre)
 453           when nre<>nref ->
 454           let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
 455             aux metasenv ty (args@moreargs)
 456       | NCic.Appl(NCic.Const(NReference.Ref (_,NReference.Def _) as nre)::tl)
 457           when nre<>nref ->
 458           let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def nre in
 459             aux metasenv (NCic.Appl(bo::tl)) (args@moreargs)
 460     | _ -> ty,metasenv,(args@moreargs)
 461   in
 462     aux metasenv ty []
 463
 464 let smart_apply t unit_eq status g =
 465   let n,h,metasenv,subst,o = status#obj in
 466   let gname, ctx, gty = List.assoc g metasenv in
 467   (* let ggty = mk_cic_term context gty in *)
 468   let status, t = disambiguate status ctx t None in
 469   let status,t = term_of_cic_term status t ctx in
 470   let ty = NCicTypeChecker.typeof subst metasenv ctx t in
 471   let ty,metasenv,args =
 472     match gty with
 473       | NCic.Const(nref)
 474       | NCic.Appl(NCic.Const(nref)::_) ->
 475           saturate_to_ref metasenv subst ctx nref ty
 476       | _ ->
 477           NCicMetaSubst.saturate metasenv subst ctx ty 0 in
 478   let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in
 479   let status = status#set_obj (n,h,metasenv,subst,o) in
 480   let pterm = if args=[] then t else NCic.Appl(t::args) in
 481   debug_print(lazy("pterm " ^ (NCicPp.ppterm ctx [] [] pterm)));
 482   debug_print(lazy("pty " ^ (NCicPp.ppterm ctx [] [] ty)));
 483   let eq_coerc =
 484     let uri =
 485       NUri.uri_of_string "cic:/matita/ng/Plogic/equality/eq_coerc.con" in
 486     let ref = NReference.reference_of_spec uri (NReference.Def(2)) in
 487       NCic.Const ref
 488   in
 489   let smart =
 490     NCic.Appl[eq_coerc;ty;NCic.Implicit `Type;pterm;inst] in
 491   let smart = mk_cic_term ctx smart in
 492     try
 493       let status = instantiate status g smart in
 494       let _,_,metasenv,subst,_ = status#obj in
 495       let _,ctx,jty = List.assoc j metasenv in
 496       let jty = NCicUntrusted.apply_subst subst ctx jty in
 497         debug_print(lazy("goal " ^ (NCicPp.ppterm ctx [] [] jty)));
 498         fast_eq_check unit_eq status j
 499     with
 500       | Error _ as e -> debug_print (lazy "error"); raise e
 501
 502 let smart_apply_tac t s =
 503   let unit_eq = index_local_equations s#eq_cache s in
 504   NTactics.distribute_tac (smart_apply t unit_eq) s
 505
 506 let smart_apply_auto t eq_cache =
 507   NTactics.distribute_tac (smart_apply t eq_cache)
 508
 509
 510 (****************** types **************)
 511
 512
 513 type th_cache = (NCic.context * InvRelDiscriminationTree.t) list
 514
 515 let keys_of_term status t =
 516   let status, orig_ty = typeof status (ctx_of t) t in
 517   let _, ty, _ = saturate ~delta:max_int status orig_ty in
 518   let keys = [ty] in
 519   let keys =
 520     let _, ty = term_of_cic_term status ty (ctx_of ty) in
 521     match ty with
 522     | NCic.Const (NReference.Ref (_,(NReference.Def h | NReference.Fix (_,_,h))))
 523     | NCic.Appl (NCic.Const(NReference.Ref(_,(NReference.Def h | NReference.Fix (_,_,h))))::_)
 524        when h > 0 ->
 525          let _,ty,_= saturate status ~delta:(h-1) orig_ty in
 526          ty::keys
 527     | _ -> keys
 528   in
 529   status, keys
 530 ;;
 531
 532 let mk_th_cache status gl =
 533   List.fold_left
 534     (fun (status, acc) g ->
 535        let gty = get_goalty status g in
 536        let ctx = ctx_of gty in
 537        debug_print(lazy("th cache for: "^ppterm status gty));
 538        debug_print(lazy("th cache in: "^ppcontext status ctx));
 539        if List.mem_assq ctx acc then status, acc else
 540          let idx = InvRelDiscriminationTree.empty in
 541          let status,_,idx =
 542            List.fold_left
 543              (fun (status, i, idx) _ ->
 544                 let t = mk_cic_term ctx (NCic.Rel i) in
 545                 let status, keys = keys_of_term status t in
 546                 debug_print(lazy("indexing: "^ppterm status t ^ ": " ^ string_of_int (List.length keys)));
 547                 let idx =
 548                   List.fold_left (fun idx k ->
 549                     InvRelDiscriminationTree.index idx k t) idx keys
 550                 in
 551                 status, i+1, idx)
 552              (status, 1, idx) ctx
 553           in
 554          status, (ctx, idx) :: acc)
 555     (status,[]) gl
 556 ;;
 557
 558 let add_to_th t c ty =
 559   let key_c = ctx_of t in
 560   if not (List.mem_assq key_c c) then
 561       (key_c ,InvRelDiscriminationTree.index
 562                InvRelDiscriminationTree.empty ty t ) :: c
 563   else
 564     let rec replace = function
 565       | [] -> []
 566       | (x, idx) :: tl when x == key_c ->
 567           (x, InvRelDiscriminationTree.index idx ty t) :: tl
 568       | x :: tl -> x :: replace tl
 569     in
 570       replace c
 571 ;;
 572
 573 let rm_from_th t c ty =
 574   let key_c = ctx_of t in
 575   if not (List.mem_assq key_c c) then assert false
 576   else
 577     let rec replace = function
 578       | [] -> []
 579       | (x, idx) :: tl when x == key_c ->
 580           (x, InvRelDiscriminationTree.remove_index idx ty t) :: tl
 581       | x :: tl -> x :: replace tl
 582     in
 583       replace c
 584 ;;
 585
 586 let pp_idx status idx =
 587    InvRelDiscriminationTree.iter idx
 588       (fun k set ->
 589          debug_print(lazy("K: " ^ NCicInverseRelIndexable.string_of_path k));
 590          Ncic_termSet.iter
 591            (fun t -> debug_print(lazy("\t"^ppterm status t)))
 592            set)
 593 ;;
 594
 595 let pp_th status =
 596   List.iter
 597     (fun ctx, idx ->
 598        debug_print(lazy( "-----------------------------------------------"));
 599        debug_print(lazy( (NCicPp.ppcontext ~metasenv:[] ~subst:[] ctx)));
 600        debug_print(lazy( "||====>  "));
 601        pp_idx status idx)
 602 ;;
 603
 604 let search_in_th gty th =
 605   let c = ctx_of gty in
 606   let rec aux acc = function
 607    | [] -> (* Ncic_termSet.elements *) acc
 608    | (_::tl) as k ->
 609        try
 610          let idx = List.assq k th in
 611          let acc = Ncic_termSet.union acc
 612            (InvRelDiscriminationTree.retrieve_unifiables idx gty)
 613          in
 614          aux acc tl
 615        with Not_found -> aux acc tl
 616   in
 617     aux Ncic_termSet.empty c
 618 ;;
 619
 620 type flags = {
 621         do_types : bool; (* solve goals in Type *)
 622         last : bool; (* last goal: take first solution only  *)
 623         maxwidth : int;
 624         maxsize  : int;
 625         maxdepth : int;
 626         timeout  : float;
 627 }
 628
 629 type cache =
 630     {facts : th_cache; (* positive results *)
 631      under_inspection : cic_term list * th_cache; (* to prune looping *)
 632      unit_eq : NCicParamod.state
 633     }
 634
 635 type sort = T | P
 636 type goal = int * sort (* goal, depth, sort *)
 637 type fail = goal * cic_term
 638 type candidate = int * Ast.term (* unique candidate number, candidate *)
 639
 640 exception Gaveup of IntSet.t (* a sublist of unprovable conjunctive
 641                                 atoms of the input goals *)
 642 exception Proved of NTacStatus.tac_status
 643
 644 (* let close_failures _ c = c;; *)
 645 (* let prunable _ _ _ = false;; *)
 646 (* let cache_examine cache gty = `Notfound;; *)
 647 (* let put_in_subst s _ _ _  = s;; *)
 648 (* let add_to_cache_and_del_from_orlist_if_green_cut _ _ c _ _ o f _ = c, o, f, false ;; *)
 649 (* let cache_add_underinspection c _ _ = c;; *)
 650
 651 let init_cache ?(facts=[]) ?(under_inspection=[],[])
 652     ?(unit_eq=NCicParamod.empty_state) _ =
 653     {facts = facts;
 654      under_inspection = under_inspection;
 655      unit_eq = unit_eq
 656     }
 657
 658 let only signature _context candidate =
 659         (* TASSI: nel trie ci mettiamo solo il body, non il ty *)
 660   let candidate_ty =
 661    NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate
 662   in
 663   let height = fast_height_of_term candidate_ty in
 664   let rc = signature >= height in
 665   if rc = false then
 666     debug_print (lazy ("Filtro: " ^ NCicPp.ppterm ~context:[] ~subst:[]
 667           ~metasenv:[] candidate ^ ": " ^ string_of_int height))
 668   else
 669     debug_print (lazy ("Tengo: " ^ NCicPp.ppterm ~context:[] ~subst:[]
 670           ~metasenv:[] candidate ^ ": " ^ string_of_int height));
 671
 672   rc
 673 ;;
 674
 675 let candidate_no = ref 0;;
 676
 677 let openg_no status = List.length (head_goals status#stack)
 678
 679 let sort_new_elems l =
 680   List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l
 681
 682 let try_candidate ?(smart=0) flags depth status eq_cache t =
 683  try
 684   debug_print ~depth (lazy ("try " ^ CicNotationPp.pp_term t));
 685   let status =
 686     if smart= 0 then NTactics.apply_tac ("",0,t) status
 687     else if smart = 1 then smart_apply_auto ("",0,t) eq_cache status
 688     else (* smart = 2: both *)
 689       try NTactics.apply_tac ("",0,t) status
 690       with Error _ ->
 691         smart_apply_auto ("",0,t) eq_cache status in
 692   let og_no = openg_no status in
 693     if (* og_no > flags.maxwidth || *)
 694       ((depth + 1) = flags.maxdepth && og_no <> 0) then
 695         (debug_print ~depth (lazy "pruned immediately"); None)
 696    else
 697      (incr candidate_no;
 698       Some ((!candidate_no,t),status))
 699  with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
 700 ;;
 701
 702 let sort_of metasenv ctx t =
 703   let ty = NCicTypeChecker.typeof [] metasenv ctx t in
 704     NCicTypeChecker.typeof [] metasenv ctx ty
 705 ;;
 706
 707 let type0= NUri.uri_of_string ("cic:/matita/pts/Type0.univ")
 708 ;;
 709
 710 let perforate_small metasenv context t =
 711   let rec aux = function
 712     | NCic.Appl (hd::tl) ->
 713         let map t =
 714           let s = sort_of metasenv context t in
 715             match s with
 716               | NCic.Sort(NCic.Type [`Type,u])
 717                   when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0))
 718               | _ -> aux t
 719         in
 720           NCic.Appl (hd::List.map map tl)
 721     | t -> t
 722   in
 723     aux t
 724 ;;
 725
 726 let get_candidates ?(smart=true) status cache signature gty =
 727   let universe = status#auto_cache in
 728   let _,_,metasenv,subst,_ = status#obj in
 729   let context = ctx_of gty in
 730   let t_ast t =
 731      let _status, t = term_of_cic_term status t context
 732      in Ast.NCic t in
 733   let c_ast = function
 734     | NCic.Const r -> Ast.NRef r | _ -> assert false in
 735   let _, raw_gty = term_of_cic_term status gty context in
 736 (*  let raw_gty = NCicUntrusted.apply_subst subst context raw_gty in *)
 737   let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables
 738         universe raw_gty in
 739   let local_cands = search_in_th gty cache in
 740   debug_print (lazy ("candidates for" ^ NTacStatus.ppterm status gty));
 741   debug_print (lazy ("local cands = " ^ (string_of_int (List.length (Ncic_termSet.elements local_cands)))));
 742   let together global local =
 743     List.map c_ast
 744       (List.filter (only signature context)
 745         (NDiscriminationTree.TermSet.elements global)) @
 746       List.map t_ast (Ncic_termSet.elements local) in
 747   let candidates = together cands local_cands in
 748   let smart_candidates =
 749     if smart then
 750       match raw_gty with
 751         | NCic.Appl _ ->
 752             let weak_gty = perforate_small metasenv context raw_gty in
 753               (*
 754               NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
 755                            (List.length tl)) in *)
 756             let more_cands =
 757               NDiscriminationTree.DiscriminationTree.retrieve_unifiables
 758                 universe weak_gty in
 759             let smart_cands =
 760               NDiscriminationTree.TermSet.diff more_cands cands in
 761              let cic_weak_gty = mk_cic_term context weak_gty in
 762             let more_local_cands = search_in_th cic_weak_gty cache in
 763             let smart_local_cands =
 764               Ncic_termSet.diff more_local_cands local_cands in
 765               together smart_cands smart_local_cands
 766         | _ -> []
 767     else []
 768   in
 769     candidates, smart_candidates
 770 ;;
 771
 772 let applicative_case depth signature status flags gty (cache:cache) =
 773   app_counter:= !app_counter+1;
 774   let _,_,metasenv,subst,_ = status#obj in
 775   let context = ctx_of gty in
 776   let tcache = cache.facts in
 777   let is_prod, is_eq =
 778     let status, t = term_of_cic_term status gty context  in
 779     let t = NCicReduction.whd subst context t in
 780       match t with
 781         | NCic.Prod _ -> true, false
 782         | _ -> false, NCicParamod.is_equation metasenv subst context t
 783   in
 784   debug_print(lazy (string_of_bool is_eq));
 785   let candidates, smart_candidates =
 786     get_candidates ~smart:(not is_eq) status tcache signature gty in
 787   debug_print ~depth
 788     (lazy ("candidates: " ^ string_of_int (List.length candidates)));
 789   debug_print ~depth
 790     (lazy ("smart candidates: " ^
 791              string_of_int (List.length smart_candidates)));
 792  (*
 793   let sm = 0 in
 794   let smart_candidates = [] in *)
 795   let sm = if is_eq then 0 else 2 in
 796   let maxd = ((depth + 1) = flags.maxdepth) in
 797   let only_one = flags.last && maxd in
 798   debug_print (lazy ("only_one: " ^ (string_of_bool only_one)));
 799   debug_print (lazy ("maxd: " ^ (string_of_bool maxd)));
 800   let elems =
 801     List.fold_left
 802       (fun elems cand ->
 803          if (only_one && (elems <> [])) then elems
 804          else
 805            if (maxd && not(is_prod) &
 806                  not(is_a_fact_ast status subst metasenv context cand))
 807            then (debug_print (lazy "pruned: not a fact"); elems)
 808          else
 809            match try_candidate (~smart:sm)
 810              flags depth status cache.unit_eq cand with
 811                | None -> elems
 812                | Some x -> x::elems)
 813       [] candidates
 814   in
 815   let more_elems =
 816     if only_one && elems <> [] then elems
 817     else
 818       List.fold_left
 819         (fun elems cand ->
 820          if (only_one && (elems <> [])) then elems
 821          else
 822            if (maxd && not(is_prod) &&
 823                  not(is_a_fact_ast status subst metasenv context cand))
 824            then (debug_print (lazy "pruned: not a fact"); elems)
 825          else
 826            match try_candidate (~smart:1)
 827              flags depth status cache.unit_eq cand with
 828                | None -> elems
 829                | Some x -> x::elems)
 830         [] smart_candidates
 831   in
 832   elems@more_elems
 833 ;;
 834
 835 exception Found
 836 ;;
 837
 838 (* gty is supposed to be meta-closed *)
 839 let is_subsumed depth status gty cache =
 840   if cache=[] then false else (
 841   debug_print ~depth (lazy("Subsuming " ^ (ppterm status gty)));
 842   let n,h,metasenv,subst,obj = status#obj in
 843   let ctx = ctx_of gty in
 844   let _ , target = term_of_cic_term status gty ctx in
 845   let target = NCicSubstitution.lift 1 target in
 846   (* candidates must only be searched w.r.t the given context *)
 847   let candidates =
 848     try
 849     let idx = List.assq ctx cache in
 850       Ncic_termSet.elements
 851         (InvRelDiscriminationTree.retrieve_generalizations idx gty)
 852     with Not_found -> []
 853   in
 854   debug_print ~depth
 855     (lazy ("failure candidates: " ^ string_of_int (List.length candidates)));
 856     try
 857       List.iter
 858         (fun t ->
 859            let _ , source = term_of_cic_term status t ctx in
 860            let implication =
 861              NCic.Prod("foo",source,target) in
 862            let metasenv,j,_,_ =
 863              NCicMetaSubst.mk_meta
 864                metasenv ctx ~with_type:implication `IsType in
 865            let status = status#set_obj (n,h,metasenv,subst,obj) in
 866            let status = status#set_stack [([1,Open j],[],[],`NoTag)] in
 867            try
 868              let status = NTactics.intro_tac "foo" status in
 869              let status =
 870                NTactics.apply_tac ("",0,Ast.NCic (NCic.Rel 1)) status
 871              in
 872                if (head_goals status#stack = []) then raise Found
 873                else ()
 874            with
 875              | Error _ -> ())
 876         candidates;false
 877     with Found -> debug_print ~depth (lazy "success");true)
 878 ;;
 879
 880 let rec guess_name name ctx =
 881   if name = "_" then guess_name "auto" ctx else
 882   if not (List.mem_assoc name ctx) then name else
 883   guess_name (name^"'") ctx
 884 ;;
 885
 886 let is_prod status =
 887   let _, ctx, gty = current_goal status in
 888   let _, raw_gty = term_of_cic_term status gty ctx in
 889   match raw_gty with
 890     | NCic.Prod (name,_,_) -> Some (guess_name name ctx)
 891     | _ -> None
 892
 893 let intro ~depth status facts name =
 894   let status = NTactics.intro_tac name status in
 895   let _, ctx, ngty = current_goal status in
 896   let t = mk_cic_term ctx (NCic.Rel 1) in
 897   let status, keys = keys_of_term status t in
 898   let facts = List.fold_left (add_to_th t) facts keys in
 899     debug_print ~depth (lazy ("intro: "^ name));
 900   (* unprovability is not stable w.r.t introduction *)
 901   status, facts
 902 ;;
 903
 904 let rec intros_facts ~depth status facts =
 905   match is_prod status with
 906     | Some(name) ->
 907         let status,facts =
 908           intro ~depth status facts name
 909         in intros_facts ~depth status facts
 910     | _ -> status, facts
 911 ;;
 912
 913 let rec intros ~depth status (cache:cache) =
 914     match is_prod status with
 915       | Some _ ->
 916           let status,facts =
 917             intros_facts ~depth status cache.facts
 918           in
 919             (* we reindex the equation from scratch *)
 920           let unit_eq =
 921             index_local_equations status#eq_cache status in
 922           status, init_cache ~facts ~unit_eq ()
 923       | _ -> status, cache
 924 ;;
 925
 926 let reduce ~depth status g =
 927   let n,h,metasenv,subst,o = status#obj in
 928   let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in
 929   let ty = NCicUntrusted.apply_subst subst ctx ty in
 930   let ty' = NCicReduction.whd ~subst ctx ty in
 931   if ty = ty' then []
 932   else
 933     (debug_print ~depth
 934       (lazy ("reduced to: "^ NCicPp.ppterm ctx subst metasenv ty'));
 935     let metasenv =
 936       (g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv)
 937     in
 938     let status = status#set_obj (n,h,metasenv,subst,o) in
 939     (* we merge to gain a depth level; the previous goal level should
 940        be empty *)
 941     let status = NTactics.merge_tac status in
 942     incr candidate_no;
 943     [(!candidate_no,Ast.Ident("__whd",None)),status])
 944 ;;
 945
 946 let do_something signature flags status g depth gty cache =
 947   (* whd *)
 948   let l = reduce ~depth status g in
 949   (* if l <> [] then l,cache else *)
 950   (* backward aplications *)
 951   let l1 =
 952     List.map
 953       (fun s ->
 954          incr candidate_no;
 955          ((!candidate_no,Ast.Ident("__paramod",None)),s))
 956       (auto_eq_check cache.unit_eq status)
 957   in
 958   let l2 =
 959     if ((l1 <> []) && flags.last) then [] else
 960     applicative_case depth signature status flags gty cache
 961   (* fast paramodulation *)
 962   in
 963   (* states in l1 have have an empty set of subgoals: no point to sort them *)
 964   debug_print ~depth
 965     (lazy ("alternatives = " ^ (string_of_int (List.length (l1@l@l2)))));
 966     l1 @ (sort_new_elems (l @ l2)), cache
 967 ;;
 968
 969 let pp_goal = function
 970   | (_,Continuationals.Stack.Open i)
 971   | (_,Continuationals.Stack.Closed i) -> string_of_int i
 972 ;;
 973
 974 let pp_goals status l =
 975   String.concat ", "
 976     (List.map
 977        (fun i ->
 978           let gty = get_goalty status i in
 979             NTacStatus.ppterm status gty)
 980        l)
 981 ;;
 982
 983 module M =
 984   struct
 985     type t = int
 986     let compare = Pervasives.compare
 987   end
 988 ;;
 989
 990 module MS = HTopoSort.Make(M)
 991 ;;
 992
 993 let sort_tac status =
 994   let gstatus =
 995     match status#stack with
 996     | [] -> assert false
 997     | (goals, t, k, tag) :: s ->
 998         let g = head_goals status#stack in
 999         let sortedg =
1000           (List.rev (MS.topological_sort g (deps status))) in
1001           debug_print (lazy ("old g = " ^
1002             String.concat "," (List.map string_of_int g)));
1003           debug_print (lazy ("sorted goals = " ^
1004             String.concat "," (List.map string_of_int sortedg)));
1005           let is_it i = function
1006             | (_,Continuationals.Stack.Open j )
1007             | (_,Continuationals.Stack.Closed j ) -> i = j
1008           in
1009           let sorted_goals =
1010             List.map (fun i -> List.find (is_it i) goals) sortedg
1011           in
1012             (sorted_goals, t, k, tag) :: s
1013   in
1014    status#set_stack gstatus
1015 ;;
1016
1017 let clean_up_tac status =
1018   let gstatus =
1019     match status#stack with
1020     | [] -> assert false
1021     | (g, t, k, tag) :: s ->
1022         let is_open = function
1023           | (_,Continuationals.Stack.Open _) -> true
1024           | (_,Continuationals.Stack.Closed _) -> false
1025         in
1026         let g' = List.filter is_open g in
1027           (g', t, k, tag) :: s
1028   in
1029    status#set_stack gstatus
1030 ;;
1031
1032 let focus_tac focus status =
1033   let gstatus =
1034     match status#stack with
1035     | [] -> assert false
1036     | (g, t, k, tag) :: s ->
1037         let in_focus = function
1038           | (_,Continuationals.Stack.Open i)
1039           | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1040         in
1041         let focus,others = List.partition in_focus g
1042         in
1043           (* we need to mark it as a BranchTag, otherwise cannot merge later *)
1044           (focus,[],[],`BranchTag) :: (others, t, k, tag) :: s
1045   in
1046    status#set_stack gstatus
1047 ;;
1048
1049 let deep_focus_tac level focus status =
1050   let in_focus = function
1051     | (_,Continuationals.Stack.Open i)
1052     | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1053   in
1054   let rec slice level gs =
1055     if level = 0 then [],[],gs else
1056       match gs with
1057         | [] -> assert false
1058         | (g, t, k, tag) :: s ->
1059             let f,o,gs = slice (level-1) s in
1060             let f1,o1 = List.partition in_focus g
1061             in
1062             (f1,[],[],`BranchTag)::f, (o1, t, k, tag)::o, gs
1063   in
1064   let gstatus =
1065     let f,o,s = slice level status#stack in f@o@s
1066   in
1067    status#set_stack gstatus
1068 ;;
1069
1070 let open_goals level status =
1071   let rec aux level gs =
1072     if level = 0 then []
1073     else match gs with
1074       | [] -> assert false
1075       | (g, _, _, _) :: s ->
1076           let is_open = function
1077            | (_,Continuationals.Stack.Open i) -> Some i
1078            | (_,Continuationals.Stack.Closed _) -> None
1079           in
1080             HExtlib.filter_map is_open g @ aux (level-1) s
1081   in
1082   aux level status#stack
1083 ;;
1084
1085 let rec auto_clusters ?(top=false)
1086     flags signature cache depth status : unit =
1087   debug_print ~depth (lazy ("entering auto clusters at depth " ^
1088                            (string_of_int depth)));
1089   (* ignore(Unix.select [] [] [] 0.01); *)
1090   let status = clean_up_tac status in
1091   let goals = head_goals status#stack in
1092   if goals = [] then
1093     if depth = 0 then raise (Proved status)
1094     else
1095       let status = NTactics.merge_tac status in
1096         auto_clusters flags signature (cache:cache) (depth-1) status
1097   else if List.length goals < 2 then
1098     auto_main flags signature cache depth status
1099   else
1100     let all_goals = open_goals (depth+1) status in
1101     debug_print ~depth (lazy ("goals = " ^
1102       String.concat "," (List.map string_of_int all_goals)));
1103     let classes = HExtlib.clusters (deps status) all_goals in
1104     List.iter
1105         (fun gl ->
1106            if List.length gl > flags.maxwidth then
1107              (debug_print (lazy "FAIL GLOBAL WIDTH");
1108               raise (Gaveup IntSet.empty))
1109            else ()) classes;
1110     if List.length classes = 1 then
1111       let flags =
1112         {flags with last = (List.length all_goals = 1)} in
1113         (* no need to cluster *)
1114       auto_main flags signature cache depth status
1115     else
1116     let classes = if top then List.rev classes else classes in
1117       debug_print ~depth
1118         (lazy
1119            (String.concat "\n"
1120            (List.map
1121               (fun l ->
1122                  ("cluster:" ^ String.concat "," (List.map string_of_int l)))
1123            classes)));
1124       let status,b =
1125         List.fold_left
1126           (fun (status,b) gl ->
1127              let flags =
1128                {flags with last = (List.length gl = 1)} in
1129              let lold = List.length status#stack in
1130               debug_print ~depth (lazy ("stack length = " ^
1131                         (string_of_int lold)));
1132              let fstatus = deep_focus_tac (depth+1) gl status in
1133              try
1134                debug_print ~depth (lazy ("focusing on" ^
1135                               String.concat "," (List.map string_of_int gl)));
1136                auto_main flags signature cache depth fstatus; assert false
1137              with
1138                | Proved(status) ->
1139                    let status = NTactics.merge_tac status in
1140                    let lnew = List.length status#stack in
1141                      assert (lold = lnew);
1142                    (status,true)
1143                | Gaveup _ when top -> (status,b)
1144           )
1145           (status,false) classes
1146       in
1147       let rec final_merge n s =
1148         if n = 0 then s else final_merge (n-1) (NTactics.merge_tac s)
1149       in let status = final_merge depth status
1150       in if b then raise (Proved status) else raise (Gaveup IntSet.empty)
1151
1152 and
1153
1154 (* BRAND NEW VERSION *)
1155 auto_main flags signature (cache:cache) depth status: unit =
1156   debug_print ~depth (lazy "entering auto main");
1157   debug_print ~depth (lazy ("stack length = " ^
1158                         (string_of_int (List.length status#stack))));
1159   (* ignore(Unix.select [] [] [] 0.01); *)
1160   let status = sort_tac (clean_up_tac status) in
1161   let goals = head_goals status#stack in
1162   match goals with
1163     | [] when depth = 0 -> raise (Proved status)
1164     | []  ->
1165         let status = NTactics.merge_tac status in
1166         let cache =
1167           let l,tree = cache.under_inspection in
1168             match l with
1169               | [] -> assert false
1170               | a::tl -> let tree = rm_from_th a tree a in
1171                   {cache with under_inspection = tl,tree}
1172         in
1173           auto_clusters flags signature (cache:cache) (depth-1) status
1174     | orig::_ ->
1175         let ng = List.length goals in
1176         (* moved inside auto_clusters *)
1177         if ng > flags.maxwidth then
1178           (debug_print (lazy "FAIL LOCAL WIDTH"); raise (Gaveup IntSet.empty))
1179         else if depth = flags.maxdepth then raise (Gaveup IntSet.empty)
1180         else
1181         let status = NTactics.branch_tac ~force:true status in
1182         let status, cache = intros ~depth status cache in
1183         let g,gctx, gty = current_goal status in
1184         let ctx,ty = close status g in
1185         let closegty = mk_cic_term ctx ty in
1186         let status, gty = apply_subst status gctx gty in
1187         debug_print ~depth (lazy("Attacking goal " ^ (string_of_int g) ^" : "^ppterm status gty));
1188         if is_subsumed depth status closegty (snd cache.under_inspection) then
1189           (debug_print ~depth (lazy "SUBSUMED");
1190            raise (Gaveup IntSet.add g IntSet.empty))
1191         else
1192         let new_sig = height_of_goal g status in
1193         if new_sig < signature then
1194           (debug_print (lazy ("news = " ^ (string_of_int new_sig)));
1195            debug_print (lazy ("olds = " ^ (string_of_int signature))));
1196         let alternatives, cache =
1197           do_something signature flags status g depth gty cache in
1198         let loop_cache =
1199           let l,tree = cache.under_inspection in
1200           let l,tree = closegty::l, add_to_th closegty tree closegty in
1201           {cache with under_inspection = l,tree} in
1202         List.iter
1203           (fun ((_,t),status) ->
1204              debug_print ~depth
1205                (lazy ("(re)considering goal " ^
1206                        (string_of_int g) ^" : "^ppterm status gty));
1207              debug_print (~depth:depth)
1208                (lazy ("Case: " ^ CicNotationPp.pp_term t));
1209              let depth,cache =
1210                if t=Ast.Ident("__whd",None) then depth, cache
1211                else depth+1,loop_cache in
1212              try
1213                auto_clusters flags signature (cache:cache) depth status
1214              with Gaveup _ ->
1215                debug_print ~depth (lazy "Failed");())
1216           alternatives;
1217         raise (Gaveup IntSet.empty)
1218 ;;
1219
1220 let int name l def =
1221   try int_of_string (List.assoc name l)
1222   with Failure _ | Not_found -> def
1223 ;;
1224
1225 let auto_tac ~params:(_univ,flags) status =
1226   let oldstatus = status in
1227   let status = (status:> NTacStatus.tac_status) in
1228   let goals = head_goals status#stack in
1229   let status, facts = mk_th_cache status goals in
1230   let unit_eq = index_local_equations status#eq_cache status in
1231   let cache = init_cache ~facts ~unit_eq  () in
1232 (*   pp_th status facts; *)
1233 (*
1234   NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
1235     debug_print (lazy(
1236       NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
1237       String.concat "\n    " (List.map (
1238       NCicPp.ppterm ~metasenv:[] ~context:[] ~subst:[])
1239         (NDiscriminationTree.TermSet.elements t))
1240       )));
1241 *)
1242   let depth = int "depth" flags 3 in
1243   let size  = int "size" flags 10 in
1244   let width = int "width" flags 4 (* (3+List.length goals)*) in
1245   (* XXX fix sort *)
1246 (*   let goals = List.map (fun i -> (i,P)) goals in *)
1247   let signature = height_of_goals status in
1248   let flags = {
1249           last = true;
1250           maxwidth = width;
1251           maxsize = size;
1252           maxdepth = depth;
1253           timeout = Unix.gettimeofday() +. 3000.;
1254           do_types = false;
1255   } in
1256   let initial_time = Unix.gettimeofday() in
1257   app_counter:= 0;
1258   let rec up_to x y =
1259     if x > y then
1260       (print(lazy
1261         ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1262        debug_print(lazy
1263         ("Applicative nodes:"^string_of_int !app_counter));
1264        raise (Error (lazy "auto gave up", None)))
1265     else
1266       let _ = debug_print (lazy("\n\nRound "^string_of_int x^"\n")) in
1267       let flags = { flags with maxdepth = x }
1268       in
1269         try auto_clusters (~top:true) flags signature cache 0 status;assert false
1270 (*
1271         try auto_main flags signature cache 0 status;assert false
1272 *)
1273         with
1274           | Gaveup _ -> up_to (x+1) y
1275           | Proved s ->
1276               debug_print (lazy ("proved at depth " ^ string_of_int x));
1277               let stack =
1278                 match s#stack with
1279                   | (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
1280                   | _ -> assert false
1281               in
1282               let s = s#set_stack stack in
1283                 oldstatus#set_status s
1284   in
1285   let s = up_to depth depth in
1286     debug_print(lazy
1287         ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1288     debug_print(lazy
1289         ("Applicative nodes:"^string_of_int !app_counter));
1290     s
1291 ;;
1292