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