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