matita/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 (2*depth) ' '^Lazy.force s)
  16 let noprint ?(depth=0) _ = ()
  17 let debug_print = noprint
  18
  19 open Continuationals.Stack
  20 open NTacStatus
  21 module Ast = NotationPt
  22
  23 (* ======================= statistics  ========================= *)
  24
  25 let app_counter = ref 0
  26
  27 module RHT = struct
  28   type t = NReference.reference
  29   let equal = (==)
  30   let compare = Pervasives.compare
  31   let hash = Hashtbl.hash
  32 end;;
  33
  34 module RefHash = Hashtbl.Make(RHT);;
  35
  36 type info = {
  37   nominations : int ref;
  38   uses: int ref;
  39 }
  40
  41 let statistics: info RefHash.t = RefHash.create 503
  42
  43 let incr_nominations tbl item =
  44   try
  45     let v = RefHash.find tbl item in incr v.nominations
  46   with Not_found ->
  47     RefHash.add tbl item {nominations = ref 1; uses = ref 0}
  48
  49 let incr_uses tbl item =
  50   try
  51     let v = RefHash.find tbl item in incr v.uses
  52   with Not_found -> assert false
  53
  54 let toref f tbl t =
  55   match t with
  56     | Ast.NRef n ->
  57         f tbl n
  58     | Ast.NCic _  (* local candidate *)
  59     | _  ->  ()
  60
  61 let is_relevant tbl item =
  62   try
  63     let v = RefHash.find tbl item in
  64       if !(v.nominations) < 60 then true (* not enough info *)
  65       else if !(v.uses) = 0 then false
  66       else true
  67   with Not_found -> true
  68
  69 let print_stat status tbl =
  70   let l = RefHash.fold (fun a v l -> (a,v)::l) tbl [] in
  71   let relevance v = float !(v.uses) /. float !(v.nominations) in
  72   let vcompare (_,v1) (_,v2) =
  73     Pervasives.compare (relevance v1) (relevance v2) in
  74   let l = List.sort vcompare l in
  75   let vstring (a,v)=
  76       NotationPp.pp_term status (Ast.NCic (NCic.Const a)) ^ ": rel = " ^
  77       (string_of_float (relevance v)) ^
  78       "; uses = " ^ (string_of_int !(v.uses)) ^
  79       "; nom = " ^ (string_of_int !(v.nominations)) in
  80   lazy ("\n\nSTATISTICS:\n" ^
  81           String.concat "\n" (List.map vstring l))
  82
  83 (* ======================= utility functions ========================= *)
  84 module IntSet = Set.Make(struct type t = int let compare = compare end)
  85
  86 let get_sgoalty status g =
  87  let _,_,metasenv,subst,_ = status#obj in
  88  try
  89    let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
  90    let ty = NCicUntrusted.apply_subst status subst ctx ty in
  91    let ctx = NCicUntrusted.apply_subst_context status
  92      ~fix_projections:true subst ctx
  93    in
  94      NTacStatus.mk_cic_term ctx ty
  95  with NCicUtils.Meta_not_found _ as exn -> fail ~exn (lazy "get_sgoalty")
  96 ;;
  97
  98 let deps status g =
  99   let gty = get_sgoalty status g in
 100   metas_of_term status gty
 101 ;;
 102
 103 let menv_closure status gl =
 104   let rec closure acc = function
 105     | [] -> acc
 106     | x::l when IntSet.mem x acc -> closure acc l
 107     | x::l -> closure (IntSet.add x acc) (deps status x @ l)
 108   in closure IntSet.empty gl
 109 ;;
 110
 111 (* we call a "fact" an object whose hypothesis occur in the goal
 112    or in types of goal-variables *)
 113 let branch status ty =
 114   let status, ty, metas = saturate ~delta:0 status ty in
 115   noprint (lazy ("saturated ty :" ^ (ppterm status ty)));
 116   let g_metas = metas_of_term status ty in
 117   let clos = menv_closure status g_metas in
 118   (* let _,_,metasenv,_,_ = status#obj in *)
 119   let menv =
 120     List.fold_left
 121       (fun acc m ->
 122          let _, m = term_of_cic_term status m (ctx_of m) in
 123          match m with
 124          | NCic.Meta(i,_) -> IntSet.add i acc
 125          | _ -> assert false)
 126       IntSet.empty metas
 127   in
 128   (* IntSet.subset menv clos *)
 129   IntSet.cardinal(IntSet.diff menv clos)
 130
 131 let is_a_fact status ty = branch status ty = 0
 132
 133 let is_a_fact_obj s uri =
 134   let obj = NCicEnvironment.get_checked_obj s uri in
 135   match obj with
 136     | (_,_,[],[],NCic.Constant(_,_,_,ty,_)) ->
 137         is_a_fact s (mk_cic_term [] ty)
 138 (* aggiungere i costruttori *)
 139     | _ -> false
 140
 141 let is_a_fact_ast status subst metasenv ctx cand =
 142  noprint ~depth:0
 143    (lazy ("checking facts " ^ NotationPp.pp_term status cand));
 144  let status, t = disambiguate status ctx ("",0,cand) None in
 145  let status,t = term_of_cic_term status t ctx in
 146  let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
 147    is_a_fact status (mk_cic_term ctx ty)
 148
 149 let current_goal status =
 150   let open_goals = head_goals status#stack in
 151   assert (List.length open_goals  = 1);
 152   let open_goal = List.hd open_goals in
 153   let gty = get_goalty status open_goal in
 154   let ctx = ctx_of gty in
 155     open_goal, ctx, gty
 156
 157 let height_of_ref status (NReference.Ref (uri, x)) =
 158   match x with
 159   | NReference.Decl
 160   | NReference.Ind _
 161   | NReference.Con _
 162   | NReference.CoFix _ ->
 163       let _,height,_,_,_ = NCicEnvironment.get_checked_obj status uri in
 164       height
 165   | NReference.Def h -> h
 166   | NReference.Fix (_,_,h) -> h
 167 ;;
 168
 169 (*************************** height functions ********************************)
 170 let fast_height_of_term status t =
 171  let h = ref 0 in
 172  let rec aux =
 173   function
 174      NCic.Meta (_,(_,NCic.Ctx l)) -> List.iter aux l
 175    | NCic.Meta _ -> ()
 176    | NCic.Rel _
 177    | NCic.Sort _ -> ()
 178    | NCic.Implicit _ -> assert false
 179    | NCic.Const nref ->
 180 (*
 181                    prerr_endline (status#ppterm ~metasenv:[] ~subst:[]
 182                    ~context:[] t ^ ":" ^ string_of_int (height_of_ref status nref));
 183 *)
 184        h := max !h (height_of_ref status nref)
 185    | NCic.Prod (_,t1,t2)
 186    | NCic.Lambda (_,t1,t2) -> aux t1; aux t2
 187    | NCic.LetIn (_,s,ty,t) -> aux s; aux ty; aux t
 188    | NCic.Appl l -> List.iter aux l
 189    | NCic.Match (_,outty,t,pl) -> aux outty; aux t; List.iter aux pl
 190  in
 191   aux t; !h
 192 ;;
 193
 194 let height_of_goal g status =
 195   let ty = get_goalty status g in
 196   let context = ctx_of ty in
 197   let _, ty = term_of_cic_term status ty (ctx_of ty) in
 198   let h = ref (fast_height_of_term status ty) in
 199   List.iter
 200     (function
 201        | _, NCic.Decl ty -> h := max !h (fast_height_of_term status ty)
 202        | _, NCic.Def (bo,ty) ->
 203            h := max !h (fast_height_of_term status ty);
 204            h := max !h (fast_height_of_term status bo);
 205     )
 206     context;
 207   !h
 208 ;;
 209
 210 let height_of_goals status =
 211   let open_goals = head_goals status#stack in
 212   assert (List.length open_goals > 0);
 213   let h = ref 1 in
 214   List.iter
 215     (fun open_goal ->
 216        h := max !h (height_of_goal open_goal status))
 217      open_goals;
 218   noprint (lazy ("altezza sequente: " ^ string_of_int !h));
 219   !h
 220 ;;
 221
 222 (* =============================== paramod =========================== *)
 223 let solve f status eq_cache goal =
 224 (*
 225   let f =
 226     if fast then NCicParamod.fast_eq_check
 227     else NCicParamod.paramod in
 228 *)
 229   let n,h,metasenv,subst,o = status#obj in
 230   let gname, ctx, gty = List.assoc goal metasenv in
 231   let gty = NCicUntrusted.apply_subst status subst ctx gty in
 232   let build_status (pt, _, metasenv, subst) =
 233     try
 234       noprint (lazy ("refining: "^(status#ppterm ctx subst metasenv pt)));
 235       let stamp = Unix.gettimeofday () in
 236       let metasenv, subst, pt, pty =
 237         (* NCicRefiner.typeof status
 238           (* (status#set_coerc_db NCicCoercion.empty_db) *)
 239           metasenv subst ctx pt None in
 240           debug_print (lazy ("refined: "^(status#ppterm ctx subst metasenv pt)));
 241           noprint (lazy ("synt: "^(status#ppterm ctx subst metasenv pty)));
 242           let metasenv, subst =
 243             NCicUnification.unify status metasenv subst ctx gty pty *)
 244         NCicRefiner.typeof
 245           (status#set_coerc_db NCicCoercion.empty_db)
 246           metasenv subst ctx pt (Some gty)
 247         in
 248           noprint (lazy (Printf.sprintf "Refined in %fs"
 249                      (Unix.gettimeofday() -. stamp)));
 250           let status = status#set_obj (n,h,metasenv,subst,o) in
 251           let metasenv = List.filter (fun j,_ -> j <> goal) metasenv in
 252           let subst = (goal,(gname,ctx,pt,pty)) :: subst in
 253             Some (status#set_obj (n,h,metasenv,subst,o))
 254     with
 255         NCicRefiner.RefineFailure msg
 256       | NCicRefiner.Uncertain msg ->
 257           noprint (lazy ("WARNING U: refining in fast_eq_check failed\n" ^
 258                         snd (Lazy.force msg) ^
 259                         "\n in the environment\n" ^
 260                         status#ppmetasenv subst metasenv)); None
 261       | NCicRefiner.AssertFailure msg ->
 262           noprint (lazy ("WARNING F: refining in fast_eq_check failed" ^
 263                         Lazy.force msg ^
 264                         "\n in the environment\n" ^
 265                         status#ppmetasenv subst metasenv)); None
 266       | _ -> None
 267     in
 268     HExtlib.filter_map build_status
 269       (f status metasenv subst ctx eq_cache (NCic.Rel ~-1,gty))
 270 ;;
 271
 272 let fast_eq_check eq_cache status (goal:int) =
 273   match solve NCicParamod.fast_eq_check status eq_cache goal with
 274   | [] -> raise (Error (lazy "no proof found",None))
 275   | s::_ -> s
 276 ;;
 277
 278 let dist_fast_eq_check eq_cache s =
 279   NTactics.distribute_tac (fast_eq_check eq_cache) s
 280 ;;
 281
 282 let auto_eq_check eq_cache status =
 283   try
 284     let s = dist_fast_eq_check eq_cache status in
 285       [s]
 286   with
 287     | Error _ -> debug_print (lazy ("no paramod proof found"));[]
 288 ;;
 289
 290 let index_local_equations eq_cache status =
 291   noprint (lazy "indexing equations");
 292   let open_goals = head_goals status#stack in
 293   let open_goal = List.hd open_goals in
 294   let ngty = get_goalty status open_goal in
 295   let ctx = apply_subst_context ~fix_projections:true status (ctx_of ngty) in
 296   let c = ref 0 in
 297   List.fold_left
 298     (fun eq_cache _ ->
 299        c:= !c+1;
 300        let t = NCic.Rel !c in
 301          try
 302            let ty = NCicTypeChecker.typeof status [] [] ctx t in
 303            if is_a_fact status (mk_cic_term ctx ty) then
 304              (noprint(lazy("eq indexing " ^ (status#ppterm ctx [] [] ty)));
 305               NCicParamod.forward_infer_step eq_cache t ty)
 306            else
 307              (noprint (lazy ("not a fact: " ^ (status#ppterm ctx [] [] ty)));
 308               eq_cache)
 309          with
 310            | NCicTypeChecker.TypeCheckerFailure _
 311            | NCicTypeChecker.AssertFailure _ -> eq_cache)
 312     eq_cache ctx
 313 ;;
 314
 315 let fast_eq_check_tac ~params s =
 316   let unit_eq = index_local_equations s#eq_cache s in
 317   dist_fast_eq_check unit_eq s
 318 ;;
 319
 320 let paramod eq_cache status goal =
 321   match solve NCicParamod.paramod status eq_cache goal with
 322   | [] -> raise (Error (lazy "no proof found",None))
 323   | s::_ -> s
 324 ;;
 325
 326 let paramod_tac ~params s =
 327   let unit_eq = index_local_equations s#eq_cache s in
 328   NTactics.distribute_tac (paramod unit_eq) s
 329 ;;
 330
 331 let demod eq_cache status goal =
 332   match solve NCicParamod.demod status eq_cache goal with
 333   | [] -> raise (Error (lazy "no progress",None))
 334   | s::_ -> s
 335 ;;
 336
 337 let demod_tac ~params s =
 338   let unit_eq = index_local_equations s#eq_cache s in
 339   NTactics.distribute_tac (demod unit_eq) s
 340 ;;
 341
 342 (*
 343 let fast_eq_check_tac_all  ~params eq_cache status =
 344   let g,_,_ = current_goal status in
 345   let allstates = fast_eq_check_all status eq_cache g in
 346   let pseudo_low_tac s _ _ = s in
 347   let pseudo_low_tactics =
 348     List.map pseudo_low_tac allstates
 349   in
 350     List.map (fun f -> NTactics.distribute_tac f status) pseudo_low_tactics
 351 ;;
 352 *)
 353
 354 (*
 355 let demod status eq_cache goal =
 356   let n,h,metasenv,subst,o = status#obj in
 357   let gname, ctx, gty = List.assoc goal metasenv in
 358   let gty = NCicUntrusted.apply_subst subst ctx gty in
 359
 360 let demod_tac ~params s =
 361   let unit_eq = index_local_equations s#eq_cache s in
 362   dist_fast_eq_check unit_eq s
 363 *)
 364
 365 (*************** subsumption ****************)
 366
 367 let close_wrt_context status =
 368   List.fold_left
 369     (fun ty ctx_entry ->
 370         match ctx_entry with
 371        | name, NCic.Decl t -> NCic.Prod(name,t,ty)
 372        | name, NCic.Def(bo, _) -> NCicSubstitution.subst status bo ty)
 373 ;;
 374
 375 let args_for_context ?(k=1) ctx =
 376   let _,args =
 377     List.fold_left
 378       (fun (n,l) ctx_entry ->
 379          match ctx_entry with
 380            | name, NCic.Decl t -> n+1,NCic.Rel(n)::l
 381            | name, NCic.Def(bo, _) -> n+1,l)
 382       (k,[]) ctx in
 383     args
 384
 385 let constant_for_meta status ctx ty i =
 386   let name = "cic:/foo"^(string_of_int i)^".con" in
 387   let uri = NUri.uri_of_string name in
 388   let ty = close_wrt_context status ty ctx in
 389   (* prerr_endline (status#ppterm [] [] [] ty); *)
 390   let attr = (`Generated,`Definition,`Local) in
 391   let obj = NCic.Constant([],name,None,ty,attr) in
 392     (* Constant  of relevance * string * term option * term * c_attr *)
 393     (uri,0,[],[],obj)
 394
 395 (* not used *)
 396 let refresh metasenv =
 397   List.fold_left
 398     (fun (metasenv,subst) (i,(iattr,ctx,ty)) ->
 399        let ikind = NCicUntrusted.kind_of_meta iattr in
 400        let metasenv,j,instance,ty =
 401          NCicMetaSubst.mk_meta ~attrs:iattr
 402            metasenv ctx ~with_type:ty ikind in
 403        let s_entry = i,(iattr, ctx, instance, ty) in
 404        let metasenv = List.filter (fun x,_ -> i <> x) metasenv in
 405          metasenv,s_entry::subst)
 406       (metasenv,[]) metasenv
 407
 408 (* close metasenv returns a ground instance of all the metas in the
 409 metasenv, insantiatied with axioms, and the list of these axioms *)
 410 let close_metasenv status metasenv subst =
 411   (*
 412   let metasenv = NCicUntrusted.apply_subst_metasenv subst metasenv in
 413   *)
 414   let metasenv = NCicUntrusted.sort_metasenv status subst metasenv in
 415     List.fold_left
 416       (fun (subst,objs) (i,(iattr,ctx,ty)) ->
 417          let ty = NCicUntrusted.apply_subst status subst ctx ty in
 418          let ctx =
 419            NCicUntrusted.apply_subst_context status ~fix_projections:true
 420              subst ctx in
 421          let (uri,_,_,_,obj) as okind =
 422            constant_for_meta status ctx ty i in
 423          try
 424            NCicEnvironment.check_and_add_obj status okind;
 425            let iref = NReference.reference_of_spec uri NReference.Decl in
 426            let iterm =
 427              let args = args_for_context ctx in
 428                if args = [] then NCic.Const iref
 429                else NCic.Appl(NCic.Const iref::args)
 430            in
 431            (* prerr_endline (status#ppterm ctx [] [] iterm); *)
 432            let s_entry = i, ([], ctx, iterm, ty)
 433            in s_entry::subst,okind::objs
 434          with _ -> assert false)
 435       (subst,[]) metasenv
 436 ;;
 437
 438 let ground_instances status gl =
 439   let _,_,metasenv,subst,_ = status#obj in
 440   let subset = menv_closure status gl in
 441   let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
 442 (*
 443   let submenv = metasenv in
 444 *)
 445   let subst, objs = close_metasenv status submenv subst in
 446   try
 447     List.iter
 448       (fun i ->
 449          let (_, ctx, t, _) = List.assoc i subst in
 450            noprint (lazy (status#ppterm ctx [] [] t));
 451            List.iter
 452              (fun (uri,_,_,_,_) as obj ->
 453                 NCicEnvironment.invalidate_item (`Obj (uri, obj)))
 454              objs;
 455            ())
 456       gl
 457   with
 458       Not_found -> assert false
 459   (* (ctx,t) *)
 460 ;;
 461
 462 let replace_meta status i args target =
 463   let rec aux k = function
 464     (* TODO: local context *)
 465     | NCic.Meta (j,lc) when i = j ->
 466         (match args with
 467            | [] -> NCic.Rel 1
 468            | _ -> let args =
 469                List.map (NCicSubstitution.subst_meta status lc) args in
 470                NCic.Appl(NCic.Rel k::args))
 471     | NCic.Meta (j,lc) as m ->
 472         (match lc with
 473            _,NCic.Irl _ -> m
 474          | n,NCic.Ctx l ->
 475             NCic.Meta
 476              (i,(0,NCic.Ctx
 477                  (List.map (fun t ->
 478                    aux k (NCicSubstitution.lift status n t)) l))))
 479     | t -> NCicUtils.map status (fun _ k -> k+1) k aux t
 480  in
 481    aux 1 target
 482 ;;
 483
 484 let close_wrt_metasenv status subst =
 485   List.fold_left
 486     (fun ty (i,(iattr,ctx,mty)) ->
 487        let mty = NCicUntrusted.apply_subst status subst ctx mty in
 488        let ctx =
 489          NCicUntrusted.apply_subst_context status ~fix_projections:true
 490            subst ctx in
 491        let cty = close_wrt_context status mty ctx in
 492        let name = "foo"^(string_of_int i) in
 493        let ty = NCicSubstitution.lift status 1 ty in
 494        let args = args_for_context ~k:1 ctx in
 495          (* prerr_endline (status#ppterm ctx [] [] iterm); *)
 496        let ty = replace_meta status i args ty
 497        in
 498        NCic.Prod(name,cty,ty))
 499 ;;
 500
 501 let close status g =
 502   let _,_,metasenv,subst,_ = status#obj in
 503   let subset = menv_closure status [g] in
 504   let subset = IntSet.remove g subset in
 505   let elems = IntSet.elements subset in
 506   let _, ctx, ty = NCicUtils.lookup_meta g metasenv in
 507   let ty = NCicUntrusted.apply_subst status subst ctx ty in
 508   noprint (lazy ("metas in " ^ (status#ppterm ctx [] metasenv ty)));
 509   noprint (lazy (String.concat ", " (List.map string_of_int elems)));
 510   let submenv = List.filter (fun (x,_) -> IntSet.mem x subset) metasenv in
 511   let submenv = List.rev (NCicUntrusted.sort_metasenv status subst submenv) in
 512 (*
 513     let submenv = metasenv in
 514 *)
 515   let ty = close_wrt_metasenv status subst ty submenv in
 516     noprint (lazy (status#ppterm ctx [] [] ty));
 517     ctx,ty
 518 ;;
 519
 520 (****************** smart application ********************)
 521
 522 let saturate_to_ref status metasenv subst ctx nref ty =
 523   let height = height_of_ref status nref in
 524   let rec aux metasenv ty args =
 525     let ty,metasenv,moreargs =
 526       NCicMetaSubst.saturate status ~delta:height metasenv subst ctx ty 0 in
 527     match ty with
 528       | NCic.Const(NReference.Ref (_,NReference.Def _) as nre)
 529           when nre<>nref ->
 530           let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
 531             aux metasenv bo (args@moreargs)
 532       | NCic.Appl(NCic.Const(NReference.Ref (_,NReference.Def _) as nre)::tl)
 533           when nre<>nref ->
 534           let _, _, bo, _, _, _ = NCicEnvironment.get_checked_def status nre in
 535             aux metasenv (NCic.Appl(bo::tl)) (args@moreargs)
 536     | _ -> ty,metasenv,(args@moreargs)
 537   in
 538     aux metasenv ty []
 539
 540 let smart_apply t unit_eq status g =
 541   let n,h,metasenv,subst,o = status#obj in
 542   let gname, ctx, gty = List.assoc g metasenv in
 543   (* let ggty = mk_cic_term context gty in *)
 544   let status, t = disambiguate status ctx t None in
 545   let status,t = term_of_cic_term status t ctx in
 546   let _,_,metasenv,subst,_ = status#obj in
 547   let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
 548   let ty,metasenv,args =
 549     match gty with
 550       | NCic.Const(nref)
 551       | NCic.Appl(NCic.Const(nref)::_) ->
 552           saturate_to_ref status metasenv subst ctx nref ty
 553       | _ ->
 554           NCicMetaSubst.saturate status metasenv subst ctx ty 0 in
 555   let metasenv,j,inst,_ = NCicMetaSubst.mk_meta metasenv ctx `IsTerm in
 556   let status = status#set_obj (n,h,metasenv,subst,o) in
 557   let pterm = if args=[] then t else
 558     match t with
 559       | NCic.Appl l -> NCic.Appl(l@args)
 560       | _ -> NCic.Appl(t::args)
 561   in
 562   noprint(lazy("pterm " ^ (status#ppterm ctx [] [] pterm)));
 563   noprint(lazy("pty " ^ (status#ppterm ctx [] [] ty)));
 564   let eq_coerc =
 565     let uri =
 566       NUri.uri_of_string "cic:/matita/basics/logic/eq_coerc.con" in
 567     let ref = NReference.reference_of_spec uri (NReference.Def(2)) in
 568       NCic.Const ref
 569   in
 570   let smart =
 571     NCic.Appl[eq_coerc;ty;NCic.Implicit `Type;pterm;inst] in
 572   let smart = mk_cic_term ctx smart in
 573     try
 574       let status = instantiate status g smart in
 575       let _,_,metasenv,subst,_ = status#obj in
 576       let _,ctx,jty = List.assoc j metasenv in
 577       let jty = NCicUntrusted.apply_subst status subst ctx jty in
 578         debug_print(lazy("goal " ^ (status#ppterm ctx [] [] jty)));
 579         let res = fast_eq_check unit_eq status j in
 580         debug_print(lazy("ritorno da fast_eq_check"));
 581         res
 582     with
 583       | NCicEnvironment.ObjectNotFound s as e ->
 584           raise (Error (lazy "eq_coerc non yet defined",Some e))
 585       | Error _ as e -> debug_print (lazy "error"); raise e
 586 ;;
 587
 588 let compare_statuses ~past ~present =
 589  let _,_,past,_,_ = past#obj in
 590  let _,_,present,_,_ = present#obj in
 591  List.map fst (List.filter (fun (i,_) -> not(List.mem_assoc i past)) present),
 592  List.map fst (List.filter (fun (i,_) -> not (List.mem_assoc i present)) past)
 593 ;;
 594
 595 (* paramodulation has only an implicit knoweledge of the symmetry of equality;
 596    hence it is in trouble in proving (a = b) = (b = a) *)
 597 let try_sym tac status g =
 598   let sym_eq = Ast.Appl [Ast.Ident("sym_eq",None); Ast.Implicit `Vector] in
 599   let _,_,metasenv,subst,_ = status#obj in
 600   let _, context, gty = List.assoc g metasenv in
 601   let is_eq =
 602     NCicParamod.is_equation status metasenv subst context gty
 603   in
 604   if is_eq then
 605     try tac status g
 606     with Error _ ->
 607       let new_status = instantiate_with_ast status g ("",0,sym_eq) in
 608       let go, _ = compare_statuses ~past:status ~present:new_status in
 609       assert (List.length go  = 1);
 610       let ng = List.hd go in
 611       tac new_status ng
 612    else tac status g
 613 ;;
 614
 615 let smart_apply_tac t s =
 616   let unit_eq = index_local_equations s#eq_cache s in
 617   NTactics.distribute_tac (try_sym (smart_apply t unit_eq)) s
 618   (* NTactics.distribute_tac (smart_apply t unit_eq) s *)
 619
 620 let smart_apply_auto t eq_cache =
 621   NTactics.distribute_tac (try_sym (smart_apply t eq_cache))
 622   (* NTactics.distribute_tac (smart_apply t eq_cache) *)
 623
 624
 625 (****************** types **************)
 626
 627
 628 type th_cache = (NCic.context * InvRelDiscriminationTree.t) list
 629
 630 (* cartesian: term set list -> term list set *)
 631 let rec cartesian =
 632  function
 633     [] -> NDiscriminationTree.TermListSet.empty
 634   | [l] ->
 635      NDiscriminationTree.TermSet.fold
 636       (fun x acc -> NDiscriminationTree.TermListSet.add [x] acc) l NDiscriminationTree.TermListSet.empty
 637   | he::tl ->
 638      let rest = cartesian tl in
 639       NDiscriminationTree.TermSet.fold
 640        (fun x acc ->
 641          NDiscriminationTree.TermListSet.fold (fun l acc' -> NDiscriminationTree.TermListSet.add (x::l) acc') rest acc
 642        ) he NDiscriminationTree.TermListSet.empty
 643 ;;
 644
 645 (* all_keys_of_cic_type: term -> term set *)
 646 let all_keys_of_cic_type status metasenv subst context ty =
 647  let saturate ty =
 648   (* Here we are dropping the metasenv, but this should not raise any
 649      exception (hopefully...) *)
 650   let ty,_,hyps =
 651    NCicMetaSubst.saturate status ~delta:max_int metasenv subst context ty 0
 652   in
 653    ty,List.length hyps
 654  in
 655  let rec aux ty =
 656   match ty with
 657      NCic.Appl (he::tl) ->
 658       let tl' =
 659        List.map (fun ty ->
 660         let wty = NCicReduction.whd status ~delta:0 ~subst context ty in
 661          if ty = wty then
 662           NDiscriminationTree.TermSet.add ty (aux ty)
 663          else
 664           NDiscriminationTree.TermSet.union
 665            (NDiscriminationTree.TermSet.add  ty (aux  ty))
 666            (NDiscriminationTree.TermSet.add wty (aux wty))
 667         ) tl
 668       in
 669        NDiscriminationTree.TermListSet.fold
 670         (fun l acc -> NDiscriminationTree.TermSet.add (NCic.Appl l) acc)
 671         (cartesian ((NDiscriminationTree.TermSet.singleton he)::tl'))
 672         NDiscriminationTree.TermSet.empty
 673    | _ -> NDiscriminationTree.TermSet.empty
 674  in
 675   let ty,ity = saturate ty in
 676   let wty,iwty = saturate (NCicReduction.whd status ~delta:0 ~subst context ty) in
 677    if ty = wty then
 678     [ity, NDiscriminationTree.TermSet.add ty (aux ty)]
 679    else
 680     [ity,  NDiscriminationTree.TermSet.add  ty (aux  ty) ;
 681      iwty, NDiscriminationTree.TermSet.add wty (aux wty) ]
 682 ;;
 683
 684 let all_keys_of_type status t =
 685  let _,_,metasenv,subst,_ = status#obj in
 686  let context = ctx_of t in
 687  let status, t = apply_subst status context t in
 688  let keys =
 689   all_keys_of_cic_type status metasenv subst context
 690    (snd (term_of_cic_term status t context))
 691  in
 692   status,
 693    List.map
 694     (fun (intros,keys) ->
 695       intros,
 696        NDiscriminationTree.TermSet.fold
 697         (fun t acc -> Ncic_termSet.add (mk_cic_term context t) acc)
 698         keys Ncic_termSet.empty
 699     ) keys
 700 ;;
 701
 702
 703 let keys_of_type status orig_ty =
 704   (* Here we are dropping the metasenv (in the status), but this should not
 705      raise any exception (hopefully...) *)
 706   let _, ty, _ = saturate ~delta:max_int status orig_ty in
 707   let _, ty = apply_subst status (ctx_of ty) ty in
 708   let keys =
 709 (*
 710     let orig_ty' = NCicTacReduction.normalize ~subst context orig_ty in
 711     if orig_ty' <> orig_ty then
 712      let ty',_,_= NCicMetaSubst.saturate ~delta:0 metasenv subst context orig_ty' 0 in
 713       [ty;ty']
 714     else
 715      [ty]
 716 *)
 717    [ty] in
 718 (*CSC: strange: we keep ty, ty normalized and ty ~delta:(h-1) *)
 719   let keys =
 720     let _, ty = term_of_cic_term status ty (ctx_of ty) in
 721     match ty with
 722     | NCic.Const (NReference.Ref (_,(NReference.Def h | NReference.Fix (_,_,h))))
 723     | NCic.Appl (NCic.Const(NReference.Ref(_,(NReference.Def h | NReference.Fix (_,_,h))))::_)
 724        when h > 0 ->
 725          let _,ty,_= saturate status ~delta:(h-1) orig_ty in
 726          ty::keys
 727     | _ -> keys
 728   in
 729   status, keys
 730 ;;
 731
 732 let all_keys_of_term status t =
 733  let status, orig_ty = typeof status (ctx_of t) t in
 734   all_keys_of_type status orig_ty
 735 ;;
 736
 737 let keys_of_term status t =
 738   let status, orig_ty = typeof status (ctx_of t) t in
 739     keys_of_type status orig_ty
 740 ;;
 741
 742 let mk_th_cache status gl =
 743   List.fold_left
 744     (fun (status, acc) g ->
 745        let gty = get_goalty status g in
 746        let ctx = ctx_of gty in
 747        noprint(lazy("th cache for: "^ppterm status gty));
 748        noprint(lazy("th cache in: "^ppcontext status ctx));
 749        if List.mem_assq ctx acc then status, acc else
 750          let idx = InvRelDiscriminationTree.empty in
 751          let status,_,idx =
 752            List.fold_left
 753              (fun (status, i, idx) _ ->
 754                 let t = mk_cic_term ctx (NCic.Rel i) in
 755                 let status, keys = keys_of_term status t in
 756                 noprint(lazy("indexing: "^ppterm status t ^ ": " ^ string_of_int (List.length keys)));
 757                 let idx =
 758                   List.fold_left (fun idx k ->
 759                     InvRelDiscriminationTree.index idx k t) idx keys
 760                 in
 761                 status, i+1, idx)
 762              (status, 1, idx) ctx
 763           in
 764          status, (ctx, idx) :: acc)
 765     (status,[]) gl
 766 ;;
 767
 768 let all_elements ctx cache =
 769   let dummy = mk_cic_term ctx (NCic.Meta (0,(0, (NCic.Irl 0)))) in
 770     try
 771       let idx = List.assq ctx cache in
 772       Ncic_termSet.elements
 773         (InvRelDiscriminationTree.retrieve_unifiables idx dummy)
 774     with Not_found -> []
 775
 776 let add_to_th t c ty =
 777   let key_c = ctx_of t in
 778   if not (List.mem_assq key_c c) then
 779       (key_c ,InvRelDiscriminationTree.index
 780                InvRelDiscriminationTree.empty ty t ) :: c
 781   else
 782     let rec replace = function
 783       | [] -> []
 784       | (x, idx) :: tl when x == key_c ->
 785           (x, InvRelDiscriminationTree.index idx ty t) :: tl
 786       | x :: tl -> x :: replace tl
 787     in
 788       replace c
 789 ;;
 790
 791 let rm_from_th t c ty =
 792   let key_c = ctx_of t in
 793   if not (List.mem_assq key_c c) then assert false
 794   else
 795     let rec replace = function
 796       | [] -> []
 797       | (x, idx) :: tl when x == key_c ->
 798           (x, InvRelDiscriminationTree.remove_index idx ty t) :: tl
 799       | x :: tl -> x :: replace tl
 800     in
 801       replace c
 802 ;;
 803
 804 let pp_idx status idx =
 805    InvRelDiscriminationTree.iter idx
 806       (fun k set ->
 807          noprint(lazy("K: " ^ NCicInverseRelIndexable.string_of_path k));
 808          Ncic_termSet.iter
 809            (fun t -> debug_print(lazy("\t"^ppterm status t)))
 810            set)
 811 ;;
 812
 813 let pp_th (status: #NTacStatus.pstatus) =
 814   List.iter
 815     (fun ctx, idx ->
 816        noprint(lazy( "-----------------------------------------------"));
 817        noprint(lazy( (status#ppcontext ~metasenv:[] ~subst:[] ctx)));
 818        noprint(lazy( "||====>  "));
 819        pp_idx status idx)
 820 ;;
 821
 822 let search_in_th gty th =
 823   let c = ctx_of gty in
 824   let rec aux acc = function
 825    | [] -> (* Ncic_termSet.elements *) acc
 826    | (_::tl) as k ->
 827        try
 828          let idx = List.assoc(*q*) k th in
 829          let acc = Ncic_termSet.union acc
 830            (InvRelDiscriminationTree.retrieve_unifiables idx gty)
 831          in
 832          aux acc tl
 833        with Not_found -> aux acc tl
 834   in
 835     aux Ncic_termSet.empty c
 836 ;;
 837
 838 type flags = {
 839         do_types : bool; (* solve goals in Type *)
 840         last : bool; (* last goal: take first solution only  *)
 841         candidates: Ast.term list option;
 842         maxwidth : int;
 843         maxsize  : int;
 844         maxdepth : int;
 845         timeout  : float;
 846 }
 847
 848 type cache =
 849     {facts : th_cache; (* positive results *)
 850      under_inspection : cic_term list * th_cache; (* to prune looping *)
 851      failures : th_cache; (* to avoid repetitions *)
 852      unit_eq : NCicParamod.state;
 853      trace: Ast.term list
 854     }
 855
 856 let add_to_trace status ~depth cache t =
 857   match t with
 858     | Ast.NRef _ ->
 859         debug_print ~depth (lazy ("Adding to trace: " ^ NotationPp.pp_term status t));
 860         {cache with trace = t::cache.trace}
 861     | Ast.NCic _  (* local candidate *)
 862     | _  -> (*not an application *) cache
 863
 864 let pptrace status tr =
 865   (lazy ("Proof Trace: " ^ (String.concat ";"
 866                               (List.map (NotationPp.pp_term status) tr))))
 867 (* not used
 868 let remove_from_trace cache t =
 869   match t with
 870     | Ast.NRef _ ->
 871         (match cache.trace with
 872            |  _::tl -> {cache with trace = tl}
 873            | _ -> assert false)
 874     | Ast.NCic _  (* local candidate *)
 875     |  _  -> (*not an application *) cache *)
 876
 877 type sort = T | P
 878 type goal = int * sort (* goal, depth, sort *)
 879 type fail = goal * cic_term
 880 type candidate = int * Ast.term (* unique candidate number, candidate *)
 881
 882 exception Gaveup of th_cache (* failure cache *)
 883 exception Proved of NTacStatus.tac_status * Ast.term list
 884
 885 (* let close_failures _ c = c;; *)
 886 (* let prunable _ _ _ = false;; *)
 887 (* let cache_examine cache gty = `Notfound;; *)
 888 (* let put_in_subst s _ _ _  = s;; *)
 889 (* let add_to_cache_and_del_from_orlist_if_green_cut _ _ c _ _ o f _ = c, o, f, false ;; *)
 890 (* let cache_add_underinspection c _ _ = c;; *)
 891
 892 let init_cache ?(facts=[]) ?(under_inspection=[],[])
 893     ?(failures=[])
 894     ?(unit_eq=NCicParamod.empty_state)
 895     ?(trace=[])
 896     _ =
 897     {facts = facts;
 898      failures = failures;
 899      under_inspection = under_inspection;
 900      unit_eq = unit_eq;
 901      trace = trace}
 902
 903 let only signature _context candidate = true
 904 (*
 905         (* TASSI: nel trie ci mettiamo solo il body, non il ty *)
 906   let candidate_ty =
 907    NCicTypeChecker.typeof ~subst:[] ~metasenv:[] [] candidate
 908   in
 909   let height = fast_height_of_term status candidate_ty in
 910   let rc = signature >= height in
 911   if rc = false then
 912     noprint (lazy ("Filtro: " ^ status#ppterm ~context:[] ~subst:[]
 913           ~metasenv:[] candidate ^ ": " ^ string_of_int height))
 914   else
 915     noprint (lazy ("Tengo: " ^ status#ppterm ~context:[] ~subst:[]
 916           ~metasenv:[] candidate ^ ": " ^ string_of_int height));
 917
 918   rc *)
 919 ;;
 920
 921 let candidate_no = ref 0;;
 922
 923 let openg_no status = List.length (head_goals status#stack)
 924
 925 let sort_candidates status ctx candidates =
 926  let _,_,metasenv,subst,_ = status#obj in
 927   let branch cand =
 928     let status,ct = disambiguate status ctx ("",0,cand) None in
 929     let status,t = term_of_cic_term status ct ctx in
 930     let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
 931     let res = branch status (mk_cic_term ctx ty) in
 932     noprint (lazy ("branch factor for: " ^ (ppterm status ct) ^ " = "
 933                       ^ (string_of_int res)));
 934       res
 935   in
 936   let candidates = List.map (fun t -> branch t,t) candidates in
 937   let candidates =
 938      List.sort (fun (a,_) (b,_) -> a - b) candidates in
 939   let candidates = List.map snd candidates in
 940     noprint (lazy ("candidates =\n" ^ (String.concat "\n"
 941         (List.map (NotationPp.pp_term status) candidates))));
 942     candidates
 943
 944 let sort_new_elems l =
 945   List.sort (fun (_,s1) (_,s2) -> openg_no s1 - openg_no s2) l
 946
 947 let try_candidate ?(smart=0) flags depth status eq_cache ctx t =
 948  try
 949   debug_print ~depth (lazy ("try " ^ (NotationPp.pp_term status) t));
 950   let status =
 951     if smart = 0 then NTactics.apply_tac ("",0,t) status
 952     else if smart = 1 then
 953       smart_apply_auto ("",0,t) eq_cache status
 954     else (* smart = 2: both *)
 955       try NTactics.apply_tac ("",0,t) status
 956       with Error _ ->
 957         smart_apply_auto ("",0,t) eq_cache status
 958   in
 959 (*
 960   let og_no = openg_no status in
 961     if (* og_no > flags.maxwidth || *)
 962       ((depth + 1) = flags.maxdepth && og_no <> 0) then
 963         (debug_print ~depth (lazy "pruned immediately"); None)
 964     else *)
 965       (* useless
 966       let status, cict = disambiguate status ctx ("",0,t) None in
 967       let status,ct = term_of_cic_term status cict ctx in
 968       let _,_,metasenv,subst,_ = status#obj in
 969       let ty = NCicTypeChecker.typeof subst metasenv ctx ct in
 970       let res = branch status (mk_cic_term ctx ty) in
 971       if smart=1 && og_no > res then
 972         (debug_print (lazy ("branch factor for: " ^ (ppterm status cict) ^ " = "
 973                     ^ (string_of_int res) ^ " vs. " ^ (string_of_int og_no)));
 974          debug_print ~depth (lazy "strange application"); None)
 975       else *)
 976         (incr candidate_no;
 977          Some ((!candidate_no,t),status))
 978  with Error (msg,exn) -> debug_print ~depth (lazy "failed"); None
 979 ;;
 980
 981 let sort_of status subst metasenv ctx t =
 982   let ty = NCicTypeChecker.typeof status subst metasenv ctx t in
 983   let metasenv',ty = NCicUnification.fix_sorts status metasenv subst ty in
 984    assert (metasenv = metasenv');
 985    NCicTypeChecker.typeof status subst metasenv ctx ty
 986 ;;
 987
 988 let type0= NUri.uri_of_string ("cic:/matita/pts/Type0.univ")
 989 ;;
 990
 991 let perforate_small status subst metasenv context t =
 992   let rec aux = function
 993     | NCic.Appl (hd::tl) ->
 994         let map t =
 995           let s = sort_of status subst metasenv context t in
 996             match s with
 997               | NCic.Sort(NCic.Type [`Type,u])
 998                   when u=type0 -> NCic.Meta (0,(0,NCic.Irl 0))
 999               | _ -> aux t
1000         in
1001           NCic.Appl (hd::List.map map tl)
1002     | t -> t
1003   in
1004     aux t
1005 ;;
1006
1007 let get_cands retrieve_for diff empty gty weak_gty =
1008   let cands = retrieve_for gty in
1009     match weak_gty with
1010       | None -> cands, empty
1011       | Some weak_gty ->
1012           let more_cands =  retrieve_for weak_gty in
1013             cands, diff more_cands cands
1014 ;;
1015
1016 let get_candidates ?(smart=true) depth flags status cache signature gty =
1017   let maxd = ((depth + 1) = flags.maxdepth) in
1018   let universe = status#auto_cache in
1019   let _,_,metasenv,subst,_ = status#obj in
1020   let context = ctx_of gty in
1021   let _, raw_gty = term_of_cic_term status gty context in
1022   debug_print ~depth (lazy ("gty:" ^ NTacStatus.ppterm status gty));
1023   let raw_weak_gty, weak_gty  =
1024     if smart then
1025       match raw_gty with
1026         | NCic.Appl _
1027         | NCic.Const _
1028         | NCic.Rel _ ->
1029             let raw_weak =
1030               perforate_small status subst metasenv context raw_gty in
1031             let weak = mk_cic_term context raw_weak in
1032             debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak));
1033               Some raw_weak, Some (weak)
1034         | _ -> None,None
1035     else None,None
1036   in
1037   let global_cands, smart_global_cands =
1038     match flags.candidates with
1039       | Some l when (not maxd) -> l,[]
1040       | Some _
1041       | None ->
1042           let mapf s =
1043             let to_ast = function
1044               | NCic.Const r when true (*is_relevant statistics r*) -> Some (Ast.NRef r)
1045         (*       | NCic.Const _ -> None  *)
1046               | _ -> assert false in
1047               HExtlib.filter_map
1048                 to_ast (NDiscriminationTree.TermSet.elements s) in
1049           let g,l =
1050             get_cands
1051               (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1052                  universe)
1053               NDiscriminationTree.TermSet.diff
1054               NDiscriminationTree.TermSet.empty
1055               raw_gty raw_weak_gty in
1056             mapf g, mapf l in
1057   let local_cands,smart_local_cands =
1058     let mapf s =
1059       let to_ast t =
1060         let _status, t = term_of_cic_term status t context
1061         in Ast.NCic t in
1062         List.map to_ast (Ncic_termSet.elements s) in
1063     let g,l =
1064       get_cands
1065         (fun ty -> search_in_th ty cache)
1066         Ncic_termSet.diff  Ncic_termSet.empty gty weak_gty in
1067       mapf g, mapf l in
1068     sort_candidates status context (global_cands@local_cands),
1069     sort_candidates status context (smart_global_cands@smart_local_cands)
1070 ;;
1071
1072 (* old version
1073 let get_candidates ?(smart=true) status cache signature gty =
1074   let universe = status#auto_cache in
1075   let _,_,metasenv,subst,_ = status#obj in
1076   let context = ctx_of gty in
1077   let t_ast t =
1078      let _status, t = term_of_cic_term status t context
1079      in Ast.NCic t in
1080   let c_ast = function
1081     | NCic.Const r -> Ast.NRef r | _ -> assert false in
1082   let _, raw_gty = term_of_cic_term status gty context in
1083   let keys = all_keys_of_cic_term metasenv subst context raw_gty in
1084   (* we only keep those keys that do not require any intros for now *)
1085   let no_intros_keys = snd (List.hd keys) in
1086   let cands =
1087    NDiscriminationTree.TermSet.fold
1088     (fun ty acc ->
1089       NDiscriminationTree.TermSet.union acc
1090        (NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1091          universe ty)
1092     ) no_intros_keys NDiscriminationTree.TermSet.empty in
1093 (* old code:
1094   let cands = NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1095         universe raw_gty in
1096 *)
1097   let local_cands =
1098    NDiscriminationTree.TermSet.fold
1099     (fun ty acc ->
1100       Ncic_termSet.union acc (search_in_th (mk_cic_term context ty) cache)
1101     ) no_intros_keys Ncic_termSet.empty in
1102 (* old code:
1103   let local_cands = search_in_th gty cache in
1104 *)
1105   debug_print (lazy ("candidates for" ^ NTacStatus.ppterm status gty));
1106   debug_print (lazy ("local cands = " ^ (string_of_int (List.length (Ncic_termSet.elements local_cands)))));
1107   let together global local =
1108     List.map c_ast
1109       (List.filter (only signature context)
1110         (NDiscriminationTree.TermSet.elements global)) @
1111       List.map t_ast (Ncic_termSet.elements local) in
1112   let candidates = together cands local_cands in
1113   let candidates = sort_candidates status context candidates in
1114   let smart_candidates =
1115     if smart then
1116       match raw_gty with
1117         | NCic.Appl _
1118         | NCic.Const _
1119         | NCic.Rel _ ->
1120             let weak_gty = perforate_small status subst metasenv context raw_gty in
1121               (*
1122               NCic.Appl (hd:: HExtlib.mk_list(NCic.Meta (0,(0,NCic.Irl 0)))
1123                            (List.length tl)) in *)
1124             let more_cands =
1125               NDiscriminationTree.DiscriminationTree.retrieve_unifiables
1126                 universe weak_gty
1127             in
1128             let smart_cands =
1129               NDiscriminationTree.TermSet.diff more_cands cands in
1130             let cic_weak_gty = mk_cic_term context weak_gty in
1131             let more_local_cands = search_in_th cic_weak_gty cache in
1132             let smart_local_cands =
1133               Ncic_termSet.diff more_local_cands local_cands in
1134               together smart_cands smart_local_cands
1135               (* together more_cands more_local_cands *)
1136         | _ -> []
1137     else []
1138   in
1139   let smart_candidates = sort_candidates status context smart_candidates in
1140   (* if smart then smart_candidates, []
1141      else candidates, [] *)
1142   candidates, smart_candidates
1143 ;;
1144
1145 let get_candidates ?(smart=true) flags status cache signature gty =
1146   match flags.candidates with
1147     | None -> get_candidates ~smart status cache signature gty
1148     | Some l -> l,[]
1149 ;; *)
1150
1151 let applicative_case depth signature status flags gty cache =
1152   app_counter:= !app_counter+1;
1153   let _,_,metasenv,subst,_ = status#obj in
1154   let context = ctx_of gty in
1155   let tcache = cache.facts in
1156   let is_prod, is_eq =
1157     let status, t = term_of_cic_term status gty context  in
1158     let t = NCicReduction.whd status subst context t in
1159       match t with
1160         | NCic.Prod _ -> true, false
1161         | _ -> false, NCicParamod.is_equation status metasenv subst context t
1162   in
1163   debug_print ~depth (lazy (string_of_bool is_eq));
1164   (* new *)
1165   let candidates, smart_candidates =
1166     get_candidates ~smart:true depth
1167       flags status tcache signature gty in
1168   let test = is_a_fact_ast status subst metasenv context in
1169   let candidates_facts,candidates_other =
1170     (* if the goal is an equation we avoid to apply unit equalities,
1171      since superposition should take care of them; refl is an
1172      exception since it prompts for convertibility *)
1173     let l1,l2 = List.partition test candidates in
1174     if is_eq then [Ast.Ident("refl",None)],l2 else l1,l2
1175   in
1176   let smart_candidates_facts, smart_candidates_other =
1177     let l1,l2 = List.partition test smart_candidates in
1178     if is_eq then [],l2 else l1,l2
1179   in
1180   let sm = if is_eq then 0 else 2 in
1181   let sm1 = if flags.last then 2 else 0 in
1182   let maxd = (depth + 1 = flags.maxdepth) in
1183   let try_candidates only_one sm acc candidates =
1184     List.fold_left
1185       (fun elems cand ->
1186          if (only_one && (elems <> [])) then elems
1187          else
1188            match try_candidate (~smart:sm)
1189              flags depth status cache.unit_eq context cand with
1190                | None -> elems
1191                | Some x -> x::elems)
1192       acc candidates
1193   in
1194   (* if the goal is the last one we stop at the first fact *)
1195   let elems = try_candidates flags.last sm [] candidates_facts in
1196   (* now we add smart_facts *)
1197   let elems = try_candidates flags.last sm elems smart_candidates_facts in
1198   (* if we are at maxdepth and the goal is not a product we are done
1199      similarly, if the goal is the last one and we already found a
1200      solution *)
1201   if (maxd && not(is_prod)) || (flags.last && elems<>[]) then elems
1202   else
1203     let elems = try_candidates false 2 elems candidates_other in
1204     debug_print ~depth (lazy ("not facts: try smart application"));
1205     try_candidates false 2 elems smart_candidates_other
1206 ;;
1207
1208 exception Found
1209 ;;
1210
1211
1212 (* gty is supposed to be meta-closed *)
1213 let is_subsumed depth filter_depth status gty cache =
1214   if cache=[] then false else (
1215   debug_print ~depth (lazy("Subsuming " ^ (ppterm status gty)));
1216   let n,h,metasenv,subst,obj = status#obj in
1217   let ctx = ctx_of gty in
1218   let _ , raw_gty = term_of_cic_term status gty ctx in
1219   let target = NCicSubstitution.lift status 1 raw_gty in
1220   (* we compute candidates using the perforated type *)
1221   let weak_gty  =
1222     match target with
1223       | NCic.Appl _
1224       | NCic.Const _
1225       | NCic.Rel _ ->
1226           let raw_weak =
1227             perforate_small status subst metasenv ctx raw_gty in
1228           let weak = mk_cic_term ctx raw_weak in
1229           debug_print ~depth (lazy ("weak_gty:" ^ NTacStatus.ppterm status weak));
1230           Some (weak)
1231       | _ -> None
1232   in
1233   (* candidates must only be searched w.r.t the given context *)
1234   let candidates =
1235     try
1236     let idx = List.assq ctx cache in
1237     match weak_gty with
1238       | Some weak ->
1239           Ncic_termSet.elements
1240             (InvRelDiscriminationTree.retrieve_unifiables idx weak)
1241       |None -> []
1242     with Not_found -> []
1243   in
1244   (* this is a dirty trick: the first argument of an application is used
1245      to remember at which depth a goal failed *)
1246   let filter t =
1247     let ctx = ctx_of t in
1248     let _, src = term_of_cic_term status t ctx in
1249     match src with
1250      | NCic.Appl [NCic.Implicit (`Typeof d); t]
1251        when d <= depth -> Some (mk_cic_term ctx t)
1252      | _ -> None in
1253   let candidates =
1254     if filter_depth then HExtlib.filter_map filter candidates else candidates in
1255   debug_print ~depth
1256     (lazy ("failure candidates: " ^ string_of_int (List.length candidates)));
1257     try
1258       List.iter
1259         (fun t ->
1260            let _ , source = term_of_cic_term status t ctx in
1261            let implication =
1262              NCic.Prod("foo",source,target) in
1263            let metasenv,j,_,_ =
1264              NCicMetaSubst.mk_meta
1265                metasenv ctx ~with_type:implication `IsType in
1266            let status = status#set_obj (n,h,metasenv,subst,obj) in
1267            let status = status#set_stack [([1,Open j],[],[],`NoTag)] in
1268            try
1269              let status = NTactics.intro_tac "foo" status in
1270              let status =
1271                NTactics.apply_tac ("",0,Ast.NCic (NCic.Rel 1)) status
1272              in
1273                if (head_goals status#stack = []) then raise Found
1274                else ()
1275            with
1276              | Error _ -> ())
1277         candidates;false
1278     with Found -> debug_print ~depth (lazy "success");true)
1279 ;;
1280
1281 let rec guess_name name ctx =
1282   if name = "_" then guess_name "auto" ctx else
1283   if not (List.mem_assoc name ctx) then name else
1284   guess_name (name^"'") ctx
1285 ;;
1286
1287 let is_prod status =
1288   let _, ctx, gty = current_goal status in
1289   let status, gty = apply_subst status ctx gty in
1290   let _, raw_gty = term_of_cic_term status gty ctx in
1291   match raw_gty with
1292     | NCic.Prod (name,src,_) ->
1293         let status, src = whd status ~delta:0 ctx (mk_cic_term ctx src) in
1294         (match snd (term_of_cic_term status src ctx) with
1295         | NCic.Const(NReference.Ref (_,NReference.Ind _) as r)
1296         | NCic.Appl (NCic.Const(NReference.Ref (_,NReference.Ind _) as r)::_) ->
1297             let _,_,itys,_,_ = NCicEnvironment.get_checked_indtys status r in
1298             (match itys with
1299             (* | [_,_,_,[_;_]]  con nat va, ovviamente, in loop *)
1300             | [_,_,_,[_]]
1301             | [_,_,_,[]] -> `Inductive (guess_name name ctx)
1302             | _ -> `Some (guess_name name ctx))
1303         | _ -> `Some (guess_name name ctx))
1304     | _ -> `None
1305
1306 let intro ~depth status facts name =
1307   let status = NTactics.intro_tac name status in
1308   let _, ctx, ngty = current_goal status in
1309   let t = mk_cic_term ctx (NCic.Rel 1) in
1310   let status, keys = keys_of_term status t in
1311   let facts = List.fold_left (add_to_th t) facts keys in
1312     debug_print ~depth (lazy ("intro: "^ name));
1313   (* unprovability is not stable w.r.t introduction *)
1314   status, facts
1315 ;;
1316
1317 let rec intros_facts ~depth status facts =
1318   if List.length (head_goals status#stack) <> 1 then status, facts else
1319   match is_prod status with
1320     | `Inductive name
1321     | `Some(name) ->
1322         let status,facts =
1323           intro ~depth status facts name
1324         in intros_facts ~depth status facts
1325 (*    | `Inductive name ->
1326           let status = NTactics.case1_tac name status in
1327           intros_facts ~depth status facts *)
1328     | _ -> status, facts
1329 ;;
1330
1331 let intros ~depth status cache =
1332     match is_prod status with
1333       | `Inductive _
1334       | `Some _ ->
1335           let trace = cache.trace in
1336           let status,facts =
1337             intros_facts ~depth status cache.facts
1338           in
1339           if head_goals status#stack = [] then
1340             let status = NTactics.merge_tac status in
1341             [(0,Ast.Ident("__intros",None)),status], cache
1342           else
1343             (* we reindex the equation from scratch *)
1344             let unit_eq = index_local_equations status#eq_cache status in
1345             let status = NTactics.merge_tac status in
1346             [(0,Ast.Ident("__intros",None)),status],
1347             init_cache ~facts ~unit_eq () ~trace
1348       | _ -> [],cache
1349 ;;
1350
1351 let reduce ~whd ~depth status g =
1352   let n,h,metasenv,subst,o = status#obj in
1353   let attr, ctx, ty = NCicUtils.lookup_meta g metasenv in
1354   let ty = NCicUntrusted.apply_subst status subst ctx ty in
1355   let ty' =
1356    (if whd then NCicReduction.whd else NCicTacReduction.normalize) status ~subst ctx ty
1357   in
1358   if ty = ty' then []
1359   else
1360     (debug_print ~depth
1361       (lazy ("reduced to: "^ status#ppterm ctx subst metasenv ty'));
1362     let metasenv =
1363       (g,(attr,ctx,ty'))::(List.filter (fun (i,_) -> i<>g) metasenv)
1364     in
1365     let status = status#set_obj (n,h,metasenv,subst,o) in
1366     (* we merge to gain a depth level; the previous goal level should
1367        be empty *)
1368     let status = NTactics.merge_tac status in
1369     incr candidate_no;
1370     [(!candidate_no,Ast.Ident("__whd",None)),status])
1371 ;;
1372
1373 let is_meta status gty =
1374   let _, ty = term_of_cic_term status gty (ctx_of gty) in
1375   match ty with
1376   | NCic.Meta _ -> true
1377   | _ -> false
1378 ;;
1379
1380 let do_something signature flags status g depth gty cache =
1381   (* if the goal is meta we close it with I:True. This should work
1382     thnaks to the toplogical sorting of goals. *)
1383   if is_meta status gty then
1384     let t = Ast.Ident("I",None) in
1385     debug_print (lazy ("using default term" ^ (NotationPp.pp_term status) t));
1386     let s = NTactics.apply_tac ("",0,t) status in
1387     [(0,t),s], cache
1388   else
1389   let l0, cache = intros ~depth status cache in
1390   if l0 <> [] then l0, cache
1391   else
1392   (* whd *)
1393   let l = reduce ~whd:true ~depth status g in
1394   (* if l <> [] then l,cache else *)
1395   (* backward aplications *)
1396   let l1 =
1397     List.map
1398       (fun s ->
1399          incr candidate_no;
1400          ((!candidate_no,Ast.Ident("__paramod",None)),s))
1401       (auto_eq_check cache.unit_eq status)
1402   in
1403   let l2 =
1404     if ((l1 <> []) && flags.last) then [] else
1405     applicative_case depth signature status flags gty cache
1406   in
1407   (* statistics *)
1408   List.iter
1409     (fun ((_,t),_) -> toref incr_nominations statistics t) l2;
1410   (* states in l1 have have an empty set of subgoals: no point to sort them *)
1411   debug_print ~depth
1412     (lazy ("alternatives = " ^ (string_of_int (List.length (l1@l@l2)))));
1413     (* we order alternatives w.r.t the number of subgoals they open *)
1414     l1 @ (sort_new_elems l2) @ l, cache
1415 ;;
1416
1417 let pp_goal = function
1418   | (_,Continuationals.Stack.Open i)
1419   | (_,Continuationals.Stack.Closed i) -> string_of_int i
1420 ;;
1421
1422 let pp_goals status l =
1423   String.concat ", "
1424     (List.map
1425        (fun i ->
1426           let gty = get_goalty status i in
1427             NTacStatus.ppterm status gty)
1428        l)
1429 ;;
1430
1431 module M =
1432   struct
1433     type t = int
1434     let compare = Pervasives.compare
1435   end
1436 ;;
1437
1438 module MS = HTopoSort.Make(M)
1439 ;;
1440
1441 let sort_tac status =
1442   let gstatus =
1443     match status#stack with
1444     | [] -> assert false
1445     | (goals, t, k, tag) :: s ->
1446         let g = head_goals status#stack in
1447         let sortedg =
1448           (List.rev (MS.topological_sort g (deps status))) in
1449           noprint (lazy ("old g = " ^
1450             String.concat "," (List.map string_of_int g)));
1451           noprint (lazy ("sorted goals = " ^
1452             String.concat "," (List.map string_of_int sortedg)));
1453           let is_it i = function
1454             | (_,Continuationals.Stack.Open j )
1455             | (_,Continuationals.Stack.Closed j ) -> i = j
1456           in
1457           let sorted_goals =
1458             List.map (fun i -> List.find (is_it i) goals) sortedg
1459           in
1460             (sorted_goals, t, k, tag) :: s
1461   in
1462    status#set_stack gstatus
1463 ;;
1464
1465 let clean_up_tac status =
1466   let gstatus =
1467     match status#stack with
1468     | [] -> assert false
1469     | (g, t, k, tag) :: s ->
1470         let is_open = function
1471           | (_,Continuationals.Stack.Open _) -> true
1472           | (_,Continuationals.Stack.Closed _) -> false
1473         in
1474         let g' = List.filter is_open g in
1475           (g', t, k, tag) :: s
1476   in
1477    status#set_stack gstatus
1478 ;;
1479
1480 let focus_tac focus status =
1481   let gstatus =
1482     match status#stack with
1483     | [] -> assert false
1484     | (g, t, k, tag) :: s ->
1485         let in_focus = function
1486           | (_,Continuationals.Stack.Open i)
1487           | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1488         in
1489         let focus,others = List.partition in_focus g
1490         in
1491           (* we need to mark it as a BranchTag, otherwise cannot merge later *)
1492           (focus,[],[],`BranchTag) :: (others, t, k, tag) :: s
1493   in
1494    status#set_stack gstatus
1495 ;;
1496
1497 let deep_focus_tac level focus status =
1498   let in_focus = function
1499     | (_,Continuationals.Stack.Open i)
1500     | (_,Continuationals.Stack.Closed i) -> List.mem i focus
1501   in
1502   let rec slice level gs =
1503     if level = 0 then [],[],gs else
1504       match gs with
1505         | [] -> assert false
1506         | (g, t, k, tag) :: s ->
1507             let f,o,gs = slice (level-1) s in
1508             let f1,o1 = List.partition in_focus g
1509             in
1510             (f1,[],[],`BranchTag)::f, (o1, t, k, tag)::o, gs
1511   in
1512   let gstatus =
1513     let f,o,s = slice level status#stack in f@o@s
1514   in
1515    status#set_stack gstatus
1516 ;;
1517
1518 let rec stack_goals level gs =
1519   if level = 0 then []
1520   else match gs with
1521     | [] -> assert false
1522     | (g,_,_,_)::s ->
1523         let is_open = function
1524           | (_,Continuationals.Stack.Open i) -> Some i
1525           | (_,Continuationals.Stack.Closed _) -> None
1526         in
1527           HExtlib.filter_map is_open g @ stack_goals (level-1) s
1528 ;;
1529
1530 let open_goals level status = stack_goals level status#stack
1531 ;;
1532
1533 let move_to_side level status =
1534 match status#stack with
1535   | [] -> assert false
1536   | (g,_,_,_)::tl ->
1537       let is_open = function
1538           | (_,Continuationals.Stack.Open i) -> Some i
1539           | (_,Continuationals.Stack.Closed _) -> None
1540         in
1541       let others = menv_closure status (stack_goals (level-1) tl) in
1542       List.for_all (fun i -> IntSet.mem i others)
1543         (HExtlib.filter_map is_open g)
1544
1545 let rec auto_clusters ?(top=false)
1546     flags signature cache depth status : unit =
1547   debug_print ~depth (lazy ("entering auto clusters at depth " ^
1548                            (string_of_int depth)));
1549   debug_print ~depth (pptrace status cache.trace);
1550   (* ignore(Unix.select [] [] [] 0.01); *)
1551   let status = clean_up_tac status in
1552   let goals = head_goals status#stack in
1553   if goals = [] then
1554     if depth = 0 then raise (Proved (status, cache.trace))
1555     else
1556       let status = NTactics.merge_tac status in
1557         let cache =
1558         let l,tree = cache.under_inspection in
1559           match l with
1560             | [] -> cache (* possible because of intros that cleans the cache *)
1561             | a::tl -> let tree = rm_from_th a tree a in
1562               {cache with under_inspection = tl,tree}
1563         in
1564          auto_clusters flags signature cache (depth-1) status
1565   else if List.length goals < 2 then
1566     auto_main flags signature cache depth status
1567   else
1568     let all_goals = open_goals (depth+1) status in
1569     debug_print ~depth (lazy ("goals = " ^
1570       String.concat "," (List.map string_of_int all_goals)));
1571     let classes = HExtlib.clusters (deps status) all_goals in
1572     (* if any of the classes exceed maxwidth we fail *)
1573     List.iter
1574       (fun gl ->
1575          if List.length gl > flags.maxwidth then
1576            begin
1577              debug_print ~depth (lazy "FAIL GLOBAL WIDTH");
1578              HLog.warn (sprintf "global width (%u) exceeded: %u"
1579                flags.maxwidth (List.length gl));
1580              raise (Gaveup cache.failures)
1581            end else ()) classes;
1582     if List.length classes = 1 then
1583       let flags =
1584         {flags with last = (List.length all_goals = 1)} in
1585         (* no need to cluster *)
1586         auto_main flags signature cache depth status
1587     else
1588       let classes = if top then List.rev classes else classes in
1589       debug_print ~depth
1590         (lazy
1591            (String.concat "\n"
1592            (List.map
1593              (fun l ->
1594                ("cluster:" ^ String.concat "," (List.map string_of_int l)))
1595            classes)));
1596       (* we now process each cluster *)
1597       let status,cache,b =
1598         List.fold_left
1599           (fun (status,cache,b) gl ->
1600              let flags =
1601                {flags with last = (List.length gl = 1)} in
1602              let lold = List.length status#stack in
1603               debug_print ~depth (lazy ("stack length = " ^
1604                         (string_of_int lold)));
1605              let fstatus = deep_focus_tac (depth+1) gl status in
1606              try
1607                debug_print ~depth (lazy ("focusing on" ^
1608                               String.concat "," (List.map string_of_int gl)));
1609                auto_main flags signature cache depth fstatus; assert false
1610              with
1611                | Proved(status,trace) ->
1612                    let status = NTactics.merge_tac status in
1613                    let cache = {cache with trace = trace} in
1614                    let lnew = List.length status#stack in
1615                      assert (lold = lnew);
1616                    (status,cache,true)
1617                | Gaveup failures when top ->
1618                    let cache = {cache with failures = failures} in
1619                    (status,cache,b)
1620           )
1621           (status,cache,false) classes
1622       in
1623       let rec final_merge n s =
1624         if n = 0 then s else final_merge (n-1) (NTactics.merge_tac s)
1625       in let status = final_merge depth status
1626       in if b then raise (Proved(status,cache.trace)) else raise (Gaveup cache.failures)
1627
1628 and
1629
1630 (* BRAND NEW VERSION *)
1631 auto_main flags signature cache depth status: unit =
1632   debug_print ~depth (lazy "entering auto main");
1633   debug_print ~depth (pptrace status cache.trace);
1634   debug_print ~depth (lazy ("stack length = " ^
1635                         (string_of_int (List.length status#stack))));
1636   (* ignore(Unix.select [] [] [] 0.01); *)
1637   let status = sort_tac (clean_up_tac status) in
1638   let goals = head_goals status#stack in
1639   match goals with
1640     | [] when depth = 0 -> raise (Proved (status,cache.trace))
1641     | []  ->
1642         let status = NTactics.merge_tac status in
1643         let cache =
1644           let l,tree = cache.under_inspection in
1645             match l with
1646               | [] -> cache (* possible because of intros that cleans the cache *)
1647               | a::tl -> let tree = rm_from_th a tree a in
1648                   {cache with under_inspection = tl,tree}
1649         in
1650           auto_clusters flags signature cache (depth-1) status
1651     | orig::_ ->
1652         if depth > 0 && move_to_side depth status
1653         then
1654           let status = NTactics.merge_tac status in
1655           let cache =
1656             let l,tree = cache.under_inspection in
1657               match l with
1658                 | [] -> cache (* possible because of intros that cleans the cache*)
1659                 | a::tl -> let tree = rm_from_th a tree a in
1660                     {cache with under_inspection = tl,tree}
1661           in
1662             auto_clusters flags signature cache (depth-1) status
1663         else
1664         let ng = List.length goals in
1665         (* moved inside auto_clusters *)
1666         if ng > flags.maxwidth then begin
1667           debug_print ~depth (lazy "FAIL LOCAL WIDTH");
1668           HLog.warn (sprintf "local width (%u) exceeded: %u"
1669              flags.maxwidth ng);
1670           raise (Gaveup cache.failures)
1671         end else if depth = flags.maxdepth then
1672           raise (Gaveup cache.failures)
1673         else
1674         let status = NTactics.branch_tac ~force:true status in
1675         let g,gctx, gty = current_goal status in
1676         let ctx,ty = close status g in
1677         let closegty = mk_cic_term ctx ty in
1678         let status, gty = apply_subst status gctx gty in
1679         debug_print ~depth (lazy("Attacking goal " ^
1680           string_of_int g ^ " : "^ppterm status gty));
1681         debug_print ~depth (lazy ("current failures: " ^
1682           string_of_int (List.length (all_elements ctx cache.failures))));
1683         let is_eq =
1684            let _,_,metasenv,subst,_ = status#obj in
1685            NCicParamod.is_equation status metasenv subst ctx ty in
1686         (* if the goal is an equality we artificially raise its depth up to
1687            flags.maxdepth - 1 *)
1688         if (not flags.last && is_eq && (depth < (flags.maxdepth -2))) then
1689         (* for efficiency reasons, in this case we severely cripple the
1690            search depth *)
1691           (debug_print ~depth (lazy ("RAISING DEPTH TO " ^ string_of_int (depth+1)));
1692            auto_main flags signature cache (depth+1) status)
1693         (* check for loops *)
1694         else if is_subsumed depth false status closegty (snd cache.under_inspection) then
1695           (debug_print ~depth (lazy "SUBSUMED");
1696            raise (Gaveup cache.failures))
1697         (* check for failures *)
1698         else if is_subsumed depth true status closegty cache.failures then
1699           (debug_print ~depth (lazy "ALREADY MET");
1700            raise (Gaveup cache.failures))
1701         else
1702         let new_sig = height_of_goal g status in
1703         if new_sig < signature then
1704           (debug_print  ~depth (lazy ("news = " ^ (string_of_int new_sig)));
1705            debug_print  ~depth (lazy ("olds = " ^ (string_of_int signature))));
1706         let alternatives, cache =
1707           do_something signature flags status g depth gty cache in
1708         let loop_cache =
1709           if flags.last then
1710             let l,tree = cache.under_inspection in
1711             let l,tree = closegty::l, add_to_th closegty tree closegty in
1712             {cache with under_inspection = l,tree}
1713           else cache in
1714         let failures =
1715           List.fold_left
1716           (fun allfailures ((_,t),status) ->
1717              debug_print ~depth
1718                (lazy ("(re)considering goal " ^
1719                        (string_of_int g) ^" : "^ppterm status gty));
1720              debug_print (~depth:depth)
1721                (lazy ("Case: " ^ NotationPp.pp_term status t));
1722              let depth,cache =
1723                if t=Ast.Ident("__whd",None) ||
1724                   t=Ast.Ident("__intros",None)
1725                then depth, cache
1726                else depth+1,loop_cache in
1727              let cache = add_to_trace status ~depth cache t in
1728              let cache = {cache with failures = allfailures} in
1729              try
1730                auto_clusters flags signature cache depth status;
1731                assert false;
1732              with Gaveup fail ->
1733                debug_print ~depth (lazy "Failed");
1734                fail)
1735           cache.failures alternatives in
1736         let failures =
1737           if flags.last then
1738             let newfail =
1739               let dty = NCic.Appl [NCic.Implicit (`Typeof depth); ty] in
1740               mk_cic_term ctx dty
1741             in
1742             (*prerr_endline ("FAILURE : " ^ ppterm status gty);*)
1743             add_to_th newfail failures closegty
1744           else failures in
1745         debug_print ~depth (lazy "no more candidates");
1746         raise (Gaveup failures)
1747 ;;
1748
1749 let int name l def =
1750   try int_of_string (List.assoc name l)
1751   with Failure _ | Not_found -> def
1752 ;;
1753
1754 module AstSet = Set.Make(struct type t = Ast.term let compare = compare end)
1755
1756 let cleanup_trace s trace =
1757   (* removing duplicates *)
1758   let trace_set =
1759     List.fold_left
1760       (fun acc t -> AstSet.add t acc)
1761       AstSet.empty trace in
1762   let trace = AstSet.elements trace_set
1763     (* filtering facts *)
1764   in List.filter
1765        (fun t ->
1766           match t with
1767             | Ast.NRef (NReference.Ref (u,_)) -> not (is_a_fact_obj s u)
1768             | _ -> false) trace
1769 ;;
1770
1771 let auto_tac ~params:(univ,flags) ?(trace_ref=ref []) status =
1772   let oldstatus = status in
1773   let status = (status:> NTacStatus.tac_status) in
1774   let goals = head_goals status#stack in
1775   let status, facts = mk_th_cache status goals in
1776   let unit_eq = index_local_equations status#eq_cache status in
1777   let cache = init_cache ~facts ~unit_eq () in
1778 (*   pp_th status facts; *)
1779 (*
1780   NDiscriminationTree.DiscriminationTree.iter status#auto_cache (fun p t ->
1781     debug_print (lazy(
1782       NDiscriminationTree.NCicIndexable.string_of_path p ^ " |--> " ^
1783       String.concat "\n    " (List.map (
1784       status#ppterm ~metasenv:[] ~context:[] ~subst:[])
1785         (NDiscriminationTree.TermSet.elements t))
1786       )));
1787 *)
1788   let candidates =
1789     match univ with
1790       | None -> None
1791       | Some l ->
1792           let to_Ast t =
1793             let status, res = disambiguate status [] t None in
1794             let _,res = term_of_cic_term status res (ctx_of res)
1795             in Ast.NCic res
1796           in Some (List.map to_Ast l)
1797   in
1798   let depth = int "depth" flags 3 in
1799   let size  = int "size" flags 10 in
1800   let width = int "width" flags 4 (* (3+List.length goals)*) in
1801   (* XXX fix sort *)
1802 (*   let goals = List.map (fun i -> (i,P)) goals in *)
1803   let signature = height_of_goals status in
1804   let flags = {
1805           last = true;
1806           candidates = candidates;
1807           maxwidth = width;
1808           maxsize = size;
1809           maxdepth = depth;
1810           timeout = Unix.gettimeofday() +. 3000.;
1811           do_types = false;
1812   } in
1813   let initial_time = Unix.gettimeofday() in
1814   app_counter:= 0;
1815   let rec up_to x y =
1816     if x > y then
1817       (debug_print(lazy
1818         ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1819        debug_print(lazy
1820         ("Applicative nodes:"^string_of_int !app_counter));
1821        raise (Error (lazy "auto gave up", None)))
1822     else
1823       let _ = debug_print (lazy("\n\nRound "^string_of_int x^"\n")) in
1824       let flags = { flags with maxdepth = x }
1825       in
1826         try auto_clusters (~top:true) flags signature cache 0 status;assert false
1827 (*
1828         try auto_main flags signature cache 0 status;assert false
1829 *)
1830         with
1831           | Gaveup _ -> up_to (x+1) y
1832           | Proved (s,trace) ->
1833               debug_print (lazy ("proved at depth " ^ string_of_int x));
1834               List.iter (toref incr_uses statistics) trace;
1835               let trace = cleanup_trace s trace in
1836               let _ = debug_print (pptrace status trace) in
1837               let stack =
1838                 match s#stack with
1839                   | (g,t,k,f) :: rest -> (filter_open g,t,k,f):: rest
1840                   | _ -> assert false
1841               in
1842               let s = s#set_stack stack in
1843                 trace_ref := trace;
1844                 oldstatus#set_status s
1845   in
1846   let s = up_to depth depth in
1847     debug_print (print_stat status statistics);
1848     debug_print(lazy
1849         ("TIME ELAPSED:"^string_of_float(Unix.gettimeofday()-.initial_time)));
1850     debug_print(lazy
1851         ("Applicative nodes:"^string_of_int !app_counter));
1852     s
1853 ;;
1854
1855 let auto_tac ~params:(_,flags as params) ?trace_ref =
1856   if List.mem_assoc "demod" flags then
1857     demod_tac ~params
1858   else if List.mem_assoc "paramod" flags then
1859     paramod_tac ~params
1860   else if List.mem_assoc "fast_paramod" flags then
1861     fast_eq_check_tac ~params
1862   else auto_tac ~params ?trace_ref
1863 ;;
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883