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