Imported Upstream version 8.0pl1upstream/8.0pl1

47 files changed, 12909 insertions, 0 deletions

diff --git a/tactics/auto.ml b/tactics/auto.ml
new file mode 100644
index 00000000..d087420a
--- /dev/null
+++ b/tactics/auto.ml
@@ -0,0 +1,939 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: auto.ml,v 1.63.2.1 2004/07/16 19:30:51 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Inductive
+open Evd
+open Reduction
+open Typing
+open Pattern
+open Matching
+open Tacmach
+open Proof_type
+open Pfedit
+open Rawterm
+open Evar_refiner
+open Tacred
+open Tactics
+open Tacticals
+open Clenv
+open Hiddentac
+open Libnames
+open Nametab
+open Libobject
+open Library
+open Printer
+open Declarations
+open Tacexpr
+
+(****************************************************************************)
+(*            The Type of Constructions Autotactic Hints                    *)
+(****************************************************************************)
+
+type auto_tactic = 
+  | Res_pf     of constr * unit clausenv (* Hint Apply *)
+  | ERes_pf    of constr * unit clausenv (* Hint EApply *)
+  | Give_exact of constr                  
+  | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *)
+  | Unfold_nth of global_reference       (* Hint Unfold *)
+  | Extern     of glob_tactic_expr       (* Hint Extern *) 
+
+type pri_auto_tactic = { 
+  hname : identifier;    (* name of the hint *)
+  pri  : int;            (* A number between 0 and 4, 4 = lower priority *)
+  pat  : constr_pattern option; (* A pattern for the concl of the Goal *)
+  code : auto_tactic     (* the tactic to apply when the concl matches pat *)
+}
+
+let pri_ord {pri=pri1} {pri=pri2} = pri1 - pri2
+
+let pri_order {pri=pri1} {pri=pri2} = pri1 <= pri2
+
+let insert v l = 
+  let rec insrec = function
+    | [] -> [v]
+    | h::tl -> if pri_order v h then v::h::tl else h::(insrec tl)
+  in 
+  insrec l
+
+(* Nov 98 -- Papageno *)
+(* Les Hints sont ré-organisés en plusieurs databases. 
+
+  La table impérative "searchtable", de type "hint_db_table",
+   associe une database (hint_db) à chaque nom.
+
+  Une hint_db est une table d'association fonctionelle constr -> search_entry
+  Le constr correspond à la constante de tête de la conclusion.
+
+  Une search_entry est un triplet comprenant :
+     - la liste des tactiques qui n'ont pas de pattern associé
+     - la liste des tactiques qui ont un pattern
+     - un discrimination net borné (Btermdn.t) constitué de tous les
+       patterns de la seconde liste de tactiques *)
+
+type stored_data = pri_auto_tactic
+
+type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+
+let empty_se = ([],[],Btermdn.create ())
+
+let add_tac t (l,l',dn) =
+  match t.pat with
+      None -> (insert t l, l', dn)
+    | Some pat -> (l, insert t l', Btermdn.add dn (pat,t))
+
+
+let lookup_tacs (hdc,c) (l,l',dn) =
+  let l'  = List.map snd (Btermdn.lookup dn c) in
+  let sl' = Sort.list pri_order l' in
+    Sort.merge pri_order l sl'
+
+
+module Constr_map = Map.Make(struct 
+			       type t = constr_label
+			       let compare = Pervasives.compare 
+			     end)
+
+module Hint_db = struct
+
+  type t = search_entry Constr_map.t
+
+  let empty = Constr_map.empty
+
+  let find key db =
+    try Constr_map.find key db
+    with Not_found -> empty_se
+
+  let map_all k db =
+    let (l,l',_) = find k db in
+      Sort.merge pri_order l l'
+   
+  let map_auto (k,c) db =
+    lookup_tacs (k,c) (find k db)
+
+  let add_one (k,v) db =
+    let oval = find k db in 
+      Constr_map.add k (add_tac v oval) db
+
+  let add_list l db = List.fold_right add_one l db
+
+  let iter f db = Constr_map.iter (fun k (l,l',_) -> f k (l@l')) db
+
+end
+
+type frozen_hint_db_table = Hint_db.t Stringmap.t 
+
+type hint_db_table = Hint_db.t Stringmap.t ref
+
+type hint_db_name = string
+
+let searchtable = (ref Stringmap.empty : hint_db_table)
+
+let searchtable_map name = 
+  Stringmap.find name !searchtable
+let searchtable_add (name,db) = 
+  searchtable := Stringmap.add name db !searchtable
+
+(**************************************************************************)
+(*                       Definition of the summary                        *)
+(**************************************************************************)
+
+let init     () = searchtable := Stringmap.empty
+let freeze   () = !searchtable
+let unfreeze fs = searchtable := fs
+
+let _ = Summary.declare_summary "search"
+	  { Summary.freeze_function   = freeze;
+	    Summary.unfreeze_function = unfreeze;
+	    Summary.init_function     = init;
+	    Summary.survive_module = false;
+	    Summary.survive_section   = false }
+
+ 
+(**************************************************************************)
+(*             Auxiliary functions to prepare AUTOHINT objects            *)
+(**************************************************************************)
+
+let rec nb_hyp c = match kind_of_term c with
+  | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2
+  | _ -> 0 
+
+(* adding and removing tactics in the search table *)
+
+let try_head_pattern c = 
+  try head_pattern_bound c
+  with BoundPattern -> error "Bound head variable"
+
+let make_exact_entry name (c,cty) =
+  let cty = strip_outer_cast cty in
+  match kind_of_term cty with
+    | Prod (_,_,_) -> 
+	failwith "make_exact_entry"
+    | _ ->
+	(head_of_constr_reference (List.hd (head_constr cty)),
+	   { hname=name; pri=0; pat=None; code=Give_exact c })
+
+let make_apply_entry env sigma (eapply,verbose) name (c,cty) =
+  let cty = hnf_constr env sigma cty in
+  match kind_of_term cty with
+    | Prod _ ->
+        let ce = mk_clenv_from () (c,cty) in
+	let c' = (clenv_template_type ce).rebus in
+	let pat = Pattern.pattern_of_constr c' in
+        let hd = (try head_pattern_bound pat
+                  with BoundPattern -> failwith "make_apply_entry") in
+        let nmiss = List.length (clenv_missing ce) 
+        in 
+	if eapply & (nmiss <> 0) then begin
+          if verbose then 
+	    warn (str "the hint: EApply " ++ prterm c ++
+		    str " will only be used by EAuto"); 
+          (hd,
+           { hname = name;
+	     pri = nb_hyp cty + nmiss;
+             pat = Some pat;
+             code = ERes_pf(c,ce) })
+        end else 
+	  (hd,
+           { hname = name;
+	     pri = nb_hyp cty;
+             pat = Some pat;
+             code = Res_pf(c,ce) })
+    | _ -> failwith "make_apply_entry"
+ 
+(* eap is (e,v) with e=true if eapply and v=true if verbose 
+   c is a constr
+   cty is the type of constr *)
+
+let make_resolves env sigma name eap (c,cty) =
+  let ents = 
+    map_succeed 
+      (fun f -> f name (c,cty)) 
+      [make_exact_entry; make_apply_entry env sigma eap]
+  in 
+  if ents = [] then 
+    errorlabstrm "Hint" (prterm c ++ spc () ++ str "cannot be used as a hint");
+  ents
+
+(* used to add an hypothesis to the local hint database *)
+let make_resolve_hyp env sigma (hname,_,htyp) = 
+  try
+    [make_apply_entry env sigma (true, false) hname
+       (mkVar hname,  htyp)]
+  with 
+    | Failure _ -> []
+    | e when Logic.catchable_exception e -> anomaly "make_resolve_hyp"
+
+(* REM : in most cases hintname = id *)
+let make_unfold (hintname, ref) =
+  (Pattern.label_of_ref ref,
+   { hname = hintname;
+     pri = 4;
+     pat = None;
+     code = Unfold_nth ref })
+
+let make_extern name pri pat tacast = 
+  let hdconstr = try_head_pattern pat in 
+  (hdconstr,
+   { hname = name;
+     pri=pri;
+     pat = Some pat;
+     code= Extern tacast })
+
+let make_trivial env sigma (name,c) =
+  let t = hnf_constr env sigma (type_of env sigma c) in
+  let hd = head_of_constr_reference (List.hd (head_constr t)) in
+  let ce = mk_clenv_from () (c,t) in
+  (hd, { hname = name;
+	       pri=1;
+               pat = Some (Pattern.pattern_of_constr (clenv_template_type ce).rebus);
+               code=Res_pf_THEN_trivial_fail(c,ce) })
+
+open Vernacexpr
+
+(**************************************************************************)
+(*               declaration of the AUTOHINT library object               *)
+(**************************************************************************)
+
+(* If the database does not exist, it is created *)
+(* TODO: should a warning be printed in this case ?? *)
+let add_hint dbname hintlist = 
+  try 
+    let db = searchtable_map dbname in
+    let db' = Hint_db.add_list hintlist db in
+    searchtable_add (dbname,db')
+  with Not_found -> 
+    let db = Hint_db.add_list hintlist Hint_db.empty in
+    searchtable_add (dbname,db)
+
+let cache_autohint (_,(local,name,hintlist)) = add_hint name hintlist
+
+(*  let recalc_hints hintlist =
+    let env = Global.env() and sigma = Evd.empty in
+    let recalc_hint ((_,data) as hint) =
+      match data.code with
+	| Res_pf (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_apply_entry env sigma (false,false) 
+		  data.hname (c', type_of env sigma c')
+	| ERes_pf (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_apply_entry env sigma (true,false) 
+		  data.hname (c', type_of env sigma c')
+	| Give_exact c ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_exact_entry data.hname (c',type_of env sigma c')
+	| Res_pf_THEN_trivial_fail (c,_) ->
+	    let c' = Term.subst_mps subst c in
+	      if c==c' then hint else
+		make_trivial env sigma (data.hname,c')
+	| Unfold_nth ref -> 
+	    let ref' = subst_global subst ref in
+	      if ref==ref' then hint else
+		make_unfold (data.hname,ref')
+	| Extern _ ->
+	    anomaly "Extern hints cannot be substituted!!!"
+    in
+      list_smartmap recalc_hint hintlist
+*)
+
+let forward_subst_tactic = 
+  ref (fun _ -> failwith "subst_tactic is not installed for Auto")
+
+let set_extern_subst_tactic f = forward_subst_tactic := f
+
+let subst_autohint (_,subst,(local,name,hintlist as obj)) = 
+  let trans_clenv clenv = Clenv.subst_clenv (fun _ a -> a) subst clenv in
+  let trans_data data code = 	      
+    { data with
+	pat = option_smartmap (subst_pattern subst) data.pat ;
+	code = code ;
+    }
+  in
+  let subst_hint (lab,data as hint) =
+    let lab' = subst_label subst lab in
+    let data' = match data.code with
+      | Res_pf (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (Res_pf (c', trans_clenv clenv))
+      | ERes_pf (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (ERes_pf (c', trans_clenv clenv))
+      | Give_exact c ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      trans_data data (Give_exact c')
+      | Res_pf_THEN_trivial_fail (c, clenv) ->
+	  let c' = Term.subst_mps subst c in
+	    if c==c' then data else
+	      let code' = Res_pf_THEN_trivial_fail (c', trans_clenv clenv) in
+		trans_data data code'
+      | Unfold_nth ref -> 
+	  let ref' = subst_global subst ref in
+	    if ref==ref' then data else
+	      trans_data data (Unfold_nth ref')
+      | Extern tac ->
+	  let tac' = !forward_subst_tactic subst tac in
+	    if tac==tac' then data else
+	      trans_data data (Extern tac')
+    in
+      if lab' == lab && data' == data then hint else
+	(lab',data')
+  in
+  let hintlist' = list_smartmap subst_hint hintlist in
+    if hintlist' == hintlist then obj else
+      (local,name,hintlist')
+
+let classify_autohint (_,((local,name,hintlist) as obj)) =
+  if local or hintlist = [] then Dispose else Substitute obj
+
+let export_autohint ((local,name,hintlist) as obj) =
+  if local then None else Some obj
+
+let (inAutoHint,outAutoHint) =
+  declare_object {(default_object "AUTOHINT") with
+                    cache_function = cache_autohint;
+		    load_function = (fun _ -> cache_autohint);
+		    subst_function = subst_autohint;
+		    classify_function = classify_autohint;
+                    export_function = export_autohint }
+
+
+(**************************************************************************)
+(*                     The "Hint" vernacular command                      *)
+(**************************************************************************)
+let add_resolves env sigma clist local dbnames =
+  List.iter 
+    (fun dbname ->
+       Lib.add_anonymous_leaf
+	 (inAutoHint
+	    (local,dbname,
+     	     List.flatten
+	       (List.map
+		  (fun (name,c) -> 
+		     let ty = type_of env sigma c in
+		     let verbose = Options.is_verbose() in
+		       make_resolves env sigma name (true,verbose) (c,ty)) clist
+	       )
+	    )))
+    dbnames
+
+
+let add_unfolds l local dbnames =
+  List.iter 
+    (fun dbname -> Lib.add_anonymous_leaf 
+       (inAutoHint (local,dbname, List.map make_unfold l)))
+    dbnames
+
+
+let add_extern name pri (patmetas,pat) tacast local dbname =
+  (* We check that all metas that appear in tacast have at least
+     one occurence in the left pattern pat *)
+(* TODO
+  let tacmetas = Coqast.collect_metas tacast in
+*)
+  let tacmetas = [] in
+  match (list_subtract tacmetas patmetas) with
+    | i::_ ->
+	errorlabstrm "add_extern" 
+	  (str "The meta-variable ?" ++ pr_patvar i ++ str" is not bound")
+    | []  ->
+	Lib.add_anonymous_leaf
+	  (inAutoHint(local,dbname, [make_extern name pri pat tacast]))
+
+let add_externs name pri pat tacast local dbnames = 
+  List.iter (add_extern name pri pat tacast local) dbnames
+
+let add_trivials env sigma l local dbnames =
+  List.iter
+    (fun dbname ->
+       Lib.add_anonymous_leaf (
+	 inAutoHint(local,dbname, List.map (make_trivial env sigma) l)))
+    dbnames
+
+let forward_intern_tac = 
+  ref (fun _ -> failwith "intern_tac is not installed for Auto")
+
+let set_extern_intern_tac f = forward_intern_tac := f
+
+let add_hints local dbnames0 h =
+  let dbnames = if dbnames0 = [] then ["core"] else dbnames0 in
+  match h with
+  | HintsResolve lhints ->	
+      let env = Global.env() and sigma = Evd.empty in
+      let f (n,c) =
+	let c = Constrintern.interp_constr sigma env c in
+	let n = match n with
+	  | None -> (*id_of_global (reference_of_constr c)*)
+              id_of_string "<anonymous hint>"
+	  | Some n -> n in
+	(n,c) in
+      add_resolves env sigma (List.map f lhints) local dbnames
+  | HintsImmediate lhints ->
+      let env = Global.env() and sigma = Evd.empty in
+      let f (n,c) = 
+	let c = Constrintern.interp_constr sigma env c in
+	let n = match n with
+	  | None -> (*id_of_global (reference_of_constr c)*)
+              id_of_string "<anonymous hint>"
+	  | Some n -> n in
+	(n,c) in
+      add_trivials env sigma (List.map f lhints) local dbnames
+  | HintsUnfold lhints ->
+      let f (n,locqid) =
+	let r = Nametab.global locqid in
+	let n = match n with
+	  | None -> id_of_global r
+	  | Some n -> n in
+	(n,r) in
+      add_unfolds (List.map f lhints) local dbnames
+  | HintsConstructors (hintname, lqid) ->
+      let add_one qid =
+        let env = Global.env() and sigma = Evd.empty in
+        let isp = global_inductive qid in
+        let consnames = (snd (Global.lookup_inductive isp)).mind_consnames in
+        let lcons = list_tabulate
+          (fun i -> mkConstruct (isp,i+1)) (Array.length consnames) in
+        let lcons = List.map2
+          (fun id c -> (id,c)) (Array.to_list consnames) lcons in
+        add_resolves env sigma lcons local dbnames in
+      List.iter add_one lqid
+  | HintsExtern (hintname, pri, patcom, tacexp) ->
+      let hintname = match hintname with
+          Some h -> h
+        | _ -> id_of_string "<anonymous hint>" in
+      let pat =	Constrintern.interp_constrpattern Evd.empty (Global.env()) patcom in
+      let tacexp = !forward_intern_tac (fst pat) tacexp in
+      add_externs hintname pri pat tacexp local dbnames
+  | HintsDestruct(na,pri,loc,pat,code) ->
+      if dbnames0<>[] then
+        warn (str"Database selection not implemented for destruct hints");
+      Dhyp.add_destructor_hint local na loc pat pri code
+
+(**************************************************************************)
+(*                    Functions for printing the hints                    *)
+(**************************************************************************)
+
+let fmt_autotactic = function
+  | Res_pf (c,clenv) -> (str"Apply " ++ prterm c)
+  | ERes_pf (c,clenv) -> (str"EApply " ++ prterm c)
+  | Give_exact c -> (str"Exact " ++ prterm c)
+  | Res_pf_THEN_trivial_fail (c,clenv) -> 
+      (str"Apply " ++ prterm c ++ str" ; Trivial")
+  | Unfold_nth c -> (str"Unfold " ++  pr_global c)
+  | Extern tac -> (str "Extern " ++ Pptactic.pr_glob_tactic tac)
+
+let fmt_hint v =
+  (fmt_autotactic v.code ++ str"(" ++ int v.pri ++ str")" ++ spc ())
+
+let fmt_hint_list hintlist =
+  (str "  " ++ hov 0 (prlist fmt_hint hintlist) ++ fnl ())
+
+let fmt_hints_db (name,db,hintlist) =
+  (str "In the database " ++ str name ++ str ":" ++
+     if hintlist = [] then (str " nothing" ++ fnl ())
+     else (fnl () ++ fmt_hint_list hintlist))
+
+(* Print all hints associated to head c in any database *)
+let fmt_hint_list_for_head c = 
+  let dbs = stringmap_to_list !searchtable in
+  let valid_dbs = 
+    map_succeed 
+      (fun (name,db) -> (name,db,Hint_db.map_all c db)) 
+      dbs 
+  in
+  if valid_dbs = [] then 
+    (str "No hint declared for :" ++ pr_ref_label c)
+  else 
+    hov 0 
+      (str"For " ++ pr_ref_label c ++ str" -> " ++ fnl () ++
+	 hov 0 (prlist fmt_hints_db valid_dbs))
+
+let fmt_hint_ref ref = fmt_hint_list_for_head (label_of_ref ref)
+
+(* Print all hints associated to head id in any database *)
+let print_hint_ref ref =  ppnl(fmt_hint_ref ref)
+
+let fmt_hint_term cl = 
+  try 
+    let (hdc,args) = match head_constr_bound cl [] with 
+      | hdc::args -> (hdc,args)
+      | [] -> assert false 
+    in
+    let hd = head_of_constr_reference hdc in
+    let dbs = stringmap_to_list !searchtable in
+    let valid_dbs = 
+      if occur_existential cl then 
+	map_succeed 
+	  (fun (name, db) -> (name, db, Hint_db.map_all hd db)) 
+	  dbs
+      else 
+	map_succeed 
+	  (fun (name, db) -> 
+	     (name, db, Hint_db.map_auto (hd,applist(hdc,args)) db)) 
+	  dbs
+    in 
+    if valid_dbs = [] then 
+      (str "No hint applicable for current goal")
+    else
+      (str "Applicable Hints :" ++ fnl () ++
+	 hov 0 (prlist fmt_hints_db valid_dbs))
+  with Bound | Match_failure _ | Failure _ -> 
+    (str "No hint applicable for current goal")
+	  
+let print_hint_term cl = ppnl (fmt_hint_term cl)
+
+(* print all hints that apply to the concl of the current goal *)
+let print_applicable_hint () = 
+  let pts = get_pftreestate () in 
+  let gl = nth_goal_of_pftreestate 1 pts in 
+  print_hint_term (pf_concl gl)
+    
+(* displays the whole hint database db *)
+let print_hint_db db =
+  Hint_db.iter 
+    (fun head hintlist ->
+       msg (hov 0 
+	      (str "For " ++ pr_ref_label head ++ str " -> " ++
+		 fmt_hint_list hintlist)))
+    db
+
+let print_hint_db_by_name dbname =
+  try 
+    let db = searchtable_map dbname in print_hint_db db
+  with Not_found -> 
+    error (dbname^" : No such Hint database")
+  
+(* displays all the hints of all databases *)
+let print_searchtable () =
+  Stringmap.iter
+    (fun name db ->
+       msg (str "In the database " ++ str name ++ fnl ());
+       print_hint_db db)
+    !searchtable
+
+(**************************************************************************)
+(*                           Automatic tactics                            *)
+(**************************************************************************)
+
+(**************************************************************************)
+(*          tactics with a trace mechanism for automatic search           *)
+(**************************************************************************)
+
+let priority l = List.map snd (List.filter (fun (pr,_) -> pr = 0) l)
+
+
+(* Try unification with the precompiled clause, then use registered Apply *)
+
+let unify_resolve (c,clenv) gls = 
+  let (wc,kONT) = startWalk gls in
+  let clenv' = connect_clenv wc clenv in
+  let _ = clenv_unique_resolver false clenv' gls in  
+  h_simplest_apply c gls
+
+(* builds a hint database from a constr signature *)
+(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
+
+let make_local_hint_db g = 
+  let sign = pf_hyps g in
+  let hintlist = list_map_append (make_resolve_hyp (pf_env g) (project g)) sign
+  in Hint_db.add_list hintlist Hint_db.empty
+
+
+(* Serait-ce possible de compiler d'abord la tactique puis de faire la
+   substitution sans passer par bdize dont l'objectif est de préparer un
+   terme pour l'affichage ? (HH) *)
+
+(* Si on enlève le dernier argument (gl) conclPattern est calculé une
+fois pour toutes : en particulier si Pattern.somatch produit une UserError 
+Ce qui fait que si la conclusion ne matche pas le pattern, Auto échoue, même
+si après Intros la conclusion matche le pattern.
+*)
+
+(* conclPattern doit échouer avec error car il est rattraper par tclFIRST *)
+
+let forward_interp_tactic = 
+  ref (fun _ -> failwith "interp_tactic is not installed for Auto")
+
+let set_extern_interp f = forward_interp_tactic := f
+
+let conclPattern concl pat tac gl =
+  let constr_bindings =
+    try matches pat concl
+    with PatternMatchingFailure -> error "conclPattern" in
+  !forward_interp_tactic constr_bindings tac gl
+
+(**************************************************************************)
+(*                           The Trivial tactic                           *)
+(**************************************************************************)
+
+(* local_db is a Hint database containing the hypotheses of current goal *)
+(* Papageno : cette fonction a été pas mal simplifiée depuis que la base
+  de Hint impérative a été remplacée par plusieurs bases fonctionnelles *)
+
+let rec trivial_fail_db db_list local_db gl =
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g'->
+	 let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	 in trivial_fail_db db_list (Hint_db.add_list hintl local_db) g')
+  in
+  tclFIRST 
+    (assumption::intro_tac::
+     (List.map tclCOMPLETE 
+	(trivial_resolve db_list local_db (pf_concl gl)))) gl
+
+and my_find_search db_list local_db hdc concl =
+  let tacl = 
+    if occur_existential concl then 
+      list_map_append (fun db -> Hint_db.map_all hdc db) (local_db::db_list)
+    else 
+      list_map_append (fun db -> Hint_db.map_auto (hdc,concl) db)
+      	(local_db::db_list)
+  in
+  List.map 
+    (fun ({pri=b; pat=p; code=t} as patac) -> 
+       (b,
+	match t with
+	  | Res_pf (term,cl)  -> unify_resolve (term,cl)
+	  | ERes_pf (_,c) -> (fun gl -> error "eres_pf")
+	  | Give_exact c  -> exact_check c
+	  | Res_pf_THEN_trivial_fail (term,cl) -> 
+	      tclTHEN 
+		(unify_resolve (term,cl)) 
+		(trivial_fail_db db_list local_db)
+	  | Unfold_nth c -> unfold_constr c
+	  | Extern tacast -> 
+	      conclPattern concl (out_some p) tacast))
+    tacl
+
+and trivial_resolve db_list local_db cl = 
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    priority 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+let trivial dbnames gl =
+  let db_list = 
+    List.map
+      (fun x -> 
+	 try 
+	   searchtable_map x
+	 with Not_found -> 
+	   error ("Trivial: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl 
+    
+let full_trivial gl =
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames = list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  tclTRY (trivial_fail_db db_list (make_local_hint_db gl)) gl
+
+let gen_trivial = function
+  | None -> full_trivial
+  | Some l -> trivial l
+
+let h_trivial l = Refiner.abstract_tactic (TacTrivial l) (gen_trivial l)
+
+(**************************************************************************)
+(*                       The classical Auto tactic                        *)
+(**************************************************************************)
+
+let possible_resolve db_list local_db cl =
+  try 
+    let hdconstr = List.hd (head_constr_bound cl []) in
+    List.map snd 
+      (my_find_search db_list local_db (head_of_constr_reference hdconstr) cl)
+  with Bound | Not_found -> 
+    []
+
+let decomp_unary_term c gls = 
+  let typc = pf_type_of gls c in 
+  let hd = List.hd (head_constr typc) in 
+  if Hipattern.is_conjunction hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_unary_term" (str "not a unary type") 
+
+let decomp_empty_term c gls = 
+  let typc = pf_type_of gls c in 
+  let (hd,_) = decompose_app typc in 
+  if Hipattern.is_empty_type hd then 
+    simplest_case c gls 
+  else 
+    errorlabstrm "Auto.decomp_empty_term" (str "not an empty type") 
+
+
+(* decomp is an natural number giving an indication on decomposition 
+   of conjunction in hypotheses, 0 corresponds to no decomposition *)
+(* n is the max depth of search *)
+(* local_db contains the local Hypotheses *)
+
+let rec search_gen decomp n db_list local_db extra_sign goal =
+  if n=0 then error "BOUND 2";
+  let decomp_tacs = match decomp with 
+    | 0 -> [] 
+    | p -> 
+	(tclTRY_sign decomp_empty_term extra_sign)
+	::
+	(List.map 
+	   (fun id -> tclTHENSEQ
+               [decomp_unary_term (mkVar id);
+                clear [id];
+		search_gen decomp p db_list local_db []])
+	   (pf_ids_of_hyps goal)) 
+  in
+  let intro_tac = 
+    tclTHEN intro 
+      (fun g' -> 
+	 let (hid,_,htyp as d) = pf_last_hyp g' in
+	 let hintl = 
+	   try 
+	     [make_apply_entry (pf_env g') (project g')
+		(true,false) 
+		hid (mkVar hid, htyp)]
+	   with Failure _ -> [] 
+	 in
+         search_gen decomp n db_list (Hint_db.add_list hintl local_db) [d] g') 
+  in
+  let rec_tacs = 
+    List.map 
+      (fun ntac -> 
+	 tclTHEN ntac
+	   (search_gen decomp (n-1) db_list local_db empty_named_context))
+      (possible_resolve db_list local_db (pf_concl goal))
+  in 
+  tclFIRST (assumption::(decomp_tacs@(intro_tac::rec_tacs))) goal
+
+
+let search = search_gen 0
+
+let default_search_depth = ref 5
+			     
+let auto n dbnames gl = 
+  let db_list = 
+    List.map
+      (fun x -> 
+	 try 
+	   searchtable_map x
+	 with Not_found -> 
+	   error ("Auto: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  let hyps = pf_hyps gl in
+  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+
+let default_auto = auto !default_search_depth []
+
+let full_auto n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames = list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> searchtable_map x) dbnames in
+  let hyps = pf_hyps gl in
+  tclTRY (search n db_list (make_local_hint_db gl) hyps) gl
+  
+let default_full_auto gl = full_auto !default_search_depth gl
+
+let gen_auto n dbnames =
+  let n = match n with None -> !default_search_depth | Some n -> n in
+  match dbnames with
+  | None -> full_auto n
+  | Some l -> auto n l
+
+let h_auto n l = Refiner.abstract_tactic (TacAuto (n,l)) (gen_auto n l)
+
+(**************************************************************************)
+(*                  The "destructing Auto" from Eduardo                   *)
+(**************************************************************************)
+
+(* Depth of search after decomposition of hypothesis, by default 
+   one look for an immediate solution *) 
+(* Papageno : de toute façon un paramète > 1 est traité comme 1 pour 
+   l'instant *)
+let default_search_decomp = ref 1
+
+let destruct_auto des_opt n gl = 
+  let hyps = pf_hyps gl in
+  search_gen des_opt n [searchtable_map "core"] 
+    (make_local_hint_db gl) hyps gl
+    
+let dautomatic des_opt n = tclTRY (destruct_auto des_opt n)
+
+let default_dauto = dautomatic !default_search_decomp !default_search_depth
+
+let dauto = function
+  | None, None     -> default_dauto
+  | Some n, None   -> dautomatic !default_search_decomp n
+  | Some n, Some p -> dautomatic p n
+  | None, Some p   -> dautomatic p !default_search_depth
+
+let h_dauto (n,p) = Refiner.abstract_tactic (TacDAuto (n,p)) (dauto (n,p))
+
+(***************************************)
+(*** A new formulation of Auto *********)
+(***************************************)
+
+type autoArguments =
+  | UsingTDB       
+  | Destructing   
+
+let keepAfter tac1 tac2 = 
+  (tclTHEN tac1 
+     (function g -> tac2 [pf_last_hyp g] g))
+
+let compileAutoArg contac = function
+  | Destructing -> 
+      (function g -> 
+         let ctx = pf_hyps g in  
+	 tclFIRST 
+           (List.map 
+              (fun (id,_,typ) -> 
+                let cl = snd (decompose_prod typ) in
+                 if Hipattern.is_conjunction cl
+		 then 
+		   tclTHENSEQ [simplest_elim (mkVar id); clear [id]; contac] 
+                 else 
+		   tclFAIL 0 ((string_of_id id)^"is not a conjunction"))
+	     ctx) g)
+  | UsingTDB ->  
+      (tclTHEN  
+         (Tacticals.tryAllClauses 
+            (function 
+               | Some (id,_,_) -> Dhyp.h_destructHyp false id
+               | None          -> Dhyp.h_destructConcl))
+         contac)
+
+let compileAutoArgList contac = List.map (compileAutoArg contac)
+
+let rec super_search n db_list local_db argl goal =
+  if n = 0 then error "BOUND 2";
+  tclFIRST
+    (assumption
+     ::
+     (tclTHEN intro 
+        (fun g -> 
+	   let (hid,_,htyp) = pf_last_hyp g in
+	   let hintl =
+	     make_resolves (pf_env g) (project g)
+	       hid (true,false) (mkVar hid, htyp) in
+	   super_search n db_list (Hint_db.add_list hintl local_db)
+	     argl g))
+     ::
+     ((List.map 
+         (fun ntac -> 
+            tclTHEN ntac 
+              (super_search (n-1) db_list local_db argl))
+         (possible_resolve db_list local_db (pf_concl goal)))
+      @
+      (compileAutoArgList  
+         (super_search (n-1) db_list local_db argl) argl))) goal
+
+let search_superauto n to_add argl g = 
+  let sigma =
+    List.fold_right
+      (fun (id,c) -> add_named_decl (id, None, pf_type_of g c))
+      to_add empty_named_context in
+  let db0 = list_map_append (make_resolve_hyp (pf_env g) (project g)) sigma in
+  let db = Hint_db.add_list db0 (make_local_hint_db g) in
+  super_search n [Stringmap.find "core" !searchtable] db argl g
+
+let superauto n to_add argl  = 
+  tclTRY (tclCOMPLETE (search_superauto n to_add argl))
+
+let default_superauto g = superauto !default_search_depth [] [] g
+
+let interp_to_add gl locqid =
+  let r = Nametab.global locqid in
+  let id = id_of_global r in
+  (next_ident_away id (pf_ids_of_hyps gl), constr_of_reference r)
+
+let gen_superauto nopt l a b gl =
+  let n = match nopt with Some n -> n | None -> !default_search_depth in
+  let al = (if a then [Destructing] else [])@(if b then [UsingTDB] else []) in
+  superauto n (List.map (interp_to_add gl) l) al gl
+
+let h_superauto no l a b =
+  Refiner.abstract_tactic (TacSuperAuto (no,l,a,b)) (gen_superauto no l a b)
+
diff --git a/tactics/auto.mli b/tactics/auto.mli
new file mode 100644
index 00000000..ef6b85ea
--- /dev/null
+++ b/tactics/auto.mli
@@ -0,0 +1,197 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: auto.mli,v 1.22.2.1 2004/07/16 19:30:51 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Proof_type
+open Tacmach
+open Clenv
+open Pattern
+open Environ
+open Evd
+open Libnames
+open Vernacexpr
+(*i*)
+  
+type auto_tactic = 
+  | Res_pf     of constr * unit clausenv    (* Hint Apply *)
+  | ERes_pf    of constr * unit clausenv    (* Hint EApply *)
+  | Give_exact of constr                  
+  | Res_pf_THEN_trivial_fail of constr * unit clausenv (* Hint Immediate *)
+  | Unfold_nth of global_reference          (* Hint Unfold *)
+  | Extern     of Tacexpr.glob_tactic_expr   (* Hint Extern *)
+
+open Rawterm
+
+type pri_auto_tactic = { 
+  hname : identifier;     (* name of the hint *)
+  pri   : int;            (* A number between 0 and 4, 4 = lower priority *)
+  pat   : constr_pattern option; (* A pattern for the concl of the Goal *)
+  code  : auto_tactic;    (* the tactic to apply when the concl matches pat *)
+}
+
+type stored_data = pri_auto_tactic 
+
+type search_entry = stored_data list * stored_data list * stored_data Btermdn.t
+
+module Hint_db :
+  sig
+    type t
+    val empty : t
+    val find : constr_label -> t -> search_entry
+    val map_all : constr_label -> t -> pri_auto_tactic list
+    val map_auto : constr_label * constr -> t -> pri_auto_tactic list
+    val add_one : constr_label * pri_auto_tactic -> t -> t
+    val add_list : (constr_label * pri_auto_tactic) list -> t -> t
+    val iter : (constr_label -> stored_data list -> unit) -> t -> unit
+  end
+
+type frozen_hint_db_table = Hint_db.t Stringmap.t
+
+type hint_db_table = Hint_db.t Stringmap.t ref
+
+type hint_db_name = string
+
+val add_hints : locality_flag -> hint_db_name list -> hints -> unit
+
+val print_searchtable : unit -> unit
+
+val print_applicable_hint : unit -> unit
+
+val print_hint_ref : global_reference -> unit
+
+val print_hint_db_by_name : hint_db_name -> unit
+
+val searchtable : hint_db_table
+
+(* [make_exact_entry hint_name (c, ctyp)]. 
+   [hint_name] is the name of then hint;
+   [c] is the term given as an exact proof to solve the goal;
+   [ctyp] is the type of [hc]. *)
+
+val make_exact_entry :
+  identifier -> constr * constr -> constr_label * pri_auto_tactic
+
+(* [make_apply_entry (eapply,verbose) name (c,cty)].
+   [eapply] is true if this hint will be used only with EApply;
+   [name] is the name of then hint;
+   [c] is the term given as an exact proof to solve the goal;
+   [cty] is the type of [hc]. *)
+
+val make_apply_entry :
+  env -> evar_map -> bool * bool -> identifier -> constr * constr
+      -> constr_label * pri_auto_tactic
+
+(* A constr which is Hint'ed will be:
+   (1) used as an Exact, if it does not start with a product
+   (2) used as an Apply, if its HNF starts with a product, and
+       has no missing arguments.
+   (3) used as an EApply, if its HNF starts with a product, and
+       has missing arguments. *)
+
+val make_resolves :
+  env -> evar_map -> identifier -> bool * bool -> constr * constr -> 
+    (constr_label * pri_auto_tactic) list
+
+(* [make_resolve_hyp hname htyp].
+   used to add an hypothesis to the local hint database;
+   Never raises an User_exception;
+   If the hyp cannot be used as a Hint, the empty list is returned. *)
+
+val make_resolve_hyp : 
+  env -> evar_map -> named_declaration ->
+      (constr_label * pri_auto_tactic) list
+
+(* [make_extern name pri pattern tactic_expr] *)
+
+val make_extern :
+  identifier -> int -> constr_pattern -> Tacexpr.glob_tactic_expr
+      -> constr_label * pri_auto_tactic
+
+val set_extern_interp :
+  (patvar_map -> Tacexpr.glob_tactic_expr -> tactic) -> unit
+
+val set_extern_intern_tac :
+  (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr)
+  -> unit
+
+val set_extern_subst_tactic :
+  (Names.substitution -> Tacexpr.glob_tactic_expr -> Tacexpr.glob_tactic_expr)
+  -> unit
+
+(* Create a Hint database from the pairs (name, constr).
+   Useful to take the current goal hypotheses as hints *)
+
+val make_local_hint_db : goal sigma -> Hint_db.t
+
+val priority : (int * 'a) list -> 'a list
+
+val default_search_depth : int ref
+
+(* Try unification with the precompiled clause, then use registered Apply *)
+val unify_resolve : (constr * unit clausenv) -> tactic
+
+(* [ConclPattern concl pat tacast]:
+   if the term concl matches the pattern pat, (in sense of 
+   [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the
+   right values to build a tactic *)
+
+val conclPattern : constr -> constr_pattern -> Tacexpr.glob_tactic_expr -> tactic
+
+(* The Auto tactic *)
+
+val auto : int -> hint_db_name list -> tactic
+
+(* auto with default search depth and with the hint database "core" *)
+val default_auto : tactic
+
+(* auto with all hint databases except the "v62" compatibility database *)
+val full_auto : int -> tactic
+
+(* auto with default search depth and with all hint databases 
+   except the "v62" compatibility database *)
+val default_full_auto : tactic
+
+(* The generic form of auto (second arg [None] means all bases) *)
+val gen_auto : int option -> hint_db_name list option -> tactic
+
+(* The hidden version of auto *)
+val h_auto   : int option -> hint_db_name list option -> tactic
+
+(* Trivial *)
+val trivial : hint_db_name list -> tactic
+val gen_trivial : hint_db_name list option -> tactic
+val full_trivial : tactic
+val h_trivial : hint_db_name list option -> tactic
+
+val fmt_autotactic : auto_tactic -> Pp.std_ppcmds
+
+(*s The following is not yet up to date -- Papageno. *)
+
+(* DAuto *)
+val dauto : int option * int option -> tactic
+val default_search_decomp : int ref
+val default_dauto : tactic
+
+val h_dauto : int option * int option -> tactic
+(* SuperAuto *)
+
+type autoArguments =
+  | UsingTDB       
+  | Destructing   
+
+(*
+val superauto : int -> (identifier * constr) list -> autoArguments list -> tactic
+*)
+
+val h_superauto : int option -> reference list -> bool -> bool -> tactic
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
new file mode 100644
index 00000000..7c134b89
--- /dev/null
+++ b/tactics/autorewrite.ml
@@ -0,0 +1,105 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+open Ast
+open Coqast
+open Equality
+open Hipattern
+open Names
+open Pp
+open Proof_type
+open Tacticals
+open Tacinterp
+open Tactics
+open Term
+open Util
+open Vernacinterp
+open Tacexpr
+
+(* Rewriting rules *)
+type rew_rule = constr * bool * tactic
+
+(* Summary and Object declaration *)
+let rewtab =
+  ref (Stringmap.empty : rew_rule list Stringmap.t)
+
+let _ = 
+  let init () = rewtab := Stringmap.empty in
+  let freeze () = !rewtab in
+  let unfreeze fs = rewtab := fs in
+  Summary.declare_summary "autorewrite"
+    { Summary.freeze_function   = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function     = init;
+      Summary.survive_module = false;
+      Summary.survive_section   = false }
+
+(* Rewriting rules before tactic interpretation *)
+type raw_rew_rule = constr * bool * raw_tactic_expr
+
+(* Applies all the rules of one base *)
+let one_base tac_main bas =
+  let lrul = 
+    try 
+      Stringmap.find bas !rewtab
+    with Not_found -> 
+      errorlabstrm "AutoRewrite" 
+        (str ("Rewriting base "^(bas)^" does not exist"))
+  in
+    tclREPEAT_MAIN (tclPROGRESS (List.fold_left (fun tac (csr,dir,tc) ->
+      tclTHEN tac
+        (tclREPEAT_MAIN 
+	  (tclTHENSFIRSTn (general_rewrite dir csr) [|tac_main|] tc)))
+      tclIDTAC lrul))
+
+(* The AutoRewrite tactic *)
+let autorewrite tac_main lbas =
+  tclREPEAT_MAIN (tclPROGRESS
+    (List.fold_left (fun tac bas -> 
+       tclTHEN tac (one_base tac_main bas)) tclIDTAC lbas))
+
+(* Functions necessary to the library object declaration *)
+let cache_hintrewrite (_,(rbase,lrl)) =
+  let l = List.rev_map (fun (c,b,t) -> (c,b,Tacinterp.eval_tactic t)) lrl in
+  let l = 
+    try 
+      List.rev_append l (Stringmap.find rbase !rewtab) 
+    with
+      | Not_found -> List.rev l
+  in
+    rewtab:=Stringmap.add rbase l !rewtab
+
+let export_hintrewrite x = Some x
+
+let subst_hintrewrite (_,subst,(rbase,list as node)) = 
+  let subst_first (cst,b,t as pair) = 
+    let cst' = Term.subst_mps subst cst in
+    let t' = Tacinterp.subst_tactic subst t in
+      if cst == cst' & t == t' then pair else
+	(cst',b,t)
+  in
+  let list' = list_smartmap subst_first list in
+    if list' == list then node else
+      (rbase,list')
+      
+let classify_hintrewrite (_,x) = Libobject.Substitute x
+
+
+(* Declaration of the Hint Rewrite library object *)
+let (in_hintrewrite,out_hintrewrite)=
+  Libobject.declare_object {(Libobject.default_object "HINT_REWRITE") with
+       Libobject.open_function = (fun i o -> if i=1 then cache_hintrewrite o);
+       Libobject.cache_function = cache_hintrewrite;
+       Libobject.subst_function = subst_hintrewrite;
+       Libobject.classify_function = classify_hintrewrite;
+       Libobject.export_function = export_hintrewrite }
+
+(* To add rewriting rules to a base *)
+let add_rew_rules base lrul =
+  let lrul = List.rev_map (fun (c,b,t) -> (c,b,Tacinterp.glob_tactic t)) lrul in
+  Lib.add_anonymous_leaf (in_hintrewrite (base,lrul))
diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli
new file mode 100644
index 00000000..e97cde83
--- /dev/null
+++ b/tactics/autorewrite.mli
@@ -0,0 +1,22 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: autorewrite.mli,v 1.5.10.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Tacmach
+(*i*)
+
+(* Rewriting rules before tactic interpretation *)
+type raw_rew_rule = Term.constr * bool * Tacexpr.raw_tactic_expr
+
+(* To add rewriting rules to a base *)
+val add_rew_rules : string -> raw_rew_rule list -> unit
+
+(* The AutoRewrite tactic *)
+val autorewrite : tactic -> string list -> tactic
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
new file mode 100644
index 00000000..c5cdd540
--- /dev/null
+++ b/tactics/btermdn.ml
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: btermdn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Term
+open Termdn
+open Pattern
+
+(* Discrimination nets with bounded depth.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97). *)
+
+let dnet_depth = ref 8
+		   
+let bounded_constr_pat_discr (t,depth) =
+  if depth = 0 then 
+    None 
+  else
+    match constr_pat_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+	    
+let bounded_constr_val_discr (t,depth) =
+  if depth = 0 then 
+    None 
+  else
+    match constr_val_discr t with
+      | None -> None
+      | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l)
+
+type 'a t = (constr_label,constr_pattern * int,'a) Dn.t
+
+let create = Dn.create
+
+let add dn (c,v) = Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)
+
+let rmv dn (c,v) = Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)
+
+let lookup dn t =
+  List.map 
+    (fun ((c,_),v) -> (c,v)) 
+    (Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth))
+
+let app f dn = Dn.app (fun ((c,_),v) -> f(c,v)) dn
+
diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli
new file mode 100644
index 00000000..fe247495
--- /dev/null
+++ b/tactics/btermdn.mli
@@ -0,0 +1,28 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: btermdn.mli,v 1.8.16.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+
+(* Discrimination nets with bounded depth. *)
+
+type 'a t
+
+val create : unit -> 'a t
+
+val add : 'a t -> (constr_pattern * 'a) -> 'a t
+val rmv : 'a t -> (constr_pattern * 'a) -> 'a t
+
+val lookup : 'a t -> constr -> (constr_pattern * 'a) list
+val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
+
+val dnet_depth : int ref
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
new file mode 100644
index 00000000..c9d0ead5
--- /dev/null
+++ b/tactics/contradiction.ml
@@ -0,0 +1,88 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: contradiction.ml,v 1.3.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Util
+open Term
+open Proof_type
+open Hipattern
+open Tacmach
+open Tacticals
+open Tactics
+open Coqlib
+open Reductionops
+open Rawterm
+
+(* Absurd *)
+
+let absurd c gls =
+  (tclTHENS
+     (tclTHEN (elim_type (build_coq_False ())) (cut c)) 
+     ([(tclTHENS
+          (cut (applist(build_coq_not (),[c]))) 
+	  ([(tclTHEN intros
+	       ((fun gl ->
+		   let ida = pf_nth_hyp_id gl 1
+                   and idna = pf_nth_hyp_id gl 2 in
+                   exact_no_check (applist(mkVar idna,[mkVar ida])) gl)));
+            tclIDTAC]));
+       tclIDTAC])) gls
+
+(* Contradiction *)
+
+let filter_hyp f tac gl =
+  let rec seek = function
+    | [] -> raise Not_found
+    | (id,_,t)::rest when f t -> tac id gl
+    | _::rest -> seek rest in
+  seek (pf_hyps gl)
+
+let contradiction_context gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let rec seek_neg l gl = match l with
+    | [] ->  error "No such contradiction"
+    | (id,_,typ)::rest ->
+	let typ = whd_betadeltaiota env sigma typ in
+	if is_empty_type typ then
+	  simplest_elim (mkVar id) gl
+	else match kind_of_term typ with
+	  | Prod (na,t,u) when is_empty_type u ->
+	      (try
+		filter_hyp (fun typ -> pf_conv_x_leq gl typ t) 
+		  (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|])))
+		  gl
+	      with Not_found -> seek_neg rest gl)
+	  | _ -> seek_neg rest gl in
+  seek_neg (pf_hyps gl) gl
+
+let is_negation_of env sigma typ t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (na,t,u) -> is_empty_type u & is_conv_leq env sigma typ t
+    | _ -> false
+
+let contradiction_term (c,lbind as cl) gl =
+  let env = pf_env gl in
+  let sigma = project gl in
+  let typ = pf_type_of gl c in
+  let _, ccl = splay_prod env sigma typ in
+  if is_empty_type ccl then
+    tclTHEN (elim cl None) (tclTRY assumption) gl
+  else
+    try
+      if lbind = NoBindings then
+	filter_hyp (is_negation_of env sigma typ)
+	  (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) gl
+      else
+	raise Not_found
+    with Not_found -> error "Not a contradiction"
+
+let contradiction = function
+  | None -> tclTHEN intros contradiction_context
+  | Some c -> contradiction_term c
diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli
new file mode 100644
index 00000000..90ec101c
--- /dev/null
+++ b/tactics/contradiction.mli
@@ -0,0 +1,19 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: contradiction.mli,v 1.2.2.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Rawterm
+(*i*)
+
+val absurd                      : constr -> tactic
+val contradiction               : constr with_bindings option -> tactic
diff --git a/tactics/dhyp.ml b/tactics/dhyp.ml
new file mode 100644
index 00000000..fb672d0b
--- /dev/null
+++ b/tactics/dhyp.ml
@@ -0,0 +1,373 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: dhyp.ml,v 1.30.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+(* Chet's comments about this tactic :
+ 
+ Programmable destruction of hypotheses and conclusions.
+
+   The idea here is that we are going to store patterns.  These
+   patterns look like:
+
+   TYP=<pattern>
+   SORT=<pattern>
+
+   and from these patterns, we will be able to decide which tactic to
+   execute.
+
+   For hypotheses, we have a vector of 4 patterns:
+
+   HYP[TYP] HYP[SORT] CONCL[TYP] CONCL[SORT]
+
+   and for conclusions, we have 2:
+
+   CONCL[TYP] CONCL[SORT]
+
+   If the user doesn't supply some of these, they are just replaced
+   with empties.
+
+   The process of matching goes like this:
+
+   We use a discrimination net to look for matches between the pattern
+   for HYP[TOP] (CONCL[TOP]) and the type of the chosen hypothesis.
+   Then, we use this to look for the right tactic to apply, by
+   matching the rest of the slots.  Each match is tried, and if there
+   is more than one, this fact is reported, and the one with the
+   lowest priority is taken.  The priority is a parameter of the
+   tactic input.
+
+   The tactic input is an expression to hand to the
+   tactic-interpreter, and its priority.
+
+   For most tactics, the priority should be the number of subgoals
+   generated.
+
+   Matching is compatible with second-order matching of sopattern.
+
+   SYNTAX:
+
+   Hint DHyp <hyp-pattern> pri <tac-pattern>.
+
+   and
+
+   Hint DConcl <concl-pattern> pri <tac-pattern>.
+
+   The bindings at the end allow us to transfer information from the
+   patterns on terms into the patterns on tactics in a safe way - we
+   will perform second-order normalization and conversion to an AST
+   before substitution into the tactic-expression.
+
+   WARNING: The binding mechanism is NOT intended to facilitate the
+   transfer of large amounts of information from the terms to the
+   tactic.  This should be done in a special-purpose tactic.
+
+ *)
+
+(*
+
+Example : The tactic "if there is a hypothesis saying that the
+successor of some number is smaller than zero, then invert such
+hypothesis" is defined in this way:
+
+Require DHyp.
+Hint Destruct Hypothesis less_than_zero (le (S ?) O) 1
+  (:tactic:<Inversion $0>).
+
+Then, the tactic is used like this:
+
+Goal (le (S O) O) -> False.
+Intro H.
+DHyp  H.
+Qed.
+
+The name "$0" refers to the matching hypothesis --in this case the
+hypothesis H.
+
+Similarly for the conclusion :
+
+Hint Destruct Conclusion equal_zero  (? = ?) 1 (:tactic:<Reflexivity>).
+
+Goal (plus O O)=O.
+DConcl.
+Qed.
+
+The "Discardable" option clears the hypothesis after using it.
+
+Require DHyp.
+Hint Destruct  Discardable Hypothesis less_than_zero (le (S ?) O) 1
+  (:tactic:<Inversion $0>).
+
+Goal (n:nat)(le (S n) O) -> False.
+Intros n H.
+DHyp  H.
+Qed.
+-- Eduardo (9/3/97 )
+
+*)
+
+open Pp
+open Util
+open Names
+open Term
+open Environ
+open Reduction
+open Proof_type
+open Rawterm
+open Tacmach
+open Refiner
+open Tactics
+open Clenv
+open Tactics
+open Tacticals
+open Libobject
+open Library
+open Pattern
+open Matching
+open Ast
+open Pcoq
+open Tacexpr
+open Libnames
+
+(* two patterns - one for the type, and one for the type of the type *)
+type destructor_pattern = {
+  d_typ: constr_pattern; 
+  d_sort: constr_pattern }
+
+let subst_destructor_pattern subst { d_typ = t; d_sort = s } =
+  { d_typ = subst_pattern subst t; d_sort = subst_pattern subst s }
+
+(* hypothesis patterns might need to do matching on the conclusion, too.
+ * conclusion-patterns only need to do matching on the hypothesis *)
+type located_destructor_pattern =
+   (* discardable, pattern for hyp, pattern for concl *)
+   (bool * destructor_pattern * destructor_pattern,
+   (* pattern for concl *)
+   destructor_pattern) location
+
+let subst_located_destructor_pattern subst = function
+  | HypLocation (b,d,d') -> 
+      HypLocation
+        (b,subst_destructor_pattern subst d, subst_destructor_pattern subst d')
+  | ConclLocation d ->
+      ConclLocation (subst_destructor_pattern subst d)
+
+type destructor_data = {
+  d_pat : located_destructor_pattern;
+  d_pri : int;
+  d_code : identifier option * glob_tactic_expr (* should be of phylum tactic *)
+}
+
+type t = (identifier,destructor_data) Nbtermdn.t
+type frozen_t = (identifier,destructor_data) Nbtermdn.frozen_t
+
+let tactab = (Nbtermdn.create () : t)
+
+let lookup pat = Nbtermdn.lookup tactab pat
+
+let init () = Nbtermdn.empty tactab
+
+let freeze () = Nbtermdn.freeze tactab
+let unfreeze fs = Nbtermdn.unfreeze fs tactab
+
+let rollback f x =
+  let fs = freeze() in 
+  try f x with e -> (unfreeze fs; raise e)
+
+let add (na,dd) =
+  let pat = match dd.d_pat with
+    | HypLocation(_,p,_) -> p.d_typ
+    | ConclLocation p -> p.d_typ
+  in 
+  if Nbtermdn.in_dn tactab na then begin
+    msgnl (str "Warning [Overriding Destructor Entry " ++ 
+             str (string_of_id na) ++ str"]");
+    Nbtermdn.remap tactab na (pat,dd)
+  end else 
+    Nbtermdn.add tactab (na,(pat,dd))
+
+let _ = 
+  Summary.declare_summary "destruct-hyp-concl"
+    { Summary.freeze_function = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function = init;
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+let forward_subst_tactic = 
+  ref (fun _ -> failwith "subst_tactic is not installed for DHyp")
+
+let set_extern_subst_tactic f = forward_subst_tactic := f
+
+let cache_dd (_,(_,na,dd)) =
+  try 
+    add (na,dd)
+  with _ -> 
+    anomalylabstrm "Dhyp.add"
+      (str"The code which adds destructor hints broke;" ++ spc () ++ 
+	 str"this is not supposed to happen")
+
+let classify_dd (_,(local,_,_ as o)) =
+  if local then Dispose else Substitute o
+
+let export_dd (local,_,_ as x) = if local then None else Some x
+
+let subst_dd (_,subst,(local,na,dd)) =
+  (local,na,
+  { d_pat = subst_located_destructor_pattern subst dd.d_pat;
+    d_pri = dd.d_pri; 
+    d_code = !forward_subst_tactic subst dd.d_code })
+
+let (inDD,outDD) =
+  declare_object {(default_object "DESTRUCT-HYP-CONCL-DATA") with
+                    cache_function = cache_dd;
+		    open_function = (fun i o -> if i=1 then cache_dd o);
+                    subst_function = subst_dd;
+		    classify_function = classify_dd;
+                    export_function = export_dd }
+
+let forward_intern_tac = 
+  ref (fun _ -> failwith "intern_tac is not installed for DHyp")
+
+let set_extern_intern_tac f = forward_intern_tac := f
+
+let catch_all_sort_pattern = PMeta(Some (id_of_string "SORT"))
+let catch_all_type_pattern = PMeta(Some (id_of_string "TYPE"))
+    
+let add_destructor_hint local na loc pat pri code =
+  let code = !forward_intern_tac code in
+  let code =
+    begin match loc, code with
+      | HypLocation _, TacFun ([id],body) -> (id,body)
+      | ConclLocation _, _ -> (None, code)
+      | _ ->
+	  errorlabstrm "add_destructor_hint"
+          (str "The tactic should be a function of the hypothesis name") end
+  in
+  let (_,pat) = Constrintern.interp_constrpattern Evd.empty (Global.env()) pat
+  in
+  let pat = match loc with
+    | HypLocation b ->
+	HypLocation
+	  (b,{d_typ=pat;d_sort=catch_all_sort_pattern},
+	     {d_typ=catch_all_type_pattern;d_sort=catch_all_sort_pattern})
+    | ConclLocation () ->
+	ConclLocation({d_typ=pat;d_sort=catch_all_sort_pattern}) in
+  Lib.add_anonymous_leaf
+    (inDD (local,na,{ d_pat = pat; d_pri=pri; d_code=code }))
+
+let match_dpat dp cls gls =
+  match (cls,dp) with
+    | ({onhyps=lo;onconcl=false},HypLocation(_,hypd,concld)) ->
+        let hl = match lo with
+            Some l -> l
+          | None -> List.map (fun id -> (id,[],(InHyp,ref None)))
+                     (pf_ids_of_hyps gls) in
+        if not
+          (List.for_all
+            (fun (id,_,(hl,_)) ->
+              let cltyp = pf_get_hyp_typ gls id in
+              let cl = pf_concl gls in
+              (hl=InHyp) &
+              (is_matching hypd.d_typ cltyp) &
+              (is_matching hypd.d_sort (pf_type_of gls cltyp)) &
+              (is_matching concld.d_typ cl) &
+              (is_matching concld.d_sort (pf_type_of gls cl)))
+            hl)
+        then error "No match"
+    | ({onhyps=Some[];onconcl=true},ConclLocation concld) ->
+        let cl = pf_concl gls in
+        if not
+          ((is_matching concld.d_typ cl) &
+           (is_matching concld.d_sort (pf_type_of gls cl)))
+        then error "No match"
+    | _ -> error "ApplyDestructor"
+
+let forward_interp_tactic = 
+  ref (fun _ -> failwith "interp_tactic is not installed for DHyp")
+
+let set_extern_interp f = forward_interp_tactic := f
+
+let applyDestructor cls discard dd gls =
+  match_dpat dd.d_pat cls gls;
+  let cll = simple_clause_list_of cls gls in
+  let tacl =
+    List.map (fun cl ->
+      match cl, dd.d_code with
+        | Some (id,_,_), (Some x, tac) -> 
+	    let arg =
+              ConstrMayEval(ConstrTerm (RRef(dummy_loc,VarRef id),None)) in
+            TacLetIn ([(dummy_loc, x), None, arg], tac)
+        | None, (None, tac) -> tac
+        | _, (Some _,_) -> error "Destructor expects an hypothesis"
+        | _, (None,_) -> error "Destructor is for conclusion")
+      cll in
+  let discard_0 =
+    List.map (fun cl ->
+      match (cl,dd.d_pat) with
+        | (Some (id,_,_),HypLocation(discardable,_,_)) ->
+            if discard & discardable then thin [id] else tclIDTAC
+        | (None,ConclLocation _) -> tclIDTAC
+        | _ -> error "ApplyDestructor" ) cll in
+  tclTHEN (tclMAP !forward_interp_tactic tacl) (tclTHENLIST discard_0) gls
+
+
+(* [DHyp id gls]
+
+   will take an identifier, get its type, look it up in the
+   discrimination net, get the destructors stored there, and then try
+   them in order of priority. *)
+
+let destructHyp discard id gls =
+  let hyptyp = pf_get_hyp_typ gls id in
+  let ddl = List.map snd (lookup hyptyp) in
+  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
+  tclFIRST (List.map (applyDestructor (onHyp id) discard) sorted_ddl) gls
+
+let cDHyp id gls = destructHyp true id gls
+let dHyp id gls = destructHyp false id gls
+
+let h_destructHyp b id =
+  abstract_tactic (TacDestructHyp (b,(dummy_loc,id))) (destructHyp b id)
+
+(* [DConcl gls]
+
+   will take a goal, get its concl, look it up in the
+   discrimination net, get the destructors stored there, and then try
+   them in order of priority. *)
+
+let dConcl gls =
+  let ddl = List.map snd (lookup (pf_concl gls)) in
+  let sorted_ddl = Sort.list (fun dd1 dd2 -> dd1.d_pri > dd2.d_pri) ddl in
+  tclFIRST (List.map (applyDestructor onConcl false) sorted_ddl) gls
+
+let h_destructConcl = abstract_tactic TacDestructConcl dConcl
+
+let to2Lists (table : t) = Nbtermdn.to2lists table
+
+let rec search n =
+  if n=0 then error "Search has reached zero.";
+  tclFIRST
+    [intros;
+     assumption;
+     (tclTHEN  
+        (Tacticals.tryAllClauses 
+           (function 
+              | Some (id,_,_) -> (dHyp id)
+              | None    ->  dConcl ))
+        (search (n-1)))]
+    
+let auto_tdb n = tclTRY (tclCOMPLETE (search n))
+   
+let search_depth_tdb = ref(5)
+
+let depth_tdb = function
+  | None -> !search_depth_tdb
+  | Some n -> n
+
+let h_auto_tdb n = abstract_tactic (TacAutoTDB n) (auto_tdb (depth_tdb n))
diff --git a/tactics/dhyp.mli b/tactics/dhyp.mli
new file mode 100644
index 00000000..a0cef679
--- /dev/null
+++ b/tactics/dhyp.mli
@@ -0,0 +1,32 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: dhyp.mli,v 1.8.2.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Tacmach
+open Tacexpr
+(*i*)
+
+(* Programmable destruction of hypotheses and conclusions. *)
+
+val set_extern_interp : (glob_tactic_expr -> tactic) -> unit
+val set_extern_intern_tac : (raw_tactic_expr -> glob_tactic_expr) -> unit
+
+(*
+val dHyp : identifier -> tactic
+val dConcl : tactic
+*)
+val h_destructHyp : bool -> identifier -> tactic
+val h_destructConcl : tactic
+val h_auto_tdb : int option -> tactic
+
+val add_destructor_hint :
+  Vernacexpr.locality_flag -> identifier -> (bool,unit) Tacexpr.location ->
+    Topconstr.constr_expr -> int -> raw_tactic_expr -> unit
diff --git a/tactics/dn.ml b/tactics/dn.ml
new file mode 100644
index 00000000..55116831
--- /dev/null
+++ b/tactics/dn.ml
@@ -0,0 +1,80 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: dn.ml,v 1.5.16.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+(* This file implements the basic structure of what Chet called
+   ``discrimination nets''. If my understanding is right, it serves
+   to associate actions (for example, tactics) with a priority to term
+   patterns, so that if a hypothesis matches a pattern in the net,
+   then the associated tactic is applied. Discrimination nets are used
+   (only) to implement the tactics Auto, DHyp and Point.
+
+   A discrimination net is a tries structure, that is, a tree structure 
+   specially conceived for searching patterns, like for example strings
+   --see the file Tlm.ml in the directory lib/util--. Here the tries
+   structure are used for looking for term patterns.
+
+   This module is then used in :
+     - termdn.ml   (discrimination nets of terms);
+     - btermdn.ml  (discrimination nets of terms with bounded depth,
+                    used in the tactic auto);
+     - nbtermdn.ml (named discrimination nets with bounded depth, used
+                    in the tactics Dhyp and Point).
+  Eduardo (4/8/97) *)
+
+(* Definition of the basic structure *)
+
+type ('lbl,'pat) decompose_fun = 'pat -> ('lbl * 'pat list) option
+
+type ('lbl,'pat,'inf) t = (('lbl * int) option,'pat * 'inf) Tlm.t
+
+let create () = Tlm.empty
+
+(* [path_of dna pat] returns the list of nodes of the pattern [pat] read in 
+prefix ordering, [dna] is the function returning the main node of a pattern *)
+
+let path_of dna =
+  let rec path_of_deferred = function
+    | [] -> []
+    | h::tl -> pathrec tl h
+	    
+  and pathrec deferred t =
+    match dna t with
+      | None -> 
+	  None :: (path_of_deferred deferred)
+      | Some (lbl,[]) ->
+	  (Some (lbl,0))::(path_of_deferred deferred)
+      | Some (lbl,(h::def_subl as v)) ->
+	  (Some (lbl,List.length v))::(pathrec (def_subl@deferred) h)
+  in 
+  pathrec []
+    
+let tm_of tm lbl =
+  try [Tlm.map tm lbl] with Not_found -> []
+
+let lookup tm dna t =
+  let rec lookrec t tm =
+    (tm_of tm None)@
+    (match dna t with
+       | None -> []
+       | Some(lbl,v) ->
+	   List.fold_left 
+	     (fun l c -> List.flatten(List.map (lookrec c) l))
+             (tm_of tm (Some(lbl,List.length v))) v)
+  in 
+  List.flatten(List.map Tlm.xtract (lookrec t tm))
+
+let add tm dna (pat,inf) =
+  let p = path_of dna pat in Tlm.add tm (p,(pat,inf))
+    
+let rmv tm dna (pat,inf) =
+  let p = path_of dna pat in Tlm.rmv tm (p,(pat,inf))
+    
+let app f tm = Tlm.app (fun (_,p) -> f p) tm
+
diff --git a/tactics/dn.mli b/tactics/dn.mli
new file mode 100644
index 00000000..a54007d8
--- /dev/null
+++ b/tactics/dn.mli
@@ -0,0 +1,40 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: dn.mli,v 1.4.16.1 2004/07/16 19:30:52 herbelin Exp $ i*)
+
+(* Discrimination nets. *)
+
+type ('lbl,'tree) decompose_fun = 'tree -> ('lbl * 'tree list) option
+
+type ('lbl,'pat,'inf) t (* = (('lbl * int) option,'pat * 'inf) Tlm.t *)
+
+val create : unit -> ('lbl,'pat,'inf) t
+
+(* [add t f (tree,inf)] adds a structured object [tree] together with
+   the associated information [inf] to the table [t]; the function
+   [f] is used to translated [tree] into its prefix decomposition: [f]
+   must decompose any tree into a label characterizing its root node and
+   the list of its subtree *)
+
+val add : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf
+  -> ('lbl,'pat,'inf) t
+
+val rmv : ('lbl,'pat,'inf) t -> ('lbl,'pat) decompose_fun -> 'pat * 'inf 
+  -> ('lbl,'pat,'inf) t
+
+(* [lookup t f tree] looks for trees (and their associated
+   information) in table [t] such that the structured object [tree]
+   matches against them; [f] is used to translated [tree] into its
+   prefix decomposition: [f] must decompose any tree into a label
+   characterizing its root node and the list of its subtree *)
+
+val lookup : ('lbl,'pat,'inf) t -> ('lbl,'term) decompose_fun -> 'term
+  -> ('pat * 'inf) list
+
+val app : (('pat * 'inf) -> unit) -> ('lbl,'pat,'inf) t -> unit
diff --git a/tactics/doc.tex b/tactics/doc.tex
new file mode 100644
index 00000000..d44cc14a
--- /dev/null
+++ b/tactics/doc.tex
@@ -0,0 +1,11 @@
+
+\newpage
+\section*{The Tactics}
+
+\ocwsection \label{tactics}
+This chapter describes the \Coq\ main tactics.
+The modules of that chapter are organized as follows.
+
+\bigskip
+\begin{center}\epsfig{file=tactics.dep.ps,width=\linewidth}\end{center}
+
diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4
new file mode 100644
index 00000000..31d79948
--- /dev/null
+++ b/tactics/eauto.ml4
@@ -0,0 +1,448 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: eauto.ml4,v 1.11.2.1 2004/07/16 19:30:52 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Reduction
+open Proof_type
+open Proof_trees
+open Declarations
+open Tacticals
+open Tacmach
+open Evar_refiner
+open Tactics
+open Pattern
+open Clenv
+open Auto
+open Rawterm
+
+let e_give_exact c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in 
+  if occur_existential t1 or occur_existential t2 then 
+     tclTHEN (unify t1) (exact_check c) gl
+  else exact_check c gl
+
+let assumption id = e_give_exact (mkVar id)
+        
+let e_assumption gl = 
+  tclFIRST (List.map assumption (pf_ids_of_hyps gl)) gl
+
+let e_resolve_with_bindings_tac  (c,lbind) gl = 
+  let (wc,kONT) = startWalk gl in
+  let t = w_hnf_constr wc (w_type_of wc c) in 
+  let clause = make_clenv_binding_apply wc (-1) (c,t) lbind in 
+  e_res_pf kONT clause gl
+
+let e_resolve_constr c gls = e_resolve_with_bindings_tac (c,NoBindings) gls
+			     
+(* V8 TACTIC EXTEND eexact
+| [ "eexact" constr(c) ] -> [ e_give_exact c ]
+END*)
+TACTIC EXTEND Eexact
+| [ "EExact" constr(c) ] -> [ e_give_exact c ]
+END
+
+let e_give_exact_constr = h_eexact
+
+let registered_e_assumption gl = 
+  tclFIRST (List.map (fun id gl -> e_give_exact_constr (mkVar id) gl) 
+              (pf_ids_of_hyps gl)) gl
+
+(* This automatically define h_eApply (among other things) *)
+(*V8 TACTIC EXTEND eapply
+  [ "eapply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
+END*)
+TACTIC EXTEND eapply
+  [ "EApply" constr_with_bindings(c) ] -> [ e_resolve_with_bindings_tac c ]
+END
+
+let vernac_e_resolve_constr c = h_eapply (c,NoBindings)
+
+let e_constructor_tac boundopt i lbind gl = 
+    let cl = pf_concl gl in 
+  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in 
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames
+  and sigma   = project gl in
+  if i=0 then error "The constructors are numbered starting from 1";
+  if i > nconstr then error "Not enough constructors";
+  begin match boundopt with 
+    | Some expctdnum -> 
+        if expctdnum <> nconstr then 
+	  error "Not the expected number of constructors"
+    | None -> ()
+  end;
+  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
+  let apply_tac = e_resolve_with_bindings_tac (cons,lbind) in
+  (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl
+
+let e_one_constructor i = e_constructor_tac None i
+
+let e_any_constructor tacopt gl =
+  let t = match tacopt with None -> tclIDTAC | Some t -> t in
+  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
+  if nconstr = 0 then error "The type has no constructors";
+  tclFIRST (List.map (fun i -> tclTHEN (e_one_constructor i NoBindings) t) 
+              (interval 1 nconstr)) gl
+
+let e_left = e_constructor_tac (Some 2) 1
+
+let e_right = e_constructor_tac (Some 2) 2
+
+let e_split = e_constructor_tac (Some 1) 1
+
+(* This automatically define h_econstructor (among other things) *)
+(*V8 TACTIC EXTEND eapply
+  [ "econstructor" integer(n) with_bindings(c) ] -> [ e_constructor_tac None n c ]
+END*)
+TACTIC EXTEND econstructor
+  [ "EConstructor" integer(n) "with" bindings(c) ] -> [ e_constructor_tac None n c ]
+  | [ "EConstructor" integer(n) ] -> [ e_constructor_tac None n NoBindings ]
+  | [ "EConstructor" tactic_opt(t) ] -> [ e_any_constructor (option_app Tacinterp.eval_tactic t) ] 
+      END
+
+TACTIC EXTEND eleft
+  [ "ELeft" "with" bindings(l) ] -> [e_left l]
+  | [ "ELeft"] -> [e_left NoBindings]
+END
+
+TACTIC EXTEND eright
+  [ "ERight" "with" bindings(l) ] -> [e_right l]
+  | [ "ERight" ] -> [e_right NoBindings]
+END
+
+TACTIC EXTEND esplit
+  [ "ESplit" "with" bindings(l) ] -> [e_split l]
+  | [ "ESplit"] -> [e_split NoBindings]
+END
+
+
+TACTIC EXTEND eexists
+  [ "EExists" bindings(l) ] -> [e_split l]
+END
+
+
+(************************************************************************)
+(*   PROLOG tactic                                                      *)
+(************************************************************************)
+
+let one_step l gl =
+  [Tactics.intro]
+  @ (List.map e_resolve_constr (List.map mkVar (pf_ids_of_hyps gl)))
+  @ (List.map e_resolve_constr l)
+  @ (List.map assumption (pf_ids_of_hyps gl))
+
+let rec prolog l n gl =
+  if n <= 0 then error "prolog - failure";
+  let prol = (prolog l (n-1)) in
+  (tclFIRST (List.map (fun t -> (tclTHEN t prol)) (one_step l gl))) gl
+
+let prolog_tac l n gl =
+  let n =
+    match n with
+      |  Genarg.ArgArg n -> n
+      | _ -> error "Prolog called with a non closed argument"
+  in
+  try (prolog l n gl)
+  with UserError ("Refiner.tclFIRST",_) ->
+    errorlabstrm "Prolog.prolog" (str "Prolog failed")
+
+(* V8 TACTIC EXTEND prolog
+| [ "prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+END*)
+TACTIC EXTEND Prolog
+| [ "Prolog" "[" constr_list(l) "]" int_or_var(n) ] -> [ prolog_tac l n ]
+END
+
+(*
+let vernac_prolog =
+  let uncom = function
+    | Constr c -> c
+    | _ -> assert false
+  in
+  let gentac = 
+    hide_tactic "Prolog"
+      (function
+	 | (Integer n) :: al -> prolog_tac (List.map uncom al) n
+	 | _ -> assert false)
+  in 
+  fun coms n -> 
+    gentac ((Integer n) :: (List.map (fun com -> (Constr com)) coms))
+*)
+
+open Auto
+
+(***************************************************************************)
+(* A tactic similar to Auto, but using EApply, Assumption and e_give_exact *)
+(***************************************************************************)
+
+let unify_e_resolve  (c,clenv) gls = 
+  let (wc,kONT) = startWalk gls in
+  let clenv' = connect_clenv wc clenv in
+  let _ = clenv_unique_resolver false clenv' gls in
+  vernac_e_resolve_constr c gls
+
+let rec e_trivial_fail_db db_list local_db goal =
+  let tacl = 
+    registered_e_assumption ::
+    (tclTHEN Tactics.intro 
+       (function g'->
+	  let d = pf_last_hyp g' in
+	  let hintl = make_resolve_hyp (pf_env g') (project g') d in
+          (e_trivial_fail_db db_list
+	     (Hint_db.add_list hintl local_db) g'))) ::
+    (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) )
+  in 
+  tclFIRST (List.map tclCOMPLETE tacl) goal 
+
+and e_my_find_search db_list local_db hdc concl = 
+  let hdc = head_of_constr_reference hdc in
+  let hintl =
+    if occur_existential concl then 
+      list_map_append (Hint_db.map_all hdc) (local_db::db_list)
+    else 
+      list_map_append (Hint_db.map_auto (hdc,concl)) (local_db::db_list)
+  in 
+  let tac_of_hint = 
+    fun ({pri=b; pat = p; code=t} as patac) -> 
+      (b, 
+       let tac =
+	 match t with
+	   | Res_pf (term,cl) -> unify_resolve (term,cl)
+	   | ERes_pf (term,cl) -> unify_e_resolve (term,cl)
+	   | Give_exact (c) -> e_give_exact_constr c
+	   | Res_pf_THEN_trivial_fail (term,cl) ->
+               tclTHEN (unify_e_resolve (term,cl)) 
+		 (e_trivial_fail_db db_list local_db)
+	   | Unfold_nth c -> unfold_constr c
+	   | Extern tacast -> conclPattern concl 
+	       (out_some p) tacast
+       in 
+       (tac,fmt_autotactic t))
+       (*i
+	 fun gls -> pPNL (fmt_autotactic t); Format.print_flush (); 
+                     try tac gls
+		     with e when Logic.catchable_exception(e) -> 
+                            (Format.print_string "Fail\n"; 
+			     Format.print_flush (); 
+			     raise e)
+       i*)
+  in 
+  List.map tac_of_hint hintl
+    
+and e_trivial_resolve db_list local_db gl = 
+  try 
+    Auto.priority 
+      (e_my_find_search db_list local_db 
+	 (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let e_possible_resolve db_list local_db gl =
+  try List.map snd (e_my_find_search db_list local_db 
+		      (List.hd (head_constr_bound gl [])) gl)
+  with Bound | Not_found -> []
+
+let assumption_tac_list id = apply_tac_list (e_give_exact_constr (mkVar id))
+
+let find_first_goal gls = 
+  try first_goal gls with UserError _ -> assert false
+
+(*s The following module [SearchProblem] is used to instantiate the generic
+    exploration functor [Explore.Make]. *)
+      
+module SearchProblem = struct
+
+  type state = { 
+    depth : int; (*r depth of search before failing *)
+    tacres : goal list sigma * validation;
+    last_tactic : std_ppcmds;
+    dblist : Auto.Hint_db.t list;
+    localdb :  Auto.Hint_db.t list }
+		 
+  let success s = (sig_it (fst s.tacres)) = []
+
+  let rec filter_tactics (glls,v) = function
+    | [] -> []
+    | (tac,pptac) :: tacl -> 
+	try 
+	  let (lgls,ptl) = apply_tac_list tac glls in 
+	  let v' p = v (ptl p) in
+	  ((lgls,v'),pptac) :: filter_tactics (glls,v) tacl
+	with e when Logic.catchable_exception e ->
+	  filter_tactics (glls,v) tacl
+
+  let rec list_addn n x l = 
+    if n = 0 then l else x :: (list_addn (pred n) x l)
+
+  (* Ordering of states is lexicographic on depth (greatest first) then
+     number of remaining goals. *)
+  let compare s s' =
+    let d = s'.depth - s.depth in
+    let nbgoals s = List.length (sig_it (fst s.tacres)) in
+    if d <> 0 then d else nbgoals s - nbgoals s'
+
+  let branching s = 
+    if s.depth = 0 then 
+      []
+    else      
+      let lg = fst s.tacres in
+      let nbgl = List.length (sig_it lg) in
+      assert (nbgl > 0);
+      let g = find_first_goal lg in
+      let assumption_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (List.map 
+	       (fun id -> (e_give_exact_constr (mkVar id),
+			   (str "Exact" ++ spc () ++ pr_id id)))
+	       (pf_ids_of_hyps g))
+	in
+	List.map (fun (res,pp) -> { depth = s.depth; tacres = res;
+				    last_tactic = pp; dblist = s.dblist;
+				    localdb = List.tl s.localdb }) l
+      in
+      let intro_tac = 
+	List.map 
+	  (fun ((lgls,_) as res,pp) -> 
+	     let g' = first_goal lgls in 
+	     let hintl = 
+	       make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g')
+	     in
+             let ldb = Hint_db.add_list hintl (List.hd s.localdb) in
+	     { depth = s.depth; tacres = res; 
+	       last_tactic = pp; dblist = s.dblist;
+	       localdb = ldb :: List.tl s.localdb })
+	  (filter_tactics s.tacres [Tactics.intro,(str "Intro")])
+      in
+      let rec_tacs = 
+	let l = 
+	  filter_tactics s.tacres
+	    (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g))
+	in
+	List.map 
+	  (fun ((lgls,_) as res, pp) -> 
+	     let nbgl' = List.length (sig_it lgls) in
+	     if nbgl' < nbgl then
+	       { depth = s.depth; tacres = res; last_tactic = pp;
+		 dblist = s.dblist; localdb = List.tl s.localdb }
+	     else 
+	       { depth = pred s.depth; tacres = res; 
+		 dblist = s.dblist; last_tactic = pp;
+		 localdb = 
+		   list_addn (nbgl'-nbgl) (List.hd s.localdb) s.localdb })
+	  l
+      in
+      List.sort compare (assumption_tacs @ intro_tac @ rec_tacs)
+
+  let pp s = 
+    msg (hov 0 (str " depth=" ++ int s.depth ++ spc () ++ 
+		  s.last_tactic ++ str "\n"))
+
+end
+
+module Search = Explore.Make(SearchProblem)
+
+let make_initial_state n gl dblist localdb =
+  { SearchProblem.depth = n;
+    SearchProblem.tacres = tclIDTAC gl;
+    SearchProblem.last_tactic = (mt ());
+    SearchProblem.dblist = dblist;
+    SearchProblem.localdb = [localdb] }
+
+let e_depth_search debug p db_list local_db gl =
+  try
+    let tac = if debug then Search.debug_depth_first else Search.depth_first in
+    let s = tac (make_initial_state p gl db_list local_db) in
+    s.SearchProblem.tacres
+  with Not_found -> error "EAuto: depth first search failed"
+
+let e_breadth_search debug n db_list local_db gl =
+  try
+    let tac = 
+      if debug then Search.debug_breadth_first else Search.breadth_first 
+    in
+    let s = tac (make_initial_state n gl db_list local_db) in
+    s.SearchProblem.tacres
+  with Not_found -> error "EAuto: breadth first search failed"
+
+let e_search_auto debug (in_depth,p) db_list gl = 
+  let local_db = make_local_hint_db gl in 
+  if in_depth then 
+    e_depth_search debug p db_list local_db gl
+  else 
+    e_breadth_search debug p db_list local_db gl
+
+let eauto debug np dbnames = 
+  let db_list =
+    List.map
+      (fun x -> 
+	 try Stringmap.find x !searchtable
+	 with Not_found -> error ("EAuto: "^x^": No such Hint database"))
+      ("core"::dbnames) 
+  in
+  tclTRY (e_search_auto debug np db_list)
+
+let full_eauto debug n gl = 
+  let dbnames = stringmap_dom !searchtable in
+  let dbnames =  list_subtract dbnames ["v62"] in
+  let db_list = List.map (fun x -> Stringmap.find x !searchtable) dbnames in
+  let local_db = make_local_hint_db gl in
+  tclTRY (e_search_auto debug n db_list) gl
+
+let gen_eauto d np = function
+  | None -> full_eauto d np
+  | Some l -> eauto d np l
+
+let make_depth = function
+  | None -> !default_search_depth 
+  | Some (Genarg.ArgArg d) -> d
+  | _ -> error "EAuto called with a non closed argument"
+
+let make_dimension n = function
+  | None -> (true,make_depth n)
+  | Some (Genarg.ArgArg d) -> (false,d)
+  | _ -> error "EAuto called with a non closed argument"
+
+open Genarg
+
+(* Hint bases *)
+
+let pr_hintbases _prc _prt = function 
+  | None -> str " with *"
+  | Some [] -> mt ()
+  | Some l -> str " with " ++ Util.prlist_with_sep spc str l
+
+ARGUMENT EXTEND hintbases
+  TYPED AS preident_list_opt
+  PRINTED BY pr_hintbases
+| [ "with" "*" ] -> [ None ]
+| [ "with" ne_preident_list(l) ] -> [ Some l ]
+| [ ] -> [ Some [] ]
+END
+
+TACTIC EXTEND EAuto
+| [ "EAuto" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] ->
+    [ gen_eauto false (make_dimension n p) db ]
+END
+
+V7 TACTIC EXTEND EAutodebug
+| [ "EAutod" int_or_var_opt(n) int_or_var_opt(p) hintbases(db) ] ->
+    [ gen_eauto true (make_dimension n p) db ]
+END
+
+
diff --git a/tactics/eauto.mli b/tactics/eauto.mli
new file mode 100644
index 00000000..c3084e65
--- /dev/null
+++ b/tactics/eauto.mli
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i*)
+open Term
+open Proof_type
+open Tacexpr
+(*i*)
+
+val rawwit_hintbases : string list option raw_abstract_argument_type
+
+val e_assumption : tactic
+
+val registered_e_assumption : tactic
+
+val e_resolve_constr :  constr -> tactic
+
+val vernac_e_resolve_constr :  constr -> tactic
+
+val e_give_exact_constr : constr -> tactic
diff --git a/tactics/elim.ml b/tactics/elim.ml
new file mode 100644
index 00000000..5573f9ea
--- /dev/null
+++ b/tactics/elim.ml
@@ -0,0 +1,195 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: elim.ml,v 1.37.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Environ
+open Libnames
+open Reduction
+open Inductiveops
+open Proof_type
+open Clenv
+open Hipattern
+open Tacmach
+open Tacticals
+open Tactics
+open Hiddentac
+open Genarg
+open Tacexpr
+
+let introElimAssumsThen tac ba =
+  let nassums = 
+    List.fold_left 
+      (fun acc b -> if b then acc+2 else acc+1) 
+      0 ba.branchsign 
+  in 
+  let introElimAssums = tclDO nassums intro in 
+  (tclTHEN introElimAssums (elim_on_ba tac ba))
+
+let introCaseAssumsThen tac ba =
+  let case_thin_sign =
+    List.flatten
+      (List.map (function b -> if b then [false;true] else [false])
+	ba.branchsign)
+  in 
+  let n1 = List.length case_thin_sign in
+  let n2 = List.length ba.branchnames in
+  let (l1,l2),l3 =
+    if n1 < n2 then list_chop n1 ba.branchnames, []
+    else 
+      (ba.branchnames, []),
+       if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
+  let introCaseAssums = tclTHEN (intros_pattern None l1) (intros_clearing l3)
+  in
+  (tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
+
+(* The following tactic Decompose repeatedly applies the
+   elimination(s) rule(s) of the types satisfying the predicate
+   ``recognizer'' onto a certain hypothesis. For example :
+
+Require Elim.
+Require Le.
+   Goal (y:nat){x:nat | (le O x)/\(le x y)}->{x:nat | (le O x)}.
+   Intros y H.
+   Decompose [sig and] H;EAuto.
+   Qed.
+
+Another example :
+
+   Goal (A,B,C:Prop)(A/\B/\C \/ B/\C \/ C/\A) -> C.
+   Intros A B C H; Decompose [and or] H; Assumption.
+   Qed.
+*)
+
+let elimHypThen tac id gl =
+  elimination_then tac ([],[]) (mkVar id) gl
+
+let rec general_decompose_on_hyp recognizer =
+  ifOnHyp recognizer (general_decompose recognizer) (fun _ -> tclIDTAC)
+
+and general_decompose recognizer id =
+  elimHypThen
+    (introElimAssumsThen
+       (fun bas ->
+	  tclTHEN (clear [id])
+	    (tclMAP (general_decompose_on_hyp recognizer)
+               (ids_of_named_context bas.assums))))
+    id
+
+(* Faudrait ajouter un COMPLETE pour que l'hypothèse créée ne reste
+   pas si aucune élimination n'est possible *)
+
+(* Meilleures stratégies mais perte de compatibilité *)
+let tmphyp_name = id_of_string "_TmpHyp"
+let up_to_delta = ref false (* true *)
+
+let general_decompose recognizer c gl = 
+  let typc = pf_type_of gl c in  
+  tclTHENSV (cut typc) 
+    [| tclTHEN (intro_using tmphyp_name)
+         (onLastHyp
+	    (ifOnHyp recognizer (general_decompose recognizer)
+	      (fun id -> clear [id])));
+       exact_no_check c |] gl
+
+let head_in gls indl t =
+  try
+    let ity,_ =
+      if !up_to_delta
+      then find_mrectype (pf_env gls) (project gls) t
+      else extract_mrectype t
+    in List.mem ity indl
+  with Not_found -> false
+       
+let inductive_of = function
+  | IndRef ity -> ity
+  | r ->
+      errorlabstrm "Decompose"
+        (Printer.pr_global r ++ str " is not an inductive type")
+
+let decompose_these c l gls =
+  let indl = (*List.map inductive_of*) l in 
+  general_decompose (fun (_,t) -> head_in gls indl t) c gls
+
+let decompose_nonrec c gls =
+  general_decompose 
+    (fun (_,t) -> is_non_recursive_type t)
+    c gls
+
+let decompose_and c gls = 
+  general_decompose 
+    (fun (_,t) -> is_conjunction t)
+    c gls
+
+let decompose_or c gls = 
+  general_decompose 
+    (fun (_,t) -> is_disjunction t)
+    c gls
+
+let h_decompose l c =
+  Refiner.abstract_tactic (TacDecompose (l,c)) (decompose_these c l)
+
+let h_decompose_or c =
+  Refiner.abstract_tactic (TacDecomposeOr c) (decompose_or c)
+
+let h_decompose_and c =
+  Refiner.abstract_tactic (TacDecomposeAnd c) (decompose_and c)
+
+(* The tactic Double performs a double induction *)
+
+let simple_elimination c gls =
+  simple_elimination_then (fun _ -> tclIDTAC) c gls
+
+let induction_trailer abs_i abs_j bargs =
+  tclTHEN 
+    (tclDO (abs_j - abs_i) intro)
+    (onLastHyp
+       (fun id gls ->
+	  let idty = pf_type_of gls (mkVar id) in
+	  let fvty = global_vars (pf_env gls) idty in
+	  let possible_bring_hyps =
+	    (List.tl (nLastHyps (abs_j - abs_i) gls)) @ bargs.assums
+          in
+	  let (hyps,_) =
+            List.fold_left 
+	      (fun (bring_ids,leave_ids) (cid,_,cidty as d) ->
+                 if not (List.mem cid leave_ids)
+                 then (d::bring_ids,leave_ids)
+                 else (bring_ids,cid::leave_ids))
+	      ([],fvty) possible_bring_hyps
+	  in
+          let ids = List.rev (ids_of_named_context hyps) in
+	  (tclTHENSEQ
+            [bring_hyps hyps; tclTRY (clear ids); 
+	     simple_elimination (mkVar id)])
+          gls))
+
+let double_ind h1 h2 gls =
+  let abs_i = depth_of_quantified_hypothesis true h1 gls in
+  let abs_j = depth_of_quantified_hypothesis true h2 gls in
+  let (abs_i,abs_j) =
+    if abs_i < abs_j then (abs_i,abs_j) else
+    if abs_i > abs_j then (abs_j,abs_i) else
+      error "Both hypotheses are the same" in
+  let cl = pf_concl gls in 
+  (tclTHEN (tclDO abs_i intro)
+     (onLastHyp
+       	(fun id ->
+           elimination_then
+             (introElimAssumsThen (induction_trailer abs_i abs_j))
+             ([],[]) (mkVar id)))) gls
+
+let h_double_induction h1 h2 =
+  Refiner.abstract_tactic (TacDoubleInduction (h1,h2)) (double_ind h1 h2)
+
+
diff --git a/tactics/elim.mli b/tactics/elim.mli
new file mode 100644
index 00000000..a891cd9d
--- /dev/null
+++ b/tactics/elim.mli
@@ -0,0 +1,38 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: elim.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Tacmach
+open Genarg
+open Tacticals
+(*i*)
+
+(* Eliminations tactics. *)
+
+val introElimAssumsThen :
+  (branch_assumptions -> tactic) -> branch_args -> tactic
+
+val introCaseAssumsThen :
+  (intro_pattern_expr list -> branch_assumptions -> tactic) -> 
+    branch_args -> tactic
+
+val general_decompose : (identifier * constr -> bool) -> constr -> tactic
+val decompose_nonrec  : constr -> tactic
+val decompose_and     : constr -> tactic
+val decompose_or      : constr -> tactic
+val h_decompose       : inductive list -> constr -> tactic
+val h_decompose_or    : constr -> tactic
+val h_decompose_and   : constr -> tactic
+
+val double_ind : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis -> tactic
+val h_double_induction : Rawterm.quantified_hypothesis -> Rawterm.quantified_hypothesis->tactic
diff --git a/tactics/eqdecide.ml4 b/tactics/eqdecide.ml4
new file mode 100644
index 00000000..8edfcb3e
--- /dev/null
+++ b/tactics/eqdecide.ml4
@@ -0,0 +1,188 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(************************************************************************)
+(*                              EqDecide                               *)
+(*   A tactic for deciding propositional equality on inductive types   *)
+(*                           by Eduardo Gimenez                        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: eqdecide.ml4,v 1.6.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Declarations
+open Tactics
+open Tacticals
+open Hiddentac
+open Equality
+open Auto
+open Pattern
+open Matching
+open Hipattern
+open Proof_trees
+open Proof_type
+open Tacmach
+open Coqlib
+
+(* This file containts the implementation of the tactics ``Decide
+   Equality'' and ``Compare''. They can be used to decide the
+   propositional equality of two objects that belongs to a small
+   inductive datatype --i.e., an inductive set such that all the
+   arguments of its constructors are non-functional sets.
+
+   The procedure for proving (x,y:R){x=y}+{~x=y} can be scketched as
+   follows:
+   1. Eliminate x and then y.
+   2. Try discrimination to solve those goals where x and y has
+      been introduced by different constructors.
+   3. If x and y have been introduced by the same constructor,
+      then analyse one by one the correspoing pairs of arguments.
+      If they are equal, rewrite one into the other. If they are
+      not, derive a contradiction from the injectiveness of the
+      constructor. 
+   4. Once all the arguments have been rewritten, solve the left half 
+      of the disjunction by reflexivity.
+
+   Eduardo Gimenez (30/3/98).
+*)
+
+let clear_last = (tclLAST_HYP (fun c -> (clear [destVar c])))
+
+let mkBranches = 
+  tclTHENSEQ
+    [intro; 
+     tclLAST_HYP h_simplest_elim;
+     clear_last;
+     intros ;
+     tclLAST_HYP h_simplest_case;
+     clear_last;
+     intros]
+
+let solveRightBranch  = 
+  tclTHEN h_simplest_right
+    (tclTHEN (intro_force true)
+      (onLastHyp (fun id -> Extratactics.h_discrHyp (Rawterm.NamedHyp id))))
+
+let h_solveRightBranch =
+  Refiner.abstract_extended_tactic "solveRightBranch" [] solveRightBranch
+
+(*
+let h_solveRightBranch =
+  hide_atomic_tactic "solveRightBranch" solveRightBranch
+*)
+
+(* Constructs the type {c1=c2}+{~c1=c2} *)
+
+let mkDecideEqGoal rectype c1 c2 g = 
+  let equality    = mkApp(build_coq_eq(), [|rectype; c1; c2|]) in
+  let disequality = mkApp(build_coq_not (), [|equality|]) in
+  mkApp(build_coq_sumbool (), [|equality; disequality |])
+
+
+(* Constructs the type (x1,x2:R){x1=x2}+{~x1=x2} *)
+
+let mkGenDecideEqGoal rectype g = 
+  let hypnames = pf_ids_of_hyps g in 
+  let xname    = next_ident_away (id_of_string "x") hypnames
+  and yname    = next_ident_away (id_of_string "y") hypnames in
+  (mkNamedProd xname rectype 
+     (mkNamedProd yname rectype 
+        (mkDecideEqGoal rectype (mkVar xname) (mkVar yname) g)))
+
+let eqCase  tac = 
+  (tclTHEN intro  
+  (tclTHEN (tclLAST_HYP Extratactics.h_rewriteLR)
+  (tclTHEN clear_last 
+  tac)))
+
+let diseqCase = 
+  let diseq  = id_of_string "diseq" in
+  let absurd = id_of_string "absurd" in 
+  (tclTHEN (intro_using diseq)
+  (tclTHEN  h_simplest_right
+  (tclTHEN  red_in_concl
+  (tclTHEN  (intro_using absurd)
+  (tclTHEN  (h_simplest_apply (mkVar diseq))
+  (tclTHEN  (Extratactics.h_injHyp (Rawterm.NamedHyp absurd))
+            full_trivial))))))
+
+let solveArg a1 a2 tac  g = 
+  let rectype = pf_type_of g a1 in
+  let decide  = mkDecideEqGoal rectype a1 a2 g in  
+  (tclTHENS
+     (h_elim_type decide) 
+     [(eqCase tac);diseqCase;default_auto]) g
+
+let solveLeftBranch rectype g =
+  try
+    let (lhs,rhs) = match_eqdec_partial (pf_concl g) in
+    let (mib,mip) = Global.lookup_inductive rectype in
+    let nparams   = mip.mind_nparams in
+    let getargs l = list_skipn nparams (snd (decompose_app l)) in
+    let rargs   = getargs rhs
+    and largs   = getargs lhs in 
+    List.fold_right2 
+      solveArg largs rargs (tclTHEN h_simplest_left h_reflexivity) g
+  with PatternMatchingFailure -> error "Unexpected conclusion!"
+
+(* The tactic Decide Equality *)
+
+let hd_app c = match kind_of_term c with
+  | App (h,_) -> h
+  | _ -> c
+
+let decideGralEquality g =
+  try
+    let typ = match_eqdec (pf_concl g) in
+    let headtyp = hd_app (pf_compute g typ) in
+    let rectype =
+      match kind_of_term headtyp with
+        | Ind mi -> mi
+	| _ -> error "This decision procedure only works for inductive objects"
+    in 
+    (tclTHEN
+      mkBranches 
+      (tclORELSE h_solveRightBranch (solveLeftBranch rectype))) g
+  with PatternMatchingFailure ->
+    error "The goal does not have the expected form"
+
+
+let decideEquality c1 c2 g = 
+  let rectype = (pf_type_of g c1) in     
+  let decide  = mkGenDecideEqGoal rectype g in  
+  (tclTHENS (cut decide) [default_auto;decideGralEquality]) g
+
+
+(* The tactic Compare *)
+
+let compare c1 c2 g = 
+  let rectype = pf_type_of g c1 in
+  let decide  = mkDecideEqGoal rectype c1 c2 g in  
+  (tclTHENS (cut decide) 
+            [(tclTHEN  intro 
+             (tclTHEN (tclLAST_HYP simplest_case)
+                       clear_last));
+             decideEquality c1 c2]) g
+
+
+(* User syntax *)
+
+TACTIC EXTEND DecideEquality
+  [ "Decide" "Equality" constr(c1) constr(c2) ] -> [ decideEquality c1 c2 ]
+| [ "Decide" "Equality" ] -> [ decideGralEquality ]
+END
+
+TACTIC EXTEND Compare
+| [ "Compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ]
+END
+
diff --git a/tactics/equality.ml b/tactics/equality.ml
new file mode 100644
index 00000000..dd9054f5
--- /dev/null
+++ b/tactics/equality.ml
@@ -0,0 +1,1213 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: equality.ml,v 1.120.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Univ
+open Term
+open Termops
+open Inductive
+open Inductiveops
+open Environ
+open Reductionops
+open Instantiate
+open Typeops
+open Typing
+open Retyping
+open Tacmach
+open Proof_type
+open Logic
+open Evar_refiner
+open Pattern
+open Matching
+open Hipattern
+open Tacexpr
+open Tacticals
+open Tactics
+open Tacred
+open Rawterm
+open Coqlib
+open Vernacexpr
+open Setoid_replace
+open Declarations
+
+(* Rewriting tactics *)
+
+(* Warning : rewriting from left to right only works
+   if there exists in the context a theorem named <eqname>_<suffsort>_r
+   with type (A:<sort>)(x:A)(P:A->Prop)(P x)->(y:A)(eqname A y x)->(P y).
+   If another equality myeq is introduced, then corresponding theorems
+   myeq_ind_r, myeq_rec_r and myeq_rect_r have to be proven. See below.
+   -- Eduardo (19/8/97
+*)
+
+let general_rewrite_bindings lft2rgt (c,l) gl =
+  let ctype = pf_type_of gl c in 
+  let env = pf_env gl in
+  let sigma = project gl in 
+  let _,t = splay_prod env sigma ctype in
+  match match_with_equation t with
+    | None -> 
+	if l = NoBindings
+	then general_s_rewrite lft2rgt c gl
+	else error "The term provided does not end with an equation" 
+    | Some (hdcncl,_) -> 
+        let hdcncls = string_of_inductive hdcncl in 
+	let suffix = Indrec.elimination_suffix (elimination_sort_of_goal gl)in
+        let elim =
+	  if lft2rgt then
+            pf_global gl (id_of_string (hdcncls^suffix^"_r"))
+          else
+	    pf_global gl (id_of_string (hdcncls^suffix))
+        in 
+	tclNOTSAMEGOAL (general_elim (c,l) (elim,NoBindings) ~allow_K:false) gl
+   (* was tclWEAK_PROGRESS which only fails for tactics generating one subgoal 
+      and did not fail for useless conditional rewritings generating an
+      extra condition *)
+
+(* Conditional rewriting, the success of a rewriting is related 
+   to the resolution of the conditions by a given tactic *)
+
+let conditional_rewrite lft2rgt tac (c,bl) = 
+  tclTHENSFIRSTn (general_rewrite_bindings lft2rgt (c,bl))
+    [|tclIDTAC|] (tclCOMPLETE tac)
+
+let general_rewrite lft2rgt c = general_rewrite_bindings lft2rgt (c,NoBindings)
+
+let rewriteLR_bindings = general_rewrite_bindings true
+let rewriteRL_bindings = general_rewrite_bindings false
+
+let rewriteLR = general_rewrite true
+let rewriteRL = general_rewrite false
+
+(* The Rewrite in tactic *)
+let general_rewrite_in lft2rgt id (c,l) gl =
+  let ctype = pf_type_of gl c in 
+  let env = pf_env gl in
+  let sigma = project gl in 
+  let _,t = splay_prod env sigma ctype in
+  match match_with_equation t with
+    | None -> (* Do not deal with setoids yet *) 
+        error "The term provided does not end with an equation" 
+    | Some (hdcncl,_) -> 
+        let hdcncls = string_of_inductive hdcncl in 
+	let suffix =
+          Indrec.elimination_suffix (elimination_sort_of_hyp id gl) in
+        let rwr_thm =
+          if lft2rgt then hdcncls^suffix else hdcncls^suffix^"_r" in
+        let elim =
+	  try pf_global gl (id_of_string rwr_thm)
+          with Not_found ->
+            error ("Cannot find rewrite principle "^rwr_thm) in 
+	general_elim_in id (c,l) (elim,NoBindings) gl
+
+let rewriteLRin = general_rewrite_in true
+let rewriteRLin = general_rewrite_in false
+
+let conditional_rewrite_in lft2rgt id tac (c,bl) = 
+  tclTHENSFIRSTn (general_rewrite_in lft2rgt id (c,bl))
+    [|tclIDTAC|] (tclCOMPLETE tac)
+
+let rewriteRL_clause = function
+  | None -> rewriteRL_bindings
+  | Some id -> rewriteRLin id
+
+(* Replacing tactics *)
+
+(* eqt,sym_eqt : equality on Type and its symmetry theorem
+   c2 c1 : c1 is to be replaced by c2
+   unsafe : If true, do not check that c1 and c2 are convertible
+   gl : goal *)
+
+let abstract_replace clause c2 c1 unsafe gl =
+  let t1 = pf_type_of gl c1 
+  and t2 = pf_type_of gl c2 in
+  if unsafe or (pf_conv_x gl t1 t2) then
+    let e = (build_coq_eqT_data ()).eq in
+    let sym = (build_coq_eqT_data ()).sym in
+    let eq = applist (e, [t1;c1;c2]) in
+    tclTHENS (assert_tac false Anonymous eq)
+      [onLastHyp (fun id -> 
+	tclTHEN 
+	  (tclTRY (rewriteRL_clause clause (mkVar id,NoBindings)))
+	  (clear [id]));
+       tclORELSE assumption 
+	(tclTRY (tclTHEN (apply sym) assumption))] gl
+  else
+    error "terms does not have convertible types"
+
+let replace c2 c1 gl = abstract_replace None c2 c1 false gl
+
+let replace_in id c2 c1 gl = abstract_replace (Some id) c2 c1 false gl
+
+(* End of Eduardo's code. The rest of this file could be improved
+   using the functions match_with_equation, etc that I defined
+   in Pattern.ml.
+   -- Eduardo (19/8/97)
+*)
+
+(* Tactics for equality reasoning with the "eq"  or "eqT"
+   relation This code  will work with any equivalence relation which 
+   is substitutive *)
+
+(* Patterns *)
+
+let build_coq_eq eq = eq.eq
+let build_ind eq = eq.ind
+let build_rect eq = 
+  match eq.rect with
+    | None -> assert false
+    | Some c -> c
+	  
+(*********** List of constructions depending of the initial state *)
+
+let find_eq_pattern aritysort sort = 
+  (* "eq" now accept arguments in Type and elimination to Type *)
+  Coqlib.build_coq_eq ()
+
+(* [find_positions t1 t2]
+
+   will find the positions in the two terms which are suitable for
+   discrimination, or for injection.  Obviously, if there is a
+   position which is suitable for discrimination, then we want to
+   exploit it, and not bother with injection.  So when we find a
+   position which is suitable for discrimination, we will just raise
+   an exception with that position.
+
+   So the algorithm goes like this:
+
+   if [t1] and [t2] start with the same constructor, then we can
+   continue to try to find positions in the arguments of [t1] and
+   [t2].
+
+   if [t1] and [t2] do not start with the same constructor, then we
+   have found a discrimination position
+
+   if one [t1] or [t2] do not start with a constructor and the two
+   terms are not already convertible, then we have found an injection
+   position.
+
+   A discriminating position consists of a constructor-path and a pair
+   of operators.  The constructor-path tells us how to get down to the
+   place where the two operators, which must differ, can be found.
+
+   An injecting position has two terms instead of the two operators,
+   since these terms are different, but not manifestly so.
+
+   A constructor-path is a list of pairs of (operator * int), where
+   the int (based at 0) tells us which argument of the operator we
+   descended into.
+
+ *)
+
+exception DiscrFound of
+  (constructor * int) list * constructor * constructor
+
+let find_positions env sigma t1 t2 =
+  let rec findrec posn t1 t2 =
+    let hd1,args1 = whd_betadeltaiota_stack env sigma t1 in
+    let hd2,args2 = whd_betadeltaiota_stack env sigma t2 in
+    match (kind_of_term hd1, kind_of_term hd2) with
+  	
+      | Construct sp1, Construct sp2 
+          when List.length args1 = mis_constructor_nargs_env env sp1
+          ->
+        (* both sides are fully applied constructors, so either we descend,
+           or we can discriminate here. *)
+	  if sp1 = sp2 then
+            List.flatten
+	      (list_map2_i
+		 (fun i arg1 arg2 ->
+		    findrec ((sp1,i)::posn) arg1 arg2)
+		 0 args1 args2)
+	  else
+	    raise (DiscrFound(List.rev posn,sp1,sp2))
+
+      | _ ->
+	  let t1_0 = applist (hd1,args1) 
+          and t2_0 = applist (hd2,args2) in
+          if is_conv env sigma t1_0 t2_0 then 
+	    []
+          else
+	    let ty1_0 = get_type_of env sigma t1_0 in
+	    match get_sort_family_of env sigma ty1_0 with
+	      | InSet | InType -> [(List.rev posn,t1_0,t2_0)]
+	      | InProp -> []
+	  in 
+	  (try 
+	     Inr(findrec [] t1 t2)
+	   with DiscrFound (path,c1,c2) -> 
+	     Inl (path,c1,c2))
+
+let discriminable env sigma t1 t2 =
+  match find_positions env sigma t1 t2 with
+    | Inl _ -> true
+    | _ -> false
+
+(* Once we have found a position, we need to project down to it.  If
+   we are discriminating, then we need to produce False on one of the
+   branches of the discriminator, and True on the other one.  So the
+   result type of the case-expressions is always Prop.
+
+   If we are injecting, then we need to discover the result-type.
+   This can be difficult, since the type of the two terms at the
+   injection-position can be different, and we need to find a
+   dependent sigma-type which generalizes them both.
+
+   We can get an approximation to the right type to choose by:
+
+   (0) Before beginning, we reserve a patvar for the default
+   value of the match, to be used in all the bogus branches.
+
+   (1) perform the case-splits, down to the site of the injection.  At
+   each step, we have a term which is the "head" of the next
+   case-split.  At the point when we actually reach the end of our
+   path, the "head" is the term to return.  We compute its type, and
+   then, backwards, make a sigma-type with every free debruijn
+   reference in that type.  We can be finer, and first do a S(TRONG)NF
+   on the type, so that we get the fewest number of references
+   possible.
+
+   (2) This gives us a closed type for the head, which we use for the
+   types of all the case-splits.
+
+   (3) Now, we can compute the type of one of T1, T2, and then unify
+   it with the type of the last component of the result-type, and this
+   will give us the bindings for the other arguments of the tuple.
+
+ *)
+
+(* The algorithm, then is to perform successive case-splits.  We have
+   the result-type of the case-split, and also the type of that
+   result-type.  We have a "direction" we want to follow, i.e. a
+   constructor-number, and in all other "directions", we want to juse
+   use the default-value.
+
+   After doing the case-split, we call the afterfun, with the updated
+   environment, to produce the term for the desired "direction".
+
+   The assumption is made here that the result-type is not manifestly
+   functional, so we can just use the length of the branch-type to
+   know how many lambda's to stick in.
+
+ *)
+
+(* [descend_then sigma env head dirn]
+
+   returns the number of products introduced, and the environment
+   which is active, in the body of the case-branch given by [dirn],
+   along with a continuation, which expects to be fed:
+
+    (1) the value of the body of the branch given by [dirn]
+    (2) the default-value
+
+    (3) the type of the default-value, which must also be the type of
+        the body of the [dirn] branch
+
+   the continuation then constructs the case-split.
+ *)
+let descend_then sigma env head dirn =
+  let IndType (indf,_) as indt =
+    try find_rectype env sigma (get_type_of env sigma head)
+    with Not_found -> assert false in
+  let ind,_ = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let cstr = get_constructors env indf in
+  let dirn_nlams = cstr.(dirn-1).cs_nargs in
+  let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in
+  (dirn_nlams,
+   dirn_env,
+   (fun dirnval (dfltval,resty) ->
+      let arign,_ = get_arity env indf in
+      let p = it_mkLambda_or_LetIn (lift mip.mind_nrealargs resty) arign in
+      let build_branch i =
+	let result = if i = dirn then dirnval else dfltval in
+	it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in
+      let brl =
+        List.map build_branch
+          (interval 1 (Array.length mip.mind_consnames)) in
+      let ci = make_default_case_info env RegularStyle ind in
+      mkCase (ci, p, head, Array.of_list brl)))
+  
+(* Now we need to construct the discriminator, given a discriminable
+   position.  This boils down to:
+
+   (1) If the position is directly beneath us, then we need to do a
+   case-split, with result-type Prop, and stick True and False into
+   the branches, as is convenient.
+
+   (2) If the position is not directly beneath us, then we need to
+   call descend_then, to descend one step, and then recursively
+   construct the discriminator.
+
+ *)
+
+(* [construct_discriminator env dirn headval]
+   constructs a case-split on [headval], with the [dirn]-th branch
+   giving [True], and all the rest giving False. *)
+
+let construct_discriminator sigma env dirn c sort =
+  let (IndType(indf,_) as indt) =
+    try find_rectype env sigma (type_of env sigma c)
+    with Not_found ->
+       (* one can find Rel(k) in case of dependent constructors 
+          like T := c : (A:Set)A->T and a discrimination 
+          on (c bool true) = (c bool false)
+          CP : changed assert false in a more informative error
+       *)
+      errorlabstrm "Equality.construct_discriminator"
+	(str "Cannot discriminate on inductive constructors with 
+		 dependent types") in
+  let (ind,_) = dest_ind_family indf in
+  let (mib,mip) = lookup_mind_specif env ind in
+  let arsign,arsort = get_arity env indf in
+  let (true_0,false_0,sort_0) = build_coq_True(),build_coq_False(),Prop Null in
+  let p = it_mkLambda_or_LetIn (mkSort sort_0) arsign in
+  let cstrs = get_constructors env indf in
+  let build_branch i =
+    let endpt = if i = dirn then true_0 else false_0 in
+    it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in
+  let brl =
+    List.map build_branch(interval 1 (Array.length mip.mind_consnames)) in
+  let ci = make_default_case_info env RegularStyle ind in
+  mkCase (ci, p, c, Array.of_list brl)
+    
+let rec build_discriminator sigma env dirn c sort = function
+  | [] -> construct_discriminator sigma env dirn c sort
+  | ((sp,cnum),argnum)::l ->
+      let cty = type_of env sigma c in
+      let IndType (indf,_) =
+	try find_rectype env sigma cty with Not_found -> assert false in
+      let (ind,_) = dest_ind_family indf in
+      let (mib,mip) = lookup_mind_specif env ind in
+      let _,arsort = get_arity env indf in
+      let nparams = mip.mind_nparams  in
+      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let newc = mkRel(cnum_nlams-(argnum-nparams)) in
+      let subval = build_discriminator sigma cnum_env dirn newc sort l  in
+      kont subval (build_coq_False (),mkSort (Prop Null))
+
+let gen_absurdity id gl =
+  if is_empty_type (clause_type (onHyp id) gl)
+  then
+    simplest_elim (mkVar id) gl
+  else
+    errorlabstrm "Equality.gen_absurdity" 
+      (str "Not the negation of an equality")
+
+(* Precondition: eq is leibniz equality
+ 
+  returns ((eq_elim t t1 P i t2), absurd_term)
+  where  P=[e:t]discriminator 
+         absurd_term=False
+*)
+
+let discrimination_pf e (t,t1,t2) discriminator lbeq gls =
+  let i           = build_coq_I () in
+  let absurd_term = build_coq_False () in
+  let eq_elim     = build_ind lbeq in
+  (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term)
+
+exception NotDiscriminable
+
+let discr id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let sort = pf_type_of gls (pf_concl gls) in 
+  let (lbeq,(t,t1,t2)) =
+    try find_eq_data_decompose eqn
+    with PatternMatchingFailure ->
+      errorlabstrm "discr" (pr_id id ++ str": not a primitive equality here")
+  in
+  let sigma = project gls in
+  let env = pf_env gls in
+  (match find_positions env sigma t1 t2 with
+     | Inr _ ->
+	 errorlabstrm "discr" (str" Not a discriminable equality")
+     | Inl (cpath, (_,dirn), _) ->
+	 let e = pf_get_new_id (id_of_string "ee") gls in
+	 let e_env = push_named (e,None,t) env in
+	 let discriminator =
+	   build_discriminator sigma e_env dirn (mkVar e) sort cpath in
+	 let (indt,_) = find_mrectype env sigma t in 
+	 let (pf, absurd_term) =
+	   discrimination_pf e (t,t1,t2) discriminator lbeq gls 
+	 in
+	 tclCOMPLETE((tclTHENS (cut_intro absurd_term)
+			([onLastHyp gen_absurdity;
+			  refine (mkApp (pf, [| mkVar id |]))]))) gls)
+
+
+let not_found_message id =
+  (str "The variable" ++ spc () ++ str (string_of_id id) ++ spc () ++
+    str" was not found in the current environment")
+
+let onNegatedEquality tac gls =
+  if is_matching_not (pf_concl gls) then
+    (tclTHEN (tclTHEN hnf_in_concl intro) (onLastHyp tac)) gls
+  else if is_matching_imp_False (pf_concl gls)then
+    (tclTHEN intro (onLastHyp tac)) gls
+  else 
+    errorlabstrm "extract_negated_equality_then"
+      (str"The goal should negate an equality")
+
+
+let discrSimpleClause = function
+  | None -> onNegatedEquality discr
+  | Some (id,_,_) -> discr id
+
+let discrClause = onClauses discrSimpleClause
+
+let discrEverywhere = 
+  tclORELSE
+    (Tacticals.tryAllClauses discrSimpleClause)
+    (fun gls -> 
+       errorlabstrm "DiscrEverywhere" (str" No discriminable equalities"))
+
+let discr_tac = function
+  | None -> discrEverywhere
+  | Some id -> try_intros_until discr id
+
+let discrConcl gls  = discrClause onConcl gls
+let discrHyp id gls = discrClause (onHyp id) gls
+
+(* returns the sigma type (sigS, sigT) with the respective
+    constructor depending on the sort *)
+
+let find_sigma_data s =
+  match s with  
+    | Prop Pos  -> build_sigma_set ()                    (* Set *) 
+    | Type _    -> build_sigma_type ()                   (* Type *)
+    | Prop Null -> error "find_sigma_data"
+
+(* [make_tuple env sigma (rterm,rty) lind] assumes [lind] is the lesser
+   index bound in [rty]
+
+   Then we build the term
+
+     [(existS A P (mkRel lind) rterm)] of type [(sigS A P)]
+
+   where [A] is the type of [mkRel lind] and [P] is [\na:A.rty{1/lind}]
+ *)
+
+let make_tuple env sigma (rterm,rty) lind =
+  assert (dependent (mkRel lind) rty);
+  let {intro = exist_term; typ = sig_term} =
+    find_sigma_data (get_sort_of env sigma rty) in
+  let a = type_of env sigma (mkRel lind) in
+  let (na,_,_) = lookup_rel lind env in
+  (* We move [lind] to [1] and lift other rels > [lind] by 1 *)
+  let rty = lift (1-lind) (liftn lind (lind+1) rty) in
+  (* Now [lind] is [mkRel 1] and we abstract on (na:a) *)
+  let p = mkLambda (na, a, rty) in
+  (applist(exist_term,[a;p;(mkRel lind);rterm]),
+   applist(sig_term,[a;p]))
+
+(* check that the free-references of the type of [c] are contained in
+   the free-references of the normal-form of that type.  If the normal
+   form of the type contains fewer references, we want to return that
+   instead. *)
+
+let minimal_free_rels env sigma (c,cty) =
+  let cty_rels = free_rels cty in
+  let nf_cty = nf_betadeltaiota env sigma cty in
+  let nf_rels = free_rels nf_cty in
+  if Intset.subset cty_rels nf_rels then
+    (cty,cty_rels)
+  else
+    (nf_cty,nf_rels)
+
+(* [sig_clausal_form siglen ty]
+    
+   Will explode [siglen] [sigS,sigT ]'s on [ty] (depending on the 
+   type of ty), and return:
+
+   (1) a pattern, with meta-variables in it for various arguments,
+       which, when the metavariables are replaced with appropriate
+       terms, will have type [ty]
+
+   (2) an integer, which is the last argument - the one which we just
+       returned.
+
+   (3) a pattern, for the type of that last meta
+
+   (4) a typing for each patvar
+
+   WARNING: No checking is done to make sure that the 
+            sigS(or sigT)'s are actually there.
+          - Only homogenious pairs are built i.e. pairs where all the 
+   dependencies are of the same sort
+
+   [sig_clausal_form] proceed as follows: the default tuple is
+   constructed by taking the tuple-type, exploding the first [tuplen]
+   [sigS]'s, and replacing at each step the binder in the
+   right-hand-type by a fresh metavariable. In addition, on the way
+   back out, we will construct the pattern for the tuple which uses
+   these meta-vars.
+
+   This gives us a pattern, which we use to match against the type of
+   [dflt]; if that fails, then against the S(TRONG)NF of that type.  If
+   both fail, then we just cannot construct our tuple.  If one of
+   those succeed, then we can construct our value easily - we just use
+   the tuple-pattern.
+
+ *)
+
+let sig_clausal_form env sigma sort_of_ty siglen ty (dFLT,dFLTty) =
+  let { intro = exist_term } = find_sigma_data sort_of_ty in 
+  let isevars = Evarutil.create_evar_defs sigma in
+  let rec sigrec_clausal_form siglen p_i =
+    if siglen = 0 then
+      if Evarconv.the_conv_x env isevars p_i dFLTty then
+	(* the_conv_x had a side-effect on isevars *)
+	dFLT
+      else
+	error "Cannot solve an unification problem"
+    else
+      let (a,p_i_minus_1) = match whd_beta_stack p_i with
+	| (_sigS,[a;p]) -> (a,p)
+ 	| _ -> anomaly "sig_clausal_form: should be a sigma type" in
+      let ev = Evarutil.new_isevar isevars env (dummy_loc,InternalHole)
+	(Evarutil.new_Type ()) in
+      let rty = beta_applist(p_i_minus_1,[ev]) in
+      let tuple_tail = sigrec_clausal_form (siglen-1) rty in
+      match
+	Instantiate.existential_opt_value (Evarutil.evars_of isevars) 
+	(destEvar ev)
+      with
+	| Some w -> applist(exist_term,[a;p_i_minus_1;w;tuple_tail])
+	| None -> anomaly "Not enough components to build the dependent tuple"
+  in
+  let scf = sigrec_clausal_form siglen ty in
+  Evarutil.nf_evar (Evarutil.evars_of isevars) scf
+
+(* The problem is to build a destructor (a generalization of the
+   predecessor) which, when applied to a term made of constructors
+   (say [Ci(e1,Cj(e2,Ck(...,term,...),...),...)]), returns a given
+   subterm of the term (say [term]).
+
+   Let [typ] be the type of [term]. If [term] has no dependencies in
+   the [e1], [e2], etc, then all is simple. If not, then we need to
+   encapsulated the dependencies into a dependent tuple in such a way
+   that the destructor has not a dependent type and rewriting can then
+   be applied. The destructor has the form
+
+   [e]Cases e of
+      | ...
+      | Ci (x1,x2,...) =>
+          Cases x2 of
+          | ...
+          | Cj (y1,y2,...) =>
+              Cases y2 of
+              | ...
+              | Ck (...,z,...) => z
+              | ... end
+          | ... end
+      | ... end
+
+   and the dependencies is expressed by the fact that [z] has a type
+   dependent in the x1, y1, ...
+
+   Assume [z] is typed as follows: env |- z:zty
+
+   If [zty] has no dependencies, this is simple. Otherwise, assume
+   [zty] has free (de Bruijn) variables in,...i1 then the role of
+   [make_iterated_tuple sigma env (term,typ) (z,zty)] is to build the
+   tuple
+
+   [existS [xn]Pn Rel(in) .. (existS [x2]P2 Rel(i2) (existS [x1]P1 Rel(i1) z))]
+
+   where P1 is zty[i1/x1], P2 is {x1 | P1[i2/x2]} etc.
+
+   To do this, we find the free (relative) references of the strong NF
+   of [z]'s type, gather them together in left-to-right order
+   (i.e. highest-numbered is farthest-left), and construct a big
+   iterated pair out of it. This only works when the references are
+   all themselves to members of [Set]s, because we use [sigS] to
+   construct the tuple.
+
+   Suppose now that our constructed tuple is of length [tuplen]. We
+   need also to construct a default value for the other branches of
+   the destructor. As default value, we take a tuple of the form
+
+    [existS [xn]Pn ?n (... existS [x2]P2 ?2 (existS [x1]P1 ?1 term))]
+
+   but for this we have to solve the following unification problem:
+
+     typ = zty[i1/?1;...;in/?n]
+
+   This is done by [sig_clausal_form].
+ *)
+
+let make_iterated_tuple env sigma dflt (z,zty) =
+  let (zty,rels) = minimal_free_rels env sigma (z,zty) in
+  let sort_of_zty = get_sort_of env sigma zty in
+  let sorted_rels = Sort.list (<) (Intset.elements rels) in
+  let (tuple,tuplety) =
+    List.fold_left (make_tuple env sigma) (z,zty) sorted_rels 
+  in
+  assert (closed0 tuplety);
+  let n = List.length sorted_rels in
+  let dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in
+  (tuple,tuplety,dfltval)
+
+let rec build_injrec sigma env (t1,t2) c = function
+  | [] ->
+      make_iterated_tuple env sigma (t1,type_of env sigma t1)
+        (c,type_of env sigma c)
+  | ((sp,cnum),argnum)::l ->
+      let cty = type_of env sigma c in
+      let (ity,_) = find_mrectype env sigma cty in
+      let (mib,mip) = lookup_mind_specif env ity in
+      let nparams = mip.mind_nparams in
+      let (cnum_nlams,cnum_env,kont) = descend_then sigma env c cnum in
+      let newc = mkRel(cnum_nlams-(argnum-nparams)) in
+      let (subval,tuplety,dfltval) =
+      	build_injrec sigma cnum_env (t1,t2) newc l
+      in
+      (kont subval (dfltval,tuplety),
+       tuplety,dfltval)
+
+let build_injector sigma env (t1,t2) c cpath =
+  let (injcode,resty,_) = build_injrec sigma env (t1,t2) c cpath in
+  (injcode,resty)
+
+let try_delta_expand env sigma t =
+  let whdt = whd_betadeltaiota env sigma t  in 
+  let rec hd_rec c  =
+    match kind_of_term c with
+      | Construct _ -> whdt
+      | App (f,_)  -> hd_rec f
+      | Cast (c,_) -> hd_rec c
+      | _  -> t
+  in 
+  hd_rec whdt 
+
+(* Given t1=t2 Inj calculates the whd normal forms of t1 and t2 and it 
+   expands then only when the whdnf has a constructor of an inductive type
+   in hd position, otherwise delta expansion is not done *)
+
+let inj id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let (eq,(t,t1,t2))= 
+    try find_eq_data_decompose eqn
+    with PatternMatchingFailure ->
+      errorlabstrm "Inj" (pr_id id ++ str": not a primitive equality here") 
+  in
+  let sigma = project gls in
+  let env = pf_env gls in
+  match find_positions env sigma t1 t2 with
+    | Inl _ ->
+	errorlabstrm "Inj"
+	  (str (string_of_id id) ++
+	    str" is not a projectable equality but a discriminable one")
+    | Inr [] ->
+	errorlabstrm "Equality.inj" 
+	   (str"Nothing to do, it is an equality between convertible terms")
+    | Inr posns ->
+	let e = pf_get_new_id (id_of_string "e") gls in
+	let e_env = push_named (e,None,t) env in
+	let injectors =
+	  map_succeed
+	    (fun (cpath,t1_0,t2_0) ->
+	      try 
+		let (injbody,resty) =
+		  build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in
+		let injfun = mkNamedLambda e t injbody in
+		let _ = type_of env sigma injfun in (injfun,resty)
+	      with e when catchable_exception e ->
+		(* may fail because ill-typed or because of a Prop argument *)
+		(* error "find_sigma_data" *)
+		failwith "caught")
+            posns
+	in
+	if injectors = [] then
+	  errorlabstrm "Equality.inj" 
+	    (str "Failed to decompose the equality");
+	tclMAP 
+	  (fun (injfun,resty) ->
+	     let pf = applist(eq.congr,
+			      [t;resty;injfun;
+			       try_delta_expand env sigma t1;
+			       try_delta_expand env sigma t2;
+			       mkVar id]) 
+	     in
+	     let ty =
+	       try pf_nf gls (pf_type_of gls pf)
+               with
+		 | UserError("refiner__fail",_) -> 
+		     errorlabstrm "InjClause" 
+		(str (string_of_id id) ++ str" Not a projectable equality")
+	     in ((tclTHENS  (cut  ty) ([tclIDTAC;refine pf]))))
+	  injectors
+	  gls
+	    
+let injClause = function
+  | None -> onNegatedEquality inj
+  | Some id -> try_intros_until inj id
+
+let injConcl gls  = injClause None gls
+let injHyp id gls = injClause (Some id) gls
+
+let decompEqThen ntac id gls =
+  let eqn = pf_whd_betadeltaiota gls (pf_get_hyp_typ gls id) in
+  let (lbeq,(t,t1,t2))= find_eq_data_decompose eqn in
+  let sort = pf_type_of gls (pf_concl gls) in 
+  let sigma = project gls in
+  let env = pf_env gls in 
+  (match find_positions env sigma t1 t2 with
+     | Inl (cpath, (_,dirn), _) ->
+	 let e = pf_get_new_id (id_of_string "e") gls in
+	 let e_env = push_named (e,None,t) env in
+	 let discriminator =
+	   build_discriminator sigma e_env dirn (mkVar e) sort cpath in
+	 let (pf, absurd_term) =
+	   discrimination_pf e (t,t1,t2) discriminator lbeq gls in
+	 tclCOMPLETE
+	   ((tclTHENS (cut_intro absurd_term)
+	       ([onLastHyp gen_absurdity;
+		 refine (mkApp (pf, [| mkVar id |]))]))) gls
+     | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *)
+         ntac 0 gls
+     | Inr posns ->
+	 (let e = pf_get_new_id (id_of_string "e") gls in
+	  let e_env = push_named (e,None,t) env in
+	  let injectors =
+	    map_succeed
+	      (fun (cpath,t1_0,t2_0) ->
+		 let (injbody,resty) =
+		   build_injector sigma e_env (t1_0,t2_0) (mkVar e) cpath in
+		 let injfun = mkNamedLambda e t injbody in
+		 try 
+		   let _ = type_of env sigma injfun in (injfun,resty)
+		 with e when catchable_exception e -> failwith "caught")
+	      posns 
+	  in
+	  if injectors = [] then
+	    errorlabstrm "Equality.decompEqThen" 
+              (str "Discriminate failed to decompose the equality");
+	  (tclTHEN
+	      (tclMAP (fun (injfun,resty) ->
+			 let pf = applist(lbeq.congr,
+					  [t;resty;injfun;t1;t2;
+					   mkVar id]) in
+			 let ty = pf_nf gls (pf_type_of gls pf) in
+			 ((tclTHENS (cut ty) 
+			     ([tclIDTAC;refine pf]))))
+		 (List.rev injectors))
+	      (ntac (List.length injectors)))
+	  gls))
+
+let decompEq = decompEqThen (fun x -> tclIDTAC)
+
+let dEqThen ntac = function
+  | None -> onNegatedEquality (decompEqThen ntac)
+  | Some id -> try_intros_until (decompEqThen ntac) id
+
+let dEq = dEqThen (fun x -> tclIDTAC)
+
+let dEqConcl gls = dEq None gls
+let dEqHyp id gls = dEq (Some id) gls
+
+let rewrite_msg = function 
+  | None -> str "passed term is not a primitive equality" 
+  | Some id -> pr_id id ++ str "does not satisfy preconditions "
+
+let swap_equands gls eqn =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in 
+  applist(lbeq.eq,[t;e2;e1])
+
+let swapEquandsInConcl gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose (pf_concl gls) in
+  let sym_equal = lbeq.sym in
+  refine (applist(sym_equal,[t;e2;e1;mkMeta (Clenv.new_meta())])) gls
+
+let swapEquandsInHyp id gls =
+  ((tclTHENS (cut_replacing id (swap_equands gls (pf_get_hyp_typ gls id)))
+      ([tclIDTAC;
+      	(tclTHEN (swapEquandsInConcl) (exact_no_check (mkVar id)))]))) gls
+
+(* find_elim determines which elimination principle is necessary to
+   eliminate lbeq on sort_of_gl. It yields the boolean true wether
+   it is a dependent elimination principle (as idT.rect) and false
+   otherwise *)
+
+let find_elim  sort_of_gl  lbeq =
+  match kind_of_term sort_of_gl  with
+    | Sort(Prop Null)  (* Prop *)  -> (lbeq.ind, false)  
+    | Sort(Prop Pos)   (* Set *)   ->  
+	(match lbeq.rrec with
+           | Some eq_rec -> (eq_rec, false) 
+	   | None -> errorlabstrm "find_elim"
+		 (str "this type of elimination is not allowed"))
+    | _ (* Type *) -> 
+        (match lbeq.rect with
+           | Some eq_rect -> (eq_rect, true) 
+           | None -> errorlabstrm "find_elim"
+		 (str "this type of elimination is not allowed"))
+
+(* builds a predicate [e:t][H:(lbeq t e t1)](body e)
+   to be used as an argument for equality dependent elimination principle:
+   Preconditon: dependent body (mkRel 1) *)
+
+let build_dependent_rewrite_predicate (t,t1,t2) body lbeq gls =
+  let e = pf_get_new_id  (id_of_string "e") gls in 
+  let h = pf_get_new_id  (id_of_string "HH") gls in 
+  let eq_term = lbeq.eq in
+  (mkNamedLambda e t 
+     (mkNamedLambda h (applist (eq_term, [t;t1;(mkRel 1)])) 
+        (lift 1 body))) 
+
+(* builds a predicate [e:t](body e) ???
+   to be used as an argument for equality non-dependent elimination principle:
+   Preconditon: dependent body (mkRel 1) *)
+
+let build_non_dependent_rewrite_predicate (t,t1,t2) body gls =
+  lambda_create (pf_env gls) (t,body)
+
+let bareRevSubstInConcl lbeq body (t,e1,e2) gls =
+  let (eq_elim,dep) =
+    try 
+      find_elim (pf_type_of gls (pf_concl gls)) lbeq  
+    with e when catchable_exception e -> 
+      errorlabstrm "RevSubstIncConcl"
+        (str "this type of substitution is not allowed")  
+  in 
+  let p =
+    if dep then
+      (build_dependent_rewrite_predicate (t,e1,e2)  body lbeq gls)
+    else
+      (build_non_dependent_rewrite_predicate (t,e1,e2)  body  gls)
+  in
+  refine (applist(eq_elim,[t;e1;p;mkMeta(Clenv.new_meta());
+                           e2;mkMeta(Clenv.new_meta())])) gls
+
+(* [subst_tuple_term dep_pair B]
+
+   Given that dep_pair looks like:
+
+   (existS e1 (existS e2 ... (existS en en+1) ... ))
+
+   and B might contain instances of the ei, we will return the term:
+
+   ([x1:ty(e1)]...[xn:ty(en)]B
+    (projS1 (mkRel 1))
+    (projS1 (projS2 (mkRel 1)))
+    ... etc ...)
+
+   That is, we will abstract out the terms e1...en+1 as usual, but
+   will then produce a term in which the abstraction is on a single
+   term - the debruijn index [mkRel 1], which will be of the same type
+   as dep_pair.
+
+   ALGORITHM for abstraction:
+
+   We have a list of terms, [e1]...[en+1], which we want to abstract
+   out of [B].  For each term [ei], going backwards from [n+1], we
+   just do a [subst_term], and then do a lambda-abstraction to the
+   type of the [ei].
+
+ *)
+
+let decomp_tuple_term env c t = 
+  let rec decomprec inner_code ex exty =
+    try
+      let {proj1 = p1; proj2 = p2 },(a,p,car,cdr) =
+	find_sigma_data_decompose ex in
+      let car_code = applist (p1,[a;p;inner_code])
+      and cdr_code = applist (p2,[a;p;inner_code]) in
+      let cdrtyp = beta_applist (p,[car]) in
+      ((car,a),car_code)::(decomprec cdr_code cdr cdrtyp)
+    with PatternMatchingFailure ->
+      [((ex,exty),inner_code)]
+  in
+  List.split (decomprec (mkRel 1) c t)
+
+let subst_tuple_term env sigma dep_pair b =
+  let typ = get_type_of env sigma dep_pair in
+  let e_list,proj_list = decomp_tuple_term env dep_pair typ in
+  let abst_B =
+    List.fold_right
+      (fun (e,t) body -> lambda_create env (t,subst_term e body)) e_list b in
+  let app_B = applist(abst_B,proj_list) in app_B
+    
+(* |- (P e2)
+     BY RevSubstInConcl (eq T e1 e2)
+     |- (P e1)
+     |- (eq T e1 e2)
+ *)
+(* Redondant avec Replace ! *)
+
+let substInConcl_RL eqn gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in
+  let body = subst_tuple_term (pf_env gls) (project gls) e2 (pf_concl gls) in
+  assert (dependent (mkRel 1) body);
+  bareRevSubstInConcl lbeq body (t,e1,e2) gls
+
+(* |- (P e1)
+     BY SubstInConcl (eq T e1 e2)
+     |- (P e2)
+     |- (eq T e1 e2)
+ *)
+let substInConcl_LR eqn gls =
+  (tclTHENS (substInConcl_RL (swap_equands gls eqn))
+     ([tclIDTAC;
+       swapEquandsInConcl])) gls
+
+let substInConcl l2r = if l2r then substInConcl_LR else substInConcl_RL
+
+let substInHyp_LR eqn id gls =
+  let (lbeq,(t,e1,e2)) = find_eq_data_decompose eqn in 
+  let body = subst_term e1 (pf_get_hyp_typ gls id) in
+  if not (dependent (mkRel 1) body) then errorlabstrm  "SubstInHyp" (mt ());
+  (tclTHENS (cut_replacing id (subst1 e2 body))
+     ([tclIDTAC;
+       (tclTHENS (bareRevSubstInConcl lbeq body (t,e1,e2))
+          ([exact_no_check (mkVar id);tclIDTAC]))])) gls
+
+let substInHyp_RL eqn id gls =
+  (tclTHENS (substInHyp_LR (swap_equands gls eqn) id)
+     ([tclIDTAC;
+       swapEquandsInConcl])) gls
+
+let substInHyp l2r = if l2r then substInHyp_LR else substInHyp_RL
+
+let try_rewrite tac gls =
+  try 
+    tac gls
+  with 
+    | PatternMatchingFailure ->
+	errorlabstrm "try_rewrite" (str "Not a primitive equality here")
+    | e when catchable_exception e -> 
+	errorlabstrm "try_rewrite"
+          (str "Cannot find a well-typed generalization of the goal that" ++
+             str " makes the proof progress")
+
+let subst l2r eqn cls gls =
+  match cls with
+    | None ->    substInConcl l2r eqn gls
+    | Some id -> substInHyp l2r eqn id gls
+
+(* |- (P a)
+ * SubstConcl_LR a=b 
+ *  |- (P b)
+ *  |- a=b
+ *)
+
+let substConcl l2r eqn gls = try_rewrite (subst l2r eqn None) gls
+let substConcl_LR = substConcl true
+
+(* id:(P a) |- G
+ * SubstHyp a=b id
+ *  id:(P b) |- G
+ *  id:(P a) |-a=b
+*)
+
+let hypSubst l2r id cls gls =
+  onClauses (function
+    | None -> 
+	(tclTHENS (substInConcl l2r (pf_get_hyp_typ gls id))
+	   ([tclIDTAC; exact_no_check (mkVar id)]))
+    | Some (hypid,_,_) -> 
+	(tclTHENS (substInHyp l2r (pf_get_hyp_typ gls id) hypid)
+	   ([tclIDTAC;exact_no_check (mkVar id)])))
+    cls gls
+
+let hypSubst_LR = hypSubst true
+
+(* id:a=b |- (P a)
+ * HypSubst id.
+ *  id:a=b |- (P b)
+ *)
+let substHypInConcl l2r id gls = try_rewrite (hypSubst l2r id onConcl) gls
+let substHypInConcl_LR = substHypInConcl true
+
+(* id:a=b H:(P a) |- G
+   SubstHypInHyp id H.
+    id:a=b H:(P b) |- G
+*)
+(* |- (P b)
+   SubstConcl_RL a=b
+     |- (P a)
+     |- a=b
+*)
+let substConcl_RL = substConcl false
+
+(* id:(P b) |-G
+   SubstHyp_RL a=b id 
+      id:(P a) |- G
+      |- a=b  
+*)
+let substHyp l2r eqn id gls = try_rewrite (subst l2r eqn (Some id)) gls
+let substHyp_RL = substHyp false
+
+let hypSubst_RL = hypSubst false
+
+(* id:a=b |- (P b)
+ * HypSubst id.
+ * id:a=b |- (P a)
+ *)
+let substHypInConcl_RL = substHypInConcl false
+
+(* id:a=b H:(P b) |- G
+   SubstHypInHyp id H.
+    id:a=b H:(P a) |- G
+*)
+
+(* Substitutions tactics (JCF) *)
+
+let unfold_body x gl =
+  let hyps = pf_hyps gl in
+  let xval =
+    match Sign.lookup_named x hyps with
+        (_,Some xval,_) -> xval
+      | _ -> errorlabstrm "unfold_body"
+          (pr_id x ++ str" is not a defined hypothesis") in
+  let aft = afterHyp x gl in
+  let hl = List.fold_right
+    (fun (y,yval,_) cl -> (y,[],(InHyp,ref None)) :: cl) aft [] in
+  let xvar = mkVar x in
+  let rfun _ _ c = replace_term xvar xval c in
+  tclTHENLIST
+    [tclMAP (fun h -> reduct_in_hyp rfun h) hl;
+     reduct_in_concl rfun] gl
+
+
+
+
+exception FoundHyp of (identifier * constr * bool)
+
+(* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *)
+let is_eq_x x (id,_,c) =
+  try
+    let (_,lhs,rhs) = snd (find_eq_data_decompose c) in
+    if (x = lhs) && not (occur_term x rhs) then raise (FoundHyp (id,rhs,true));
+    if (x = rhs) && not (occur_term x lhs) then raise (FoundHyp (id,lhs,false))
+  with PatternMatchingFailure ->
+    ()
+
+let subst_one x gl = 
+  let hyps = pf_hyps gl in
+  let (_,xval,_) = pf_get_hyp gl x in
+  (* If x has a body, simply replace x with body and clear x *)
+  if xval <> None then tclTHEN (unfold_body x) (clear [x]) gl else
+  (* x is a variable: *)
+  let varx = mkVar x in
+  (* Find a non-recursive definition for x *)
+  let (hyp,rhs,dir) = 
+    try
+      let test hyp _ = is_eq_x varx hyp in
+      Sign.fold_named_context test ~init:() hyps;
+      errorlabstrm "Subst"
+        (str "cannot find any non-recursive equality over " ++ pr_id x)
+    with FoundHyp res -> res
+  in
+  (* The set of hypotheses using x *)
+  let depdecls = 
+    let test (id,_,c as dcl) = 
+      if id <> hyp && occur_var_in_decl (pf_env gl) x dcl then dcl
+      else failwith "caught" in
+    List.rev (map_succeed test hyps) in
+  let dephyps = List.map (fun (id,_,_) -> id) depdecls in
+  (* Decides if x appears in conclusion *)
+  let depconcl = occur_var (pf_env gl) x (pf_concl gl) in
+  (* The set of non-defined hypothesis: they must be abstracted,
+     rewritten and reintroduced *)
+  let abshyps =
+    map_succeed
+      (fun (id,v,_) -> if v=None then mkVar id else failwith "caught")
+      depdecls in
+  (* a tactic that either introduce an abstracted and rewritten hyp,
+     or introduce a definition where x was replaced *)
+  let introtac = function
+      (id,None,_) -> intro_using id
+    | (id,Some hval,htyp) ->
+        forward true (Name id) (mkCast(replace_term varx rhs hval,
+                                       replace_term varx rhs htyp)) in
+  let need_rewrite = dephyps <> [] || depconcl in
+  tclTHENLIST 
+    ((if need_rewrite then
+      [generalize abshyps;
+       (if dir then rewriteLR else rewriteRL) (mkVar hyp);
+       thin dephyps;
+       tclMAP introtac depdecls]
+    else
+      [thin dephyps;
+       tclMAP introtac depdecls]) @
+     [tclTRY (clear [x;hyp])]) gl
+
+let subst = tclMAP subst_one
+
+let subst_all gl =
+  let test (_,c) =
+    try
+      let (_,x,y) = snd (find_eq_data_decompose c) in
+      match kind_of_term x with Var x -> x | _ -> 
+      match kind_of_term y with Var y -> y | _ -> failwith "caught"
+    with PatternMatchingFailure -> failwith "caught"
+  in
+  let ids = map_succeed test (pf_hyps_types gl) in
+  let ids = list_uniquize ids in
+  subst ids gl
+
+(* Rewrite the first assumption for which the condition faildir does not fail 
+   and gives the direction of the rewrite *)
+
+let rewrite_assumption_cond faildir gl =
+   let rec arec = function
+      | [] -> error "No such assumption"
+      | (id,_,t)::rest -> 
+	  (try let dir = faildir t gl in 
+	       general_rewrite dir (mkVar id) gl
+	   with Failure _ | UserError _  ->  arec rest)
+   in arec (pf_hyps gl)
+
+
+let rewrite_assumption_cond_in faildir hyp gl =
+   let rec arec = function
+      | [] -> error "No such assumption"
+      | (id,_,t)::rest -> 
+	  (try let dir = faildir t gl in 
+	       general_rewrite_in dir hyp ((mkVar id),NoBindings) gl
+	   with Failure _ | UserError _ ->  arec rest)
+   in arec (pf_hyps gl)
+
+let cond_eq_term_left c t gl =
+  try
+    let (_,x,_) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then true else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let cond_eq_term_right c t gl = 
+  try
+    let (_,_,x) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then false else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let cond_eq_term c t gl = 
+  try
+    let (_,x,y) = snd (find_eq_data_decompose t) in
+    if pf_conv_x gl c x then true 
+    else if pf_conv_x gl c y then false
+    else failwith "not convertible"
+  with PatternMatchingFailure -> failwith "not an equality"
+
+let replace_term_left t = rewrite_assumption_cond (cond_eq_term_left t)
+
+let replace_term_right t = rewrite_assumption_cond (cond_eq_term_right t)
+   
+let replace_term t = rewrite_assumption_cond (cond_eq_term t)
+   
+let replace_term_in_left t = rewrite_assumption_cond_in (cond_eq_term_left t)
+
+let replace_term_in_right t = rewrite_assumption_cond_in (cond_eq_term_right t)
+   
+let replace_term_in t = rewrite_assumption_cond_in (cond_eq_term t)
diff --git a/tactics/equality.mli b/tactics/equality.mli
new file mode 100644
index 00000000..ab439c39
--- /dev/null
+++ b/tactics/equality.mli
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: equality.mli,v 1.26.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Evd
+open Environ
+open Proof_type
+open Tacmach
+open Hipattern
+open Pattern
+open Tacticals
+open Tactics
+open Tacexpr
+open Rawterm
+(*i*)
+
+val find_eq_pattern : sorts -> sorts -> constr
+
+val general_rewrite_bindings : bool -> constr with_bindings -> tactic
+val general_rewrite          : bool -> constr -> tactic
+val rewriteLR_bindings       : constr with_bindings -> tactic
+val rewriteRL_bindings       : constr with_bindings -> tactic
+
+val rewriteLR   : constr -> tactic
+val rewriteRL   : constr  -> tactic
+
+val conditional_rewrite : bool -> tactic -> constr with_bindings -> tactic
+val general_rewrite_in : bool -> identifier -> constr with_bindings -> tactic
+val conditional_rewrite_in :
+  bool -> identifier -> tactic -> constr with_bindings -> tactic
+
+val replace    : constr -> constr -> tactic
+val replace_in : identifier -> constr -> constr -> tactic
+
+val discr        : identifier -> tactic
+val discrConcl   : tactic
+val discrClause  : clause -> tactic
+val discrHyp     : identifier -> tactic
+val discrEverywhere     : tactic
+val discr_tac    : quantified_hypothesis option -> tactic
+val inj          : identifier -> tactic
+val injClause    : quantified_hypothesis option -> tactic
+
+val dEq : quantified_hypothesis option -> tactic
+val dEqThen : (int -> tactic) -> quantified_hypothesis option -> tactic
+
+val make_iterated_tuple : 
+  env -> evar_map -> (constr * constr) -> (constr * constr) 
+    -> constr * constr * constr
+
+val substHypInConcl : bool -> identifier -> tactic
+val substConcl : bool -> constr -> tactic
+val substHyp : bool -> constr -> identifier -> tactic
+
+val hypSubst_LR : identifier -> clause -> tactic
+val hypSubst_RL : identifier -> clause -> tactic
+
+val discriminable : env -> evar_map -> constr -> constr -> bool
+
+(* Subst *)
+
+val unfold_body : identifier -> tactic
+
+val subst : identifier list -> tactic
+val subst_all : tactic
+
+(* Replace term *)
+val replace_term_left : constr -> tactic
+val replace_term_right : constr -> tactic
+val replace_term : constr -> tactic
+val replace_term_in_left : constr -> identifier -> tactic
+val replace_term_in_right : constr -> identifier -> tactic
+val replace_term_in : constr -> identifier -> tactic
diff --git a/tactics/extraargs.ml4 b/tactics/extraargs.ml4
new file mode 100644
index 00000000..34348834
--- /dev/null
+++ b/tactics/extraargs.ml4
@@ -0,0 +1,31 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: extraargs.ml4,v 1.5.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Pcoq
+open Genarg
+
+(* Rewriting orientation *)
+
+let _ = Metasyntax.add_token_obj "<-"
+let _ = Metasyntax.add_token_obj "->"
+
+let pr_orient _prc _prt = function
+  | true -> Pp.mt ()
+  | false -> Pp.str " <-"
+
+ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient
+| [ "->" ] -> [ true ]
+| [ "<-" ] -> [ false ]
+| [ ] -> [ true ]
+END
+
diff --git a/tactics/extraargs.mli b/tactics/extraargs.mli
new file mode 100644
index 00000000..60a1ddc5
--- /dev/null
+++ b/tactics/extraargs.mli
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: extraargs.mli,v 1.3.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Tacexpr
+open Term
+open Proof_type
+open Topconstr
+
+val rawwit_orient : bool raw_abstract_argument_type
+val wit_orient : bool closed_abstract_argument_type
+val orient : bool Pcoq.Gram.Entry.e
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
new file mode 100644
index 00000000..1dbf84ab
--- /dev/null
+++ b/tactics/extratactics.ml4
@@ -0,0 +1,329 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(* $Id: extratactics.ml4,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Pcoq
+open Genarg
+open Extraargs
+
+(* Equality *)
+open Equality
+
+TACTIC EXTEND Rewrite
+  [ "Rewrite" orient(b) constr_with_bindings(c) ] -> [general_rewrite_bindings b c]
+END
+
+TACTIC EXTEND RewriteIn
+ [ "Rewrite" orient(b) constr_with_bindings(c) "in" hyp(h) ] ->
+ [general_rewrite_in b h c]
+END
+
+let h_rewriteLR x = h_rewrite true (x,Rawterm.NoBindings)
+
+TACTIC EXTEND Replace
+  [ "Replace" constr(c1) "with" constr(c2) ] -> [ replace c1 c2 ]
+END
+
+TACTIC EXTEND ReplaceIn
+  [ "Replace" constr(c1) "with" constr(c2) "in" hyp(h) ] ->
+    [ replace_in h c1 c2 ]
+END
+
+TACTIC EXTEND Replacetermleft
+  [ "Replace" "->" constr(c)  ] -> [ replace_term_left c ]
+END
+
+TACTIC EXTEND Replacetermright
+  [ "Replace" "<-" constr(c)  ] -> [ replace_term_right c ]
+END
+
+TACTIC EXTEND Replaceterm
+  [ "Replace" constr(c)  ] -> [ replace_term c ]
+END
+
+TACTIC EXTEND ReplacetermInleft
+  [ "Replace"  "->" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in_left c h ]
+END
+
+TACTIC EXTEND ReplacetermInright
+  [ "Replace"  "<-" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in_right c h ]
+END
+
+TACTIC EXTEND ReplacetermIn
+  [ "Replace" constr(c) "in" hyp(h) ]
+  -> [ replace_term_in c h ]
+END
+
+TACTIC EXTEND DEq
+  [ "Simplify_eq" quantified_hypothesis_opt(h) ] -> [ dEq h ]
+END
+
+TACTIC EXTEND Discriminate
+  [ "Discriminate" quantified_hypothesis_opt(h) ] -> [ discr_tac h ]
+END
+
+let h_discrHyp id = h_discriminate (Some id)
+
+TACTIC EXTEND Injection
+  [ "Injection" quantified_hypothesis_opt(h) ] -> [ injClause h ]
+END
+
+let h_injHyp id = h_injection (Some id)
+
+TACTIC EXTEND ConditionalRewrite
+  [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c) ]
+    -> [ conditional_rewrite b (snd tac) c ]
+END
+
+TACTIC EXTEND ConditionalRewriteIn
+  [ "Conditional" tactic(tac) "Rewrite" orient(b) constr_with_bindings(c)
+    "in" hyp(h) ]
+    -> [ conditional_rewrite_in b h (snd tac) c ]
+END
+
+TACTIC EXTEND DependentRewrite
+| [ "Dependent" "Rewrite" orient(b) hyp(id) ] -> [ substHypInConcl b id ]
+| [ "CutRewrite" orient(b) constr(eqn) ] -> [ substConcl b eqn ]
+| [ "CutRewrite" orient(b) constr(eqn) "in" hyp(id) ]
+      -> [ substHyp b eqn id ]
+END
+
+(* Contradiction *)
+open Contradiction
+
+TACTIC EXTEND Absurd
+ [ "Absurd" constr(c) ] -> [ absurd c ]
+END
+
+TACTIC EXTEND Contradiction
+ [ "Contradiction" constr_with_bindings_opt(c) ] -> [ contradiction c ]
+END
+
+(* AutoRewrite *)
+
+open Autorewrite
+TACTIC EXTEND AutorewriteV7
+  [ "AutoRewrite" "[" ne_preident_list(l) "]" ] ->
+    [ autorewrite Refiner.tclIDTAC l ]
+| [ "AutoRewrite" "[" ne_preident_list(l) "]" "using" tactic(t) ] ->
+    [ autorewrite (snd t) l ]
+END
+TACTIC EXTEND AutorewriteV8
+  [ "AutoRewrite" "with" ne_preident_list(l) ] ->
+    [ autorewrite Refiner.tclIDTAC l ]
+| [ "AutoRewrite" "with" ne_preident_list(l) "using" tactic(t) ] ->
+    [ autorewrite (snd t) l ]
+END
+
+let add_rewrite_hint name ort t lcsr =
+  let env = Global.env() and sigma = Evd.empty in
+  let f c = Constrintern.interp_constr sigma env c, ort, t in
+  add_rew_rules name (List.map f lcsr)
+
+(* V7 *)
+VERNAC COMMAND EXTEND HintRewriteV7
+  [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b) ] ->
+  [ add_rewrite_hint b o (Tacexpr.TacId "") l ]
+| [ "Hint" "Rewrite" orient(o) "[" ne_constr_list(l) "]" "in" preident(b)
+    "using" tactic(t) ] ->
+  [ add_rewrite_hint b o t l ]
+END
+
+(* V8 *)
+VERNAC COMMAND EXTEND HintRewriteV8
+  [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident(b) ] ->
+  [ add_rewrite_hint b o (Tacexpr.TacId "") l ]
+| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t)
+    ":" preident(b) ] ->
+  [ add_rewrite_hint b o t l ]
+END
+
+
+(* Refine *)
+
+open Refine
+
+TACTIC EXTEND Refine
+  [ "Refine" castedopenconstr(c) ] -> [ refine c ]
+END
+
+let refine_tac = h_refine
+
+(* Setoid_replace *)
+
+open Setoid_replace
+
+TACTIC EXTEND SetoidReplace
+  [ "Setoid_replace" constr(c1) "with" constr(c2) ]
+  -> [ setoid_replace c1 c2 None]
+END
+
+TACTIC EXTEND SetoidRewrite
+  [ "Setoid_rewrite" orient(b) constr(c) ] -> [ general_s_rewrite b c ]
+END
+
+VERNAC COMMAND EXTEND AddSetoid
+| [ "Add" "Setoid" constr(a) constr(aeq) constr(t) ] -> [ add_setoid a aeq t ]
+| [ "Add" "Morphism" constr(m) ":" ident(s) ] -> [ new_named_morphism s m ]
+END
+
+(* Inversion lemmas (Leminv) *)
+
+open Inv
+open Leminv
+
+VERNAC COMMAND EXTEND DeriveInversionClear
+  [ "Derive" "Inversion_clear" ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" natural(n) ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal n na id Term.mk_Prop false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s false inv_clear_tac ]
+
+| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ]
+  -> [ add_inversion_lemma_exn na c (Rawterm.RProp Term.Null) false inv_clear_tac ]
+END
+
+open Term
+open Rawterm
+
+VERNAC COMMAND EXTEND DeriveInversion
+| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s false half_inv_tac ]
+
+| [ "Derive" "Inversion" ident(na) "with" constr(c) ]
+  -> [ add_inversion_lemma_exn na c (RProp Null) false half_inv_tac ]
+
+| [ "Derive" "Inversion" ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal 1 na id Term.mk_Prop false half_inv_tac ]
+
+| [ "Derive" "Inversion" natural(n) ident(na) hyp(id) ]
+  -> [ inversion_lemma_from_goal n na id Term.mk_Prop false half_inv_tac ]
+END
+
+VERNAC COMMAND EXTEND DeriveDependentInversion
+| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s true half_dinv_tac ]
+    END
+
+VERNAC COMMAND EXTEND DeriveDependentInversionClear
+| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ]
+  -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ]
+END
+
+(* Subst *)
+
+TACTIC EXTEND Subst
+| [ "Subst" ne_var_list(l) ] -> [ subst l ]
+| [ "Subst" ] -> [ subst_all ]
+END
+
+(** Nijmegen "step" tactic for setoid rewriting *)
+
+open Tacticals
+open Tactics
+open Tactics
+open Libnames
+open Rawterm
+open Summary
+open Libobject
+open Lib
+
+(* Registered lemmas are expected to be of the form
+     x R y -> y == z -> x R z    (in the right table)
+     x R y -> x == z -> z R y    (in the left table)
+*)
+
+let transitivity_right_table = ref []
+let transitivity_left_table = ref []
+
+(* [step] tries to apply a rewriting lemma; then apply [tac] intended to
+   complete to proof of the last hypothesis (assumed to state an equality) *)
+
+let step left x tac =
+  let l =
+    List.map (fun lem ->
+      tclTHENLAST
+      (apply_with_bindings (constr_of_reference lem, ImplicitBindings [x]))
+        tac)
+      !(if left then transitivity_left_table else transitivity_right_table)
+  in
+  tclFIRST l
+
+(* Main function to push lemmas in persistent environment *)
+
+let cache_transitivity_lemma (_,(left,lem)) =
+  if left then  
+    transitivity_left_table  := lem :: !transitivity_left_table
+  else
+    transitivity_right_table := lem :: !transitivity_right_table
+  
+let subst_transitivity_lemma (_,subst,(b,ref)) = (b,subst_global subst ref)
+
+let (inTransitivity,_) =
+  declare_object {(default_object "TRANSITIVITY-STEPS") with
+    cache_function = cache_transitivity_lemma;
+    open_function = (fun i o -> if i=1 then cache_transitivity_lemma o);
+    subst_function = subst_transitivity_lemma;
+    classify_function = (fun (_,o) -> Substitute o);       
+    export_function = (fun x -> Some x) }
+
+(* Synchronisation with reset *)
+
+let freeze () = !transitivity_left_table, !transitivity_right_table
+
+let unfreeze (l,r) = 
+  transitivity_left_table := l;
+  transitivity_right_table := r
+
+let init () = 
+  transitivity_left_table := [];
+  transitivity_right_table := []
+
+let _ = 
+  declare_summary "transitivity-steps"
+    { freeze_function = freeze;
+      unfreeze_function = unfreeze;
+      init_function = init;
+      survive_module = false; 
+      survive_section = false }
+
+(* Main entry points *)
+
+let add_transitivity_lemma left ref =
+  add_anonymous_leaf (inTransitivity (left,Nametab.global ref))
+
+(* Vernacular syntax *)
+
+TACTIC EXTEND Stepl
+| ["Stepl" constr(c) "by" tactic(tac) ] -> [ step true c (snd tac) ]
+| ["Stepl" constr(c) ] -> [ step true c tclIDTAC ]
+END
+
+TACTIC EXTEND Stepr
+| ["Stepr" constr(c) "by" tactic(tac) ] -> [ step false c (snd tac) ]
+| ["Stepr" constr(c) ] -> [ step false c tclIDTAC ]
+END
+
+VERNAC COMMAND EXTEND AddStepl
+| [ "Declare" "Left" "Step" global(id) ] ->
+    [ add_transitivity_lemma true id ]
+END
+
+VERNAC COMMAND EXTEND AddStepr
+| [ "Declare" "Right" "Step" global(id) ] ->
+    [ add_transitivity_lemma false id ]
+END
diff --git a/tactics/extratactics.mli b/tactics/extratactics.mli
new file mode 100644
index 00000000..a714c8dd
--- /dev/null
+++ b/tactics/extratactics.mli
@@ -0,0 +1,20 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: extratactics.mli,v 1.3.10.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Names
+open Term
+open Proof_type
+open Rawterm
+
+val h_discrHyp : quantified_hypothesis -> tactic
+val h_injHyp : quantified_hypothesis -> tactic
+val h_rewriteLR : constr -> tactic
+
+val refine_tac : Genarg.open_constr -> tactic
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
new file mode 100644
index 00000000..f35c624b
--- /dev/null
+++ b/tactics/hiddentac.ml
@@ -0,0 +1,103 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: hiddentac.ml,v 1.21.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Term
+open Proof_type
+open Tacmach
+
+open Rawterm
+open Refiner
+open Genarg
+open Tacexpr
+open Tactics
+open Util
+
+let inj_id id = (dummy_loc,id)
+
+(* Basic tactics *)
+let h_intro_move x y =
+  abstract_tactic (TacIntroMove (x, option_app inj_id y)) (intro_move x y)
+let h_intro x        = h_intro_move (Some x) None
+let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
+let h_assumption     = abstract_tactic TacAssumption assumption
+let h_exact c        = abstract_tactic (TacExact c) (exact_check c)
+let h_apply cb       = abstract_tactic (TacApply cb) (apply_with_bindings cb)
+let h_elim cb cbo    = abstract_tactic (TacElim (cb,cbo)) (elim cb cbo)
+let h_elim_type c    = abstract_tactic (TacElimType c) (elim_type c)
+let h_case cb        = abstract_tactic (TacCase cb) (general_case_analysis cb)
+let h_case_type c    = abstract_tactic (TacCaseType c) (case_type c)
+let h_fix ido n      = abstract_tactic (TacFix (ido,n)) (fix ido n)
+let h_mutual_fix id n l =
+  abstract_tactic (TacMutualFix (id,n,l)) (mutual_fix id n l)
+let h_cofix ido      = abstract_tactic (TacCofix ido) (cofix ido)
+let h_mutual_cofix id l =
+  abstract_tactic (TacMutualCofix (id,l)) (mutual_cofix id l)
+
+let h_cut c          = abstract_tactic (TacCut c) (cut c)
+let h_true_cut na c = abstract_tactic (TacTrueCut (na,c)) (true_cut na c)
+let h_forward b na c = abstract_tactic (TacForward (b,na,c)) (forward b na c)
+let h_generalize cl  = abstract_tactic (TacGeneralize cl) (generalize cl)
+let h_generalize_dep c = abstract_tactic (TacGeneralizeDep c)(generalize_dep c)
+let h_let_tac na c cl =
+  abstract_tactic (TacLetTac (na,c,cl)) (letin_tac true na c cl)
+let h_instantiate n c cls = 
+  abstract_tactic (TacInstantiate (n,c,cls))
+    (Evar_refiner.instantiate n c (simple_clause_of cls))
+
+(* Derived basic tactics *)
+let h_simple_induction h =
+  abstract_tactic (TacSimpleInduction h) (simple_induct h)
+let h_simple_destruct h  =
+  abstract_tactic (TacSimpleDestruct h) (simple_destruct h)
+let h_new_induction c e idl =
+  abstract_tactic (TacNewInduction (c,e,idl)) (new_induct c e idl)
+let h_new_destruct c e idl =
+  abstract_tactic (TacNewDestruct (c,e,idl)) (new_destruct c e idl)
+let h_specialize n d = abstract_tactic (TacSpecialize (n,d)) (new_hyp n d)
+let h_lapply c = abstract_tactic (TacLApply c) (cut_and_apply c)
+
+(* Context management *)
+let h_clear l = abstract_tactic (TacClear l) (clear l)
+let h_clear_body l = abstract_tactic (TacClearBody l) (clear_body l)
+let h_move dep id1 id2 =
+  abstract_tactic (TacMove (dep,id1,id2)) (move_hyp dep id1 id2)
+let h_rename id1 id2 =
+  abstract_tactic (TacRename (id1,id2)) (rename_hyp id1 id2)
+
+(* Constructors *)
+let h_left l          = abstract_tactic (TacLeft l) (left l)
+let h_right l         = abstract_tactic (TacLeft l) (right l)
+let h_split l         = abstract_tactic (TacSplit (false,l)) (split l)
+(* Moved to tacinterp because of dependence in Tacinterp.interp
+let h_any_constructor t =
+  abstract_tactic (TacAnyConstructor t) (any_constructor t)
+*)
+let h_constructor n l =
+  abstract_tactic (TacConstructor(AI n,l))(constructor_tac None n l)
+let h_one_constructor n = h_constructor n NoBindings
+let h_simplest_left   = h_left NoBindings
+let h_simplest_right  = h_right NoBindings
+
+(* Conversion *)
+let h_reduce r cl  = abstract_tactic (TacReduce (r,cl)) (reduce r cl)
+let h_change oc c cl  = abstract_tactic (TacChange (oc,c,cl)) (change oc c cl)
+
+(* Equivalence relations *)
+let h_reflexivity    = abstract_tactic TacReflexivity intros_reflexivity
+let h_symmetry c     = abstract_tactic (TacSymmetry c) (intros_symmetry c)
+let h_transitivity c =
+  abstract_tactic (TacTransitivity c) (intros_transitivity c)
+
+let h_simplest_apply c  = h_apply (c,NoBindings)
+let h_simplest_elim c   = h_elim (c,NoBindings) None
+let h_simplest_case   c = h_case (c,NoBindings)
+
+let h_intro_patterns l = abstract_tactic (TacIntroPattern l) (intro_patterns l)
+
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
new file mode 100644
index 00000000..816678ae
--- /dev/null
+++ b/tactics/hiddentac.mli
@@ -0,0 +1,108 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: hiddentac.mli,v 1.19.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Proof_type
+open Tacmach
+open Genarg
+open Tacexpr
+open Rawterm
+(*i*)
+
+(* Tactics for the interpreter. They left a trace in the proof tree
+   when they are called. *)
+
+(* Basic tactics *)
+
+val h_intro_move      : identifier option -> identifier option -> tactic
+val h_intro           : identifier -> tactic
+val h_intros_until    : quantified_hypothesis -> tactic
+
+val h_assumption      : tactic
+val h_exact           : constr -> tactic
+
+val h_apply           : constr with_bindings -> tactic
+
+val h_elim            : constr with_bindings ->
+                        constr with_bindings option -> tactic
+val h_elim_type       : constr -> tactic
+val h_case            : constr with_bindings -> tactic
+val h_case_type       : constr -> tactic
+
+val h_mutual_fix      : identifier -> int ->
+                        (identifier * int * constr) list -> tactic
+val h_fix             : identifier option -> int -> tactic
+val h_mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val h_cofix           : identifier option -> tactic
+
+val h_cut             : constr -> tactic 
+val h_true_cut        : name -> constr -> tactic 
+val h_generalize      : constr list -> tactic 
+val h_generalize_dep  : constr -> tactic 
+val h_forward         : bool -> name -> constr -> tactic 
+val h_let_tac         : name -> constr -> Tacticals.clause -> tactic
+val h_instantiate     : int -> constr -> Tacticals.clause -> tactic
+
+(* Derived basic tactics *)
+
+val h_simple_induction   : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic
+val h_simple_destruct    : quantified_hypothesis -> tactic
+val h_new_induction   :
+  constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+val h_new_destruct    :
+  constr induction_arg -> constr with_bindings option -> 
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+val h_specialize      : int option -> constr with_bindings -> tactic
+val h_lapply          : constr -> tactic
+
+(* Automation tactic : see Auto *)
+
+
+(* Context management *)
+val h_clear           : identifier list -> tactic
+val h_clear_body      : identifier list -> tactic
+val h_move            : bool -> identifier -> identifier -> tactic
+val h_rename          : identifier -> identifier -> tactic
+
+
+(* Constructors *)
+(*
+val h_any_constructor : tactic -> tactic
+*)
+val h_constructor     : int -> constr bindings -> tactic
+val h_left            : constr bindings -> tactic
+val h_right           : constr bindings -> tactic
+val h_split           : constr bindings -> tactic
+
+val h_one_constructor : int -> tactic
+val h_simplest_left   : tactic
+val h_simplest_right  : tactic
+
+
+(* Conversion *)
+val h_reduce          : Tacred.red_expr -> Tacticals.clause -> tactic
+val h_change          :
+  constr occurrences option -> constr -> Tacticals.clause -> tactic
+
+(* Equivalence relations *)
+val h_reflexivity     : tactic
+val h_symmetry        : Tacticals.clause -> tactic
+val h_transitivity    : constr -> tactic
+
+val h_simplest_apply  : constr -> tactic 
+val h_simplest_elim   : constr -> tactic
+val h_simplest_case   : constr -> tactic
+
+val h_intro_patterns  : intro_pattern_expr list -> tactic
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
new file mode 100644
index 00000000..0ada5a06
--- /dev/null
+++ b/tactics/hipattern.ml
@@ -0,0 +1,366 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: hipattern.ml,v 1.29.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Reductionops
+open Inductiveops
+open Evd
+open Environ
+open Proof_trees
+open Clenv
+open Pattern
+open Matching
+open Coqlib
+open Declarations
+
+(* I implemented the following functions which test whether a term t
+   is an inductive but non-recursive type, a general conjuction, a
+   general disjunction, or a type with no constructors.
+
+   They are more general than matching with or_term, and_term, etc, 
+   since they do not depend on the name of the type. Hence, they 
+   also work on ad-hoc disjunctions introduced by the user.
+  
+  -- Eduardo (6/8/97). *)
+
+type 'a matching_function = constr -> 'a option
+
+type testing_function  = constr -> bool
+
+let mkmeta n = Nameops.make_ident "X" (Some n)
+let mkPMeta n = PMeta (Some (mkmeta n))
+let meta1 = mkmeta 1
+let meta2 = mkmeta 2
+let meta3 = mkmeta 3
+let meta4 = mkmeta 4
+
+let op2bool = function Some _ -> true | None -> false
+
+let match_with_non_recursive_type t = 
+  match kind_of_term t with 
+    | App _ -> 
+        let (hdapp,args) = decompose_app t in
+        (match kind_of_term hdapp with
+           | Ind ind -> 
+               if not (Global.lookup_mind (fst ind)).mind_finite then 
+		 Some (hdapp,args) 
+	       else 
+		 None 
+           | _ -> None)
+    | _ -> None
+
+let is_non_recursive_type t = op2bool (match_with_non_recursive_type t)
+
+(* A general conjunction type is a non-recursive inductive type with
+   only one constructor. *)
+
+let match_with_conjunction t =
+  let (hdapp,args) = decompose_app t in 
+  match kind_of_term hdapp with
+    | Ind ind -> 
+	let (mib,mip) = Global.lookup_inductive ind in
+	if (Array.length mip.mind_consnames = 1)
+	  && (not (mis_is_recursive (ind,mib,mip)))
+          && (mip.mind_nrealargs = 0)
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_conjunction t = op2bool (match_with_conjunction t)
+    
+(* A general disjunction type is a non-recursive inductive type all
+   whose constructors have a single argument. *)
+
+let match_with_disjunction t =
+  let (hdapp,args) = decompose_app t in 
+  match kind_of_term hdapp with
+    | Ind ind  ->
+        let car = mis_constr_nargs ind in
+	if array_for_all (fun ar -> ar = 1) car &&
+	   (let (mib,mip) = Global.lookup_inductive ind in
+            not (mis_is_recursive (ind,mib,mip)))
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_disjunction t = op2bool (match_with_disjunction t)
+
+let match_with_empty_type t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let nconstr = Array.length mip.mind_consnames in  
+	if nconstr = 0 then Some hdapp else None
+    | _ ->  None
+	  
+let is_empty_type t = op2bool (match_with_empty_type t)
+
+let match_with_unit_type t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind  -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let constr_types = mip.mind_nf_lc in 
+        let nconstr = Array.length mip.mind_consnames in
+        let zero_args c =
+          nb_prod c = mip.mind_nparams in  
+	if nconstr = 1 && array_for_all zero_args constr_types then 
+	  Some hdapp
+        else 
+	  None
+    | _ -> None
+
+let is_unit_type t = op2bool (match_with_unit_type t)
+
+(* Checks if a given term is an application of an
+   inductive binary relation R, so that R has only one constructor
+   establishing its reflexivity.  *)
+
+(* ["(A : ?)(x:A)(? A x x)"] and ["(x : ?)(? x x)"] *)
+let x = Name (id_of_string "x")
+let y = Name (id_of_string "y")
+let name_A = Name (id_of_string "A")
+let coq_refl_rel1_pattern =
+  PProd
+    (name_A, PMeta None,
+    PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 1|])))
+let coq_refl_rel2_pattern =
+  PProd (x, PMeta None, PApp (PMeta None, [|PRel 1; PRel 1|]))
+
+let coq_refl_reljm_pattern =
+PProd
+    (name_A, PMeta None,
+    PProd (x, PRel 1, PApp (PMeta None, [|PRel 2; PRel 1; PRel 2;PRel 1|])))
+
+let match_with_equation t =
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+        let constr_types = mip.mind_nf_lc in 
+        let nconstr = Array.length mip.mind_consnames in
+	if nconstr = 1 &&
+           (is_matching coq_refl_rel1_pattern constr_types.(0) ||
+            is_matching coq_refl_rel2_pattern constr_types.(0) ||
+            is_matching coq_refl_reljm_pattern constr_types.(0)) 
+        then 
+	  Some (hdapp,args)
+        else 
+	  None
+    | _ -> None
+
+let is_equation t = op2bool (match_with_equation  t)
+
+(* ["(?1 -> ?2)"] *)
+let imp a b = PProd (Anonymous, a, b)
+let coq_arrow_pattern = imp (mkPMeta 1) (mkPMeta 2)
+let match_arrow_pattern t =
+  match matches coq_arrow_pattern t with
+    | [(m1,arg);(m2,mind)] -> assert (m1=meta1 & m2=meta2); (arg, mind)
+    | _ -> anomaly "Incorrect pattern matching" 
+
+let match_with_nottype t =
+  try
+    let (arg,mind) = match_arrow_pattern t in
+    if is_empty_type mind then Some (mind,arg) else None
+  with PatternMatchingFailure -> None  
+
+let is_nottype t = op2bool (match_with_nottype t)
+		     
+let match_with_forall_term c=
+  match kind_of_term c with
+    | Prod (nam,a,b) -> Some (nam,a,b)
+    | _            -> None
+
+let is_forall_term c = op2bool (match_with_forall_term c) 
+
+let match_with_imp_term c=
+  match kind_of_term c with
+    | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b)
+    | _              -> None
+
+let is_imp_term c = op2bool (match_with_imp_term c) 
+
+let rec has_nodep_prod_after n c =
+  match kind_of_term c with
+    | Prod (_,_,b) -> 
+	( n>0 || not (dependent (mkRel 1) b)) 
+	&& (has_nodep_prod_after (n-1) b)
+    | _            -> true
+	  
+let has_nodep_prod = has_nodep_prod_after 0
+	
+let match_with_nodep_ind t =
+  let (hdapp,args) = decompose_app t in
+    match (kind_of_term hdapp) with
+      | Ind ind  -> 
+          let (mib,mip) = Global.lookup_inductive ind in
+	    if Array.length (mib.mind_packets)>1 then None else
+	      let nodep_constr = has_nodep_prod_after mip.mind_nparams in
+		if array_for_all nodep_constr mip.mind_nf_lc then
+		  let params=
+		    if mip.mind_nrealargs=0 then args else
+		      fst (list_chop mip.mind_nparams args) in
+		    Some (hdapp,params,mip.mind_nrealargs)
+		else 
+		  None
+      | _ -> None
+	  
+let is_nodep_ind t=op2bool (match_with_nodep_ind t)
+
+let match_with_sigma_type t=
+  let (hdapp,args) = decompose_app t in
+  match (kind_of_term hdapp) with
+    | Ind ind  -> 
+        let (mib,mip) = Global.lookup_inductive ind in
+          if (Array.length (mib.mind_packets)=1) &&
+	    (mip.mind_nrealargs=0) &&
+	    (Array.length mip.mind_consnames=1) &&
+	    has_nodep_prod_after (mip.mind_nparams+1) mip.mind_nf_lc.(0) then
+	      (*allowing only 1 existential*) 
+	      Some (hdapp,args)
+	  else 
+	    None
+    | _ -> None
+
+let is_sigma_type t=op2bool (match_with_sigma_type t)
+
+(***** Destructing patterns bound to some theory *)
+
+let rec first_match matcher = function
+  | [] -> raise PatternMatchingFailure
+  | (pat,build_set)::l ->
+      try (build_set (),matcher pat)
+      with PatternMatchingFailure -> first_match matcher l
+
+(*** Equality *)
+
+(* Patterns "(eq ?1 ?2 ?3)", "(eqT ?1 ?2 ?3)" and "(idT ?1 ?2 ?3)" *)
+let coq_eq_pattern_gen eq = 
+  lazy (PApp(PRef (Lazy.force eq), [|mkPMeta 1;mkPMeta 2;mkPMeta 3|]))
+let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref
+(*let coq_eqT_pattern = coq_eq_pattern_gen coq_eqT_ref*)
+let coq_idT_pattern = coq_eq_pattern_gen coq_idT_ref
+
+let match_eq eqn eq_pat =
+  match matches (Lazy.force eq_pat) eqn with
+    | [(m1,t);(m2,x);(m3,y)] ->
+	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+	(t,x,y)
+    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+
+let equalities =
+  [coq_eq_pattern, build_coq_eq_data;
+(*   coq_eqT_pattern, build_coq_eqT_data;*)
+   coq_idT_pattern, build_coq_idT_data]
+
+let find_eq_data_decompose eqn = (* fails with PatternMatchingFailure *)
+  first_match (match_eq eqn) equalities
+
+open Tacmach
+open Tacticals
+
+let match_eq_nf gls eqn eq_pat =
+  match pf_matches gls (Lazy.force eq_pat) eqn with
+    | [(m1,t);(m2,x);(m3,y)] ->
+	assert (m1 = meta1 & m2 = meta2 & m3 = meta3);
+	(t,pf_whd_betadeltaiota gls x,pf_whd_betadeltaiota gls y)
+    | _ -> anomaly "match_eq: an eq pattern should match 3 terms"
+
+let dest_nf_eq gls eqn =
+  try
+    snd (first_match (match_eq_nf gls eqn) equalities)
+  with PatternMatchingFailure ->
+    error "Not an equality"
+
+(*** Sigma-types *)
+
+(* Patterns "(existS ?1 ?2 ?3 ?4)" and "(existT ?1 ?2 ?3 ?4)" *)
+let coq_ex_pattern_gen ex =
+  lazy(PApp(PRef (Lazy.force ex), [|mkPMeta 1;mkPMeta 2;mkPMeta 3;mkPMeta 4|]))
+let coq_existS_pattern = coq_ex_pattern_gen coq_existS_ref
+let coq_existT_pattern = coq_ex_pattern_gen coq_existT_ref
+
+let match_sigma ex ex_pat =
+  match matches (Lazy.force ex_pat) ex with
+    | [(m1,a);(m2,p);(m3,car);(m4,cdr)] as l ->
+	assert (m1=meta1 & m2=meta2 & m3=meta3 & m4=meta4);
+	(a,p,car,cdr)
+    | _ ->
+	anomaly "match_sigma: a successful sigma pattern should match 4 terms"
+
+let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *)
+  first_match (match_sigma ex) 
+    [coq_existS_pattern, build_sigma_set; 
+     coq_existT_pattern, build_sigma_type]
+
+(* Pattern "(sig ?1 ?2)" *)
+let coq_sig_pattern = 
+  lazy (PApp (PRef (Lazy.force coq_sig_ref), [| (mkPMeta 1); (mkPMeta 2) |]))
+
+let match_sigma t =
+  match matches (Lazy.force coq_sig_pattern) t with
+    | [(_,a); (_,p)] -> (a,p)
+    | _ -> anomaly "Unexpected pattern"
+
+let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t
+
+(*** Decidable equalities *)
+
+(* Pattern "(sumbool (eq ?1 ?2 ?3) ?4)" *)
+let coq_eqdec_partial_pattern =
+  lazy
+    (PApp
+       (PRef (Lazy.force coq_sumbool_ref),
+	[| Lazy.force coq_eq_pattern; (mkPMeta 4) |]))
+
+let match_eqdec_partial t =
+  match matches (Lazy.force coq_eqdec_partial_pattern) t with
+    | [_; (_,lhs); (_,rhs); _] -> (lhs,rhs)
+    | _ -> anomaly "Unexpected pattern"
+
+(* The expected form of the goal for the tactic Decide Equality *)
+
+(* Pattern "(x,y:?1){<?1>x=y}+{~(<?1>x=y)}" *)
+(* i.e. "(x,y:?1)(sumbool (eq ?1 x y) ~(eq ?1 x y))" *)
+let x = Name (id_of_string "x")
+let y = Name (id_of_string "y")
+let coq_eqdec_pattern =
+  lazy
+    (PProd (x, (mkPMeta 1), PProd (y, (mkPMeta 1), 
+    PApp (PRef (Lazy.force coq_sumbool_ref),
+	  [| PApp (PRef (Lazy.force coq_eq_ref),
+		   [| (mkPMeta 1); PRel 2; PRel 1 |]);
+	     PApp (PRef (Lazy.force coq_not_ref), 
+		   [|PApp (PRef (Lazy.force coq_eq_ref),
+ 			   [| (mkPMeta 1); PRel 2; PRel 1 |])|]) |]))))
+
+let match_eqdec t =
+  match matches (Lazy.force coq_eqdec_pattern) t with
+    | [(_,typ)] -> typ
+    | _ -> anomaly "Unexpected pattern"
+
+(* Patterns "~ ?" and "? -> False" *)
+let coq_not_pattern = lazy(PApp(PRef (Lazy.force coq_not_ref), [|PMeta None|]))
+let coq_imp_False_pattern =
+  lazy (imp (PMeta None) (PRef (Lazy.force coq_False_ref)))
+
+let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t
+let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
new file mode 100644
index 00000000..7e2aa8f2
--- /dev/null
+++ b/tactics/hipattern.mli
@@ -0,0 +1,129 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: hipattern.mli,v 1.13.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Evd
+open Pattern
+open Proof_trees
+(*i*)
+
+(*s Given a term with second-order variables in it,
+   represented by Meta's, and possibly applied using SoApp
+   terms, this function will perform second-order, binding-preserving,
+   matching, in the case where the pattern is a pattern in the sense
+   of Dale Miller.
+
+   ALGORITHM:
+
+   Given a pattern, we decompose it, flattening casts and apply's,
+   recursing on all operators, and pushing the name of the binder each
+   time we descend a binder.
+
+   When we reach a first-order variable, we ask that the corresponding
+   term's free-rels all be higher than the depth of the current stack.
+
+   When we reach a second-order application, we ask that the
+   intersection of the free-rels of the term and the current stack be
+   contained in the arguments of the application *)
+
+val is_imp_term : constr -> bool
+
+(*s I implemented the following functions which test whether a term [t]
+   is an inductive but non-recursive type, a general conjuction, a
+   general disjunction, or a type with no constructors.
+
+   They are more general than matching with [or_term], [and_term], etc, 
+   since they do not depend on the name of the type. Hence, they 
+   also work on ad-hoc disjunctions introduced by the user.
+   (Eduardo, 6/8/97). *)
+
+type 'a matching_function = constr -> 'a option
+type testing_function = constr -> bool
+
+val match_with_non_recursive_type : (constr * constr list) matching_function
+val is_non_recursive_type         : testing_function 
+
+val match_with_disjunction : (constr * constr list) matching_function
+val is_disjunction         : testing_function 
+
+val match_with_conjunction : (constr * constr list) matching_function
+val is_conjunction         : testing_function 
+
+val match_with_empty_type  : constr matching_function
+val is_empty_type          : testing_function 
+
+val match_with_unit_type   : constr matching_function
+
+(* type with only one constructor and no arguments *)
+val is_unit_type           : testing_function 
+
+val match_with_equation    : (constr * constr list) matching_function
+val is_equation            : testing_function 
+
+val match_with_nottype     : (constr * constr) matching_function
+val is_nottype             : testing_function 
+
+val match_with_forall_term    : (name * constr * constr) matching_function
+val is_forall_term            : testing_function 
+
+val match_with_imp_term    : (constr * constr) matching_function
+val is_imp_term            : testing_function 
+
+(* I added these functions to test whether a type contains dependent
+  products or not, and if an inductive has constructors with dependent types
+ (excluding parameters). this is useful to check whether a conjunction is a
+ real conjunction and not a dependent tuple. (Pierre Corbineau, 13/5/2002) *)
+
+val has_nodep_prod_after   : int -> testing_function
+val has_nodep_prod         : testing_function
+
+val match_with_nodep_ind   : (constr * constr list * int) matching_function  
+val is_nodep_ind           : testing_function 
+
+val match_with_sigma_type   : (constr * constr list) matching_function	  
+val is_sigma_type           : testing_function 
+
+(***** Destructing patterns bound to some theory *)
+
+open Coqlib
+
+(* Match terms [(eq A t u)], [(eqT A t u)] or [(identityT A t u)] *)
+(* Returns associated lemmas and [A,t,u] *)
+val find_eq_data_decompose : constr -> 
+  coq_leibniz_eq_data * (constr * constr * constr)
+
+(* Match a term of the form [(existS A P t p)] or [(existT A P t p)] *)
+(* Returns associated lemmas and [A,P,t,p] *)
+val find_sigma_data_decompose : constr -> 
+  coq_sigma_data * (constr * constr * constr * constr)
+
+(* Match a term of the form [{x:A|P}], returns [A] and [P] *)
+val match_sigma : constr -> constr * constr
+
+val is_matching_sigma : constr -> bool
+
+(* Match a term of the form [{x=y}+{_}], returns [x] and [y] *)
+val match_eqdec_partial : constr -> constr * constr
+
+(* Match a term of the form [(x,y:t){x=y}+{~x=y}], returns [t] *)
+val match_eqdec : constr -> constr
+
+(* Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
+open Proof_type
+open Tacmach
+val dest_nf_eq : goal sigma -> constr -> (constr * constr * constr)
+
+(* Match a negation *)
+val is_matching_not : constr -> bool
+val is_matching_imp_False : constr -> bool
diff --git a/tactics/inv.ml b/tactics/inv.ml
new file mode 100644
index 00000000..54ce467c
--- /dev/null
+++ b/tactics/inv.ml
@@ -0,0 +1,564 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: inv.ml,v 1.53.2.1 2004/07/16 19:30:53 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Global
+open Sign
+open Environ
+open Inductiveops
+open Printer
+open Reductionops
+open Retyping
+open Tacmach
+open Proof_type
+open Evar_refiner
+open Clenv
+open Tactics
+open Tacticals
+open Tactics
+open Elim
+open Equality
+open Typing
+open Pattern
+open Matching
+open Rawterm
+open Genarg
+open Tacexpr
+
+let collect_meta_variables c = 
+  let rec collrec acc c = match kind_of_term c with
+    | Meta mv -> mv::acc
+    | _ -> fold_constr collrec acc c
+  in 
+  collrec [] c
+
+let check_no_metas clenv ccl =
+  if occur_meta ccl then
+    let metas = List.map (fun n -> Metamap.find n clenv.namenv)
+		  (collect_meta_variables ccl) in
+    errorlabstrm "inversion" 
+      (str ("Cannot find an instantiation for variable"^
+	       (if List.length metas = 1 then " " else "s ")) ++
+	 prlist_with_sep pr_coma pr_id metas
+	 (* ajouter "in " ++ prterm ccl mais il faut le bon contexte *))
+
+let var_occurs_in_pf gl id =
+  let env = pf_env gl in
+  occur_var env id (pf_concl gl) or
+  List.exists (occur_var_in_decl env id) (pf_hyps gl)
+
+(* [make_inv_predicate (ity,args) C]
+  
+   is given the inductive type, its arguments, both the global
+   parameters and its local arguments, and is expected to produce a
+   predicate P such that if largs is the "local" part of the
+   arguments, then (P largs) will be convertible with a conclusion of
+   the form:
+
+   <A1>a1=a1-><A2>a2=a2 ... -> C
+
+   Algorithm: suppose length(largs)=n
+
+   (1) Push the entire arity, [xbar:Abar], carrying along largs and
+   the conclusion
+
+   (2) Pair up each ai with its respective Rel version: a1==(Rel n),
+   a2==(Rel n-1), etc.
+
+   (3) For each pair, ai,Rel j, if the Ai is dependent - that is, the
+   type of [Rel j] is an open term, then we construct the iterated
+   tuple, [make_iterated_tuple] does it, and use that for our equation
+
+   Otherwise, we just use <Ai>ai=Rel j
+
+ *)
+
+type inversion_status = Dep of constr option | NoDep
+
+let compute_eqn env sigma n i ai =
+  (ai,get_type_of env sigma ai),
+  (mkRel (n-i),get_type_of env sigma (mkRel (n-i)))
+
+let make_inv_predicate env sigma indf realargs id status concl =
+  let nrealargs = List.length realargs in
+  let (hyps,concl) =
+    match status with
+      | NoDep ->
+	  (* We push the arity and leave concl unchanged *)
+	  let hyps_arity,_ = get_arity env indf in
+	  (hyps_arity,concl)
+      | Dep dflt_concl ->
+	  if not (occur_var env id concl) then
+	    errorlabstrm "make_inv_predicate"
+              (str "Current goal does not depend on " ++ pr_id id);
+          (* We abstract the conclusion of goal with respect to
+             realargs and c to * be concl in order to rewrite and have
+             c also rewritten when the case * will be done *)
+	  let pred =
+            match dflt_concl with
+              | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*)
+              | None ->
+		let sort = get_sort_of env sigma concl in
+		let p = make_arity env true indf sort in
+		abstract_list_all env sigma p concl (realargs@[mkVar id]) in
+	  let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in
+	  (* We lift to make room for the equations *)
+	  (hyps,lift nrealargs bodypred)
+  in
+  let nhyps = List.length hyps in
+  let env' = push_rel_context hyps env in
+  let realargs' = List.map (lift nhyps) realargs in
+  let pairs = list_map_i (compute_eqn env' sigma nhyps) 0 realargs' in
+  (* Now the arity is pushed, and we need to construct the pairs
+   * ai,mkRel(n-i+1) *)
+  (* Now, we can recurse down this list, for each ai,(mkRel k) whether to
+     push <Ai>(mkRel k)=ai (when   Ai is closed).
+   In any case, we carry along the rest of pairs *)
+  let rec build_concl eqns n = function
+    | [] -> (prod_it concl eqns,n)
+    | ((ai,ati),(xi,ti))::restlist ->
+        let (lhs,eqnty,rhs) =
+          if closed0 ti then 
+	    (xi,ti,ai)
+          else 
+	    make_iterated_tuple env' sigma (ai,ati) (xi,ti)
+	in
+        let type_type_rhs = get_sort_of env sigma (type_of env sigma rhs) in
+        let sort = get_sort_of env sigma concl in 
+        let eq_term = find_eq_pattern type_type_rhs sort in
+        let eqn = applist (eq_term ,[eqnty;lhs;rhs]) in 
+	build_concl ((Anonymous,lift n eqn)::eqns) (n+1) restlist
+  in
+  let (newconcl,neqns) = build_concl [] 0 pairs in
+  let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in
+  (* OK - this predicate should now be usable by res_elimination_then to
+     do elimination on the conclusion. *)
+  (predicate,neqns)
+
+(* The result of the elimination is a bunch of goals like:
+
+           |- (cibar:Cibar)Equands->C
+
+   where the cibar are either dependent or not.  We are fed a
+   signature, with "true" for every recursive argument, and false for
+   every non-recursive one.  So we need to do the
+   sign_branch_len(sign) intros, thinning out all recursive
+   assumptions.  This leaves us with exactly length(sign) assumptions.
+
+   We save their names, and then do introductions for all the equands
+   (there are some number of them, which is the other argument of the
+   tactic)
+
+   This gives us the #neqns equations, whose names we get also, and
+   the #length(sign) arguments.
+
+   Suppose that #nodep of these arguments are non-dependent.
+   Generalize and thin them.
+
+   This gives us #dep = #length(sign)-#nodep arguments which are
+   dependent.
+
+   Now, we want to take each of the equations, and do all possible
+   injections to get the left-hand-side to be a variable.  At the same
+   time, if we find a lhs/rhs pair which are different, we can
+   discriminate them to prove false and finish the branch.
+
+   Then, we thin away the equations, and do the introductions for the
+   #nodep arguments which we generalized before.
+ *)
+
+(* Called after the case-assumptions have been killed off, and all the
+   intros have been done.  Given that the clause in question is an
+   equality (if it isn't we fail), we are responsible for projecting
+   the equality, using Injection and Discriminate, and applying it to
+   the concusion *)
+
+(* Computes the subset of hypothesis in the local context whose
+   type depends on t (should be of the form (mkVar id)), then
+   it generalizes them, applies tac to rewrite all occurrencies of t,
+   and introduces generalized hypotheis.
+   Precondition: t=(mkVar id) *)
+    
+let rec dependent_hyps id idlist sign = 
+  let rec dep_rec =function
+    | [] -> []
+    | (id1,_,id1ty as d1)::l -> 
+	if occur_var (Global.env()) id id1ty
+        then d1 :: dep_rec l
+        else dep_rec l
+  in 
+  dep_rec idlist 
+
+let split_dep_and_nodep hyps gl =
+  List.fold_right 
+    (fun (id,_,_ as d) (l1,l2) ->
+       if var_occurs_in_pf gl id then (d::l1,l2) else (l1,d::l2))
+    hyps ([],[])
+
+open Coqlib
+
+(* Computation of dids is late; must have been done in rewrite_equations*)
+(* Will keep generalizing and introducing back and forth... *)
+(* Moreover, others hyps depending of dids should have been *)
+(* generalized; in such a way that [dids] can endly be cleared *)
+(* Consider for instance this case extracted from Well_Ordering.v
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  ============================
+   (Acc WO le_WO y)
+
+  Inversion H0 gives
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  a1 : A
+  f0 : (B a1) ->WO
+  v : (B a1)
+  H1 : (f0 v)=y
+  H3 : a1=a0
+  f1 : (B a0) ->WO
+  v0 : (B a0)
+  H4 : (existS A [a:A](B a) ->WO a0 f1)=(existS A [a:A](B a) ->WO a0 f)
+  ============================
+   (Acc WO le_WO (f1 v0))
+
+while, ideally, we would have expected
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f0 : (B a0)->WO
+  v : (B a0)
+  ============================
+   (Acc WO le_WO (f0 v))
+
+obtained from destruction with equalities
+
+  A : Set
+  B : A ->Set
+  a0 : A
+  f : (B a0) ->WO
+  y : WO
+  H0 : (le_WO y (sup a0 f))
+  a1 : A
+  f0 : (B a1)->WO
+  v : (B a1)
+  H1 : (f0 v)=y
+  H2 : (sup a1 f0)=(sup a0 f)
+  ============================
+   (Acc WO le_WO (f0 v))
+
+by clearing initial hypothesis H0 and its dependency y, clearing H1
+(in fact H1 can be avoided using the same trick as for newdestruct),
+decomposing H2 to get a1=a0 and (a1,f0)=(a0,f), replacing a1 by a0
+everywhere and removing a1 and a1=a0 (in fact it would have been more
+regular to replace a0 by a1, avoiding f1 and v0 cannot replace f0 and v),
+finally removing H4 (here because f is not used, more generally after using
+eq_dep and replacing f by f0) [and finally rename a0, f0 into a,f].
+Summary: nine useless hypotheses!
+Nota: with Inversion_clear, only four useless hypotheses
+*)
+
+let generalizeRewriteIntros tac depids id gls = 
+  let dids = dependent_hyps id depids (pf_env gls) in
+  (tclTHENSEQ
+    [bring_hyps dids; tac; 
+     (* may actually fail to replace if dependent in a previous eq *)
+     intros_replacing (ids_of_named_context dids)])
+  gls
+
+let rec tclMAP_i n tacfun = function
+  | [] -> tclDO n (tacfun None)
+  | a::l -> 
+      if n=0 then error "Too much names"
+      else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
+
+let remember_first_eq id x = if !x = None then x := Some id
+
+(* invariant: ProjectAndApply is responsible for erasing the clause
+   which it is given as input
+   It simplifies the clause (an equality) to use it as a rewrite rule and then
+   erases the result of the simplification. *)
+(* invariant: ProjectAndApplyNoThining simplifies the clause (an equality) .
+   If it can discriminate then the goal is proved, if not tries to use it as
+   a rewrite rule. It erases the clause which is given as input *)
+
+let projectAndApply thin id eqname names depids gls =
+  let env = pf_env gls in
+  let clearer id =
+    if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC) in
+  let subst_hyp_LR id = tclTHEN (tclTRY(hypSubst_LR id onConcl)) (clearer id) in
+  let subst_hyp_RL id = tclTHEN (tclTRY(hypSubst_RL id onConcl)) (clearer id) in
+  let substHypIfVariable tac id gls =
+    let (t,t1,t2) = Hipattern.dest_nf_eq gls (pf_get_hyp_typ gls id) in
+    match (kind_of_term t1, kind_of_term t2) with
+      | Var id1, _ -> generalizeRewriteIntros (subst_hyp_LR id) depids id1 gls
+      | _, Var id2 -> generalizeRewriteIntros (subst_hyp_RL id) depids id2 gls
+      | _ -> tac id gls
+  in
+  let deq_trailer id neqns =
+    tclTHENSEQ 
+      [(if names <> [] then clear [id] else tclIDTAC);
+       (tclMAP_i neqns (fun idopt ->
+	 tclTHEN
+	   (intro_move idopt None)
+	   (* try again to substitute and if still not a variable after *)
+	   (* decomposition, arbitrarily try to rewrite RL !? *)
+	   (tclTRY (onLastHyp (substHypIfVariable subst_hyp_RL))))
+	 names);
+       (if names = [] then clear [id] else tclIDTAC)]
+  in
+  substHypIfVariable
+    (* If no immediate variable in the equation, try to decompose it *)
+    (* and apply a trailer which again try to substitute *)
+    (fun id -> dEqThen (deq_trailer id) (Some (NamedHyp id)))
+    id
+    gls
+
+(* Inversion qui n'introduit pas les hypotheses, afin de pouvoir les nommer
+   soi-meme (proposition de Valerie). *)
+let rewrite_equations_gene othin neqns ba gl =
+  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
+  let rewrite_eqns =
+    match othin with
+      | Some thin ->
+          onLastHyp
+            (fun last ->
+              tclTHENSEQ
+                [tclDO neqns
+                     (tclTHEN intro
+                        (onLastHyp
+                           (fun id ->
+                              tclTRY 
+			        (projectAndApply thin id (ref None)
+				  [] depids))));
+                 onHyps (compose List.rev (afterHyp last)) bring_hyps;
+                 onHyps (afterHyp last)
+                   (compose clear ids_of_named_context)])
+      | None -> tclIDTAC
+  in
+  (tclTHENSEQ
+    [tclDO neqns intro;
+     bring_hyps nodepids;
+     clear (ids_of_named_context nodepids);
+     onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
+     onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+     rewrite_eqns;
+     tclMAP (fun (id,_,_ as d) ->
+               (tclORELSE (clear [id])
+                 (tclTHEN (bring_hyps [d]) (clear [id]))))
+       depids])
+  gl
+
+(* Introduction of the equations on arguments
+   othin: discriminates Simple Inversion, Inversion and Inversion_clear
+     None: the equations are introduced, but not rewritten
+     Some thin: the equations are rewritten, and cleared if thin is true *)
+
+let rec get_names allow_conj = function
+  | IntroWildcard ->
+      error "Discarding pattern not allowed for inversion equations"
+  | IntroOrAndPattern [l] -> 
+      if allow_conj then
+	if l = [] then (None,[]) else
+	  let l = List.map (fun id -> out_some (fst (get_names false id))) l in
+	  (Some (List.hd l), l)
+      else
+	error "Nested conjunctive patterns not allowed for inversion equations"
+  | IntroOrAndPattern l ->
+      error "Disjunctive patterns not allowed for inversion equations"
+  | IntroIdentifier id ->
+      (Some id,[id])
+
+let extract_eqn_names = function
+  | None -> None,[]
+  | Some x -> x
+
+let rewrite_equations othin neqns names ba gl =
+  let names = List.map (get_names true) names in
+  let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
+  let rewrite_eqns =
+    let first_eq = ref None in
+    let update id = if !first_eq = None then first_eq := Some id in
+    match othin with
+      | Some thin ->
+          tclTHENSEQ
+            [onHyps (compose List.rev (nLastHyps neqns)) bring_hyps;
+             onHyps (nLastHyps neqns) (compose clear ids_of_named_context);
+	     tclMAP_i neqns (fun o ->
+	       let idopt,names = extract_eqn_names o in
+               (tclTHEN
+		 (intro_move idopt None)
+		 (onLastHyp (fun id ->
+		   tclTRY (projectAndApply thin id first_eq names depids)))))
+	       names;
+	     tclMAP (fun (id,_,_) gl ->
+	       intro_move None (if thin then None else !first_eq) gl)
+	       nodepids;
+	     tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids]
+      | None -> tclIDTAC
+  in
+  (tclTHENSEQ
+    [tclDO neqns intro;
+     bring_hyps nodepids;
+     clear (ids_of_named_context nodepids);
+     rewrite_eqns])
+  gl
+
+let interp_inversion_kind = function
+  | SimpleInversion -> None
+  | FullInversion -> Some false
+  | FullInversionClear -> Some true
+
+let rewrite_equations_tac (gene, othin) id neqns names ba =
+  let othin = interp_inversion_kind othin in
+  let tac =
+    if gene then rewrite_equations_gene othin neqns ba
+    else rewrite_equations othin neqns names ba in
+  if othin = Some true (* if Inversion_clear, clear the hypothesis *) then 
+    tclTHEN tac (tclTRY (clear [id]))
+  else 
+    tac
+
+
+let raw_inversion inv_kind indbinding id status names gl =
+  let env = pf_env gl and sigma = project gl in
+  let c = mkVar id in
+  let (wc,kONT) = startWalk gl in
+  let t = strong_prodspine (pf_whd_betadeltaiota gl) (pf_type_of gl c) in
+  let indclause = mk_clenv_from wc (c,t) in
+  let indclause' = clenv_constrain_with_bindings indbinding indclause in
+  let newc = clenv_instance_template indclause' in
+  let ccl = clenv_instance_template_type indclause' in
+  check_no_metas indclause' ccl;
+  let IndType (indf,realargs) =
+    try find_rectype env sigma ccl
+    with Not_found ->
+      errorlabstrm "raw_inversion"
+	(str ("The type of "^(string_of_id id)^" is not inductive")) in
+  let (elim_predicate,neqns) =
+    make_inv_predicate env sigma indf realargs id status (pf_concl gl) in
+  let (cut_concl,case_tac) =
+    if status <> NoDep & (dependent c (pf_concl gl)) then 
+      Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])),
+      case_then_using 
+    else 
+      Reduction.beta_appvect elim_predicate (Array.of_list realargs),
+      case_nodep_then_using 
+  in
+  (tclTHENS
+     (true_cut Anonymous cut_concl)
+     [case_tac names 
+       (introCaseAssumsThen (rewrite_equations_tac inv_kind id neqns))
+       (Some elim_predicate) ([],[]) newc;
+      onLastHyp
+        (fun id ->
+           (tclTHEN
+              (apply_term (mkVar id)
+                 (list_tabulate (fun _ -> mkMeta(Clenv.new_meta())) neqns))
+              reflexivity))])
+  gl
+
+(* Error messages of the inversion tactics *)
+let not_found_message ids =
+  if List.length ids = 1 then
+    (str "the variable" ++ spc () ++ str (string_of_id (List.hd ids)) ++ spc () ++
+      str" was not found in the current environment")
+  else 
+    (str "the variables [" ++ 
+      spc () ++ prlist (fun id -> (str (string_of_id id) ++ spc ())) ids ++
+      str" ] were not found in the current environment")
+
+let dep_prop_prop_message id =
+  errorlabstrm "Inv"
+    (str "Inversion on " ++ pr_id id ++
+       str " would needs dependent elimination Prop-Prop")
+ 
+let not_inductive_here id =
+  errorlabstrm "mind_specif_of_mind"
+    (str "Cannot recognize an inductive predicate in " ++ pr_id id ++
+       str ". If there is one, may be the structure of the arity or of the type of constructors is hidden by constant definitions.")
+
+(* Noms d'errreurs obsolètes ?? *)
+let wrap_inv_error id = function
+  | UserError ("Case analysis",s) -> errorlabstrm "Inv needs Nodep Prop Set" s
+  | UserError("mind_specif_of_mind",_)  -> not_inductive_here id
+  | UserError (a,b)  -> errorlabstrm "Inv" b
+  | Invalid_argument (*"it_list2"*) "List.fold_left2" -> dep_prop_prop_message id
+  | Not_found  ->  errorlabstrm "Inv" (not_found_message [id]) 
+  | e -> raise e
+
+(* The most general inversion tactic *)
+let inversion inv_kind status names id gls =
+  try (raw_inversion inv_kind [] id status names) gls
+  with e -> wrap_inv_error id e
+
+(* Specializing it... *)
+
+let inv_gen gene thin status names =
+  try_intros_until (inversion (gene,thin) status names)
+
+open Tacexpr
+
+let inv k = inv_gen false k NoDep
+
+let half_inv_tac id  = inv SimpleInversion None (NamedHyp id)
+let inv_tac id       = inv FullInversion None (NamedHyp id)
+let inv_clear_tac id = inv FullInversionClear None (NamedHyp id)
+
+let dinv k c = inv_gen false k (Dep c)
+
+let half_dinv_tac id  = dinv SimpleInversion None None (NamedHyp id)
+let dinv_tac id       = dinv FullInversion None None (NamedHyp id)
+let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
+
+(* InvIn will bring the specified clauses into the conclusion, and then
+ * perform inversion on the named hypothesis.  After, it will intro them
+ * back to their places in the hyp-list. *)
+
+let invIn k names ids id gls =
+  let hyps = List.map (pf_get_hyp gls) ids in
+  let nb_prod_init = nb_prod (pf_concl gls) in
+  let intros_replace_ids gls =
+    let nb_of_new_hyp =
+      nb_prod (pf_concl gls) - (List.length hyps + nb_prod_init)
+    in 
+    if nb_of_new_hyp < 1 then 
+      intros_replacing ids gls
+    else 
+      tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids) gls
+  in
+  try 
+    (tclTHENSEQ
+      [bring_hyps hyps;
+       inversion (false,k) NoDep names id; 
+       intros_replace_ids])
+    gls
+  with e -> wrap_inv_error id e
+
+let invIn_gen k names idl = try_intros_until (invIn k names idl)
+
+let inv_clause k names = function
+  | [] -> inv k names
+  | idl -> invIn_gen k names idl
diff --git a/tactics/inv.mli b/tactics/inv.mli
new file mode 100644
index 00000000..e19d8232
--- /dev/null
+++ b/tactics/inv.mli
@@ -0,0 +1,44 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: inv.mli,v 1.10.2.1 2004/07/16 19:30:53 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Tacmach
+open Genarg
+open Tacexpr
+open Rawterm
+(*i*)
+
+type inversion_status = Dep of constr option | NoDep
+
+val inv_gen :
+  bool -> inversion_kind -> inversion_status ->
+    intro_pattern_expr option -> quantified_hypothesis -> tactic
+val invIn_gen :
+  inversion_kind -> intro_pattern_expr option -> identifier list -> 
+    quantified_hypothesis -> tactic
+
+val inv_clause :
+  inversion_kind -> intro_pattern_expr option -> identifier list ->
+    quantified_hypothesis -> tactic
+
+val inv : inversion_kind -> intro_pattern_expr option ->
+  quantified_hypothesis -> tactic
+
+val dinv : inversion_kind -> constr option -> intro_pattern_expr option ->
+  quantified_hypothesis -> tactic
+
+val half_inv_tac : identifier -> tactic
+val inv_tac : identifier -> tactic
+val inv_clear_tac : identifier -> tactic
+val half_dinv_tac : identifier -> tactic
+val dinv_tac : identifier -> tactic
+val dinv_clear_tac : identifier -> tactic
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
new file mode 100644
index 00000000..1be465f5
--- /dev/null
+++ b/tactics/leminv.ml
@@ -0,0 +1,318 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: leminv.ml,v 1.41.2.1 2004/07/16 19:30:54 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Evd
+open Printer
+open Reductionops
+open Declarations
+open Entries
+open Inductiveops
+open Environ
+open Tacmach
+open Proof_trees
+open Proof_type
+open Pfedit
+open Evar_refiner
+open Clenv
+open Declare
+open Tacticals
+open Tactics
+open Inv
+open Vernacexpr
+open Safe_typing
+open Decl_kinds
+
+let not_work_message = "tactic fails to build the inversion lemma, may be because the predicate has arguments that depend on other arguments"
+
+let no_inductive_inconstr env constr =
+  (str "Cannot recognize an inductive predicate in " ++ 
+     prterm_env env constr ++
+     str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++
+     spc () ++ str "or of the type of constructors" ++ spc () ++
+     str "is hidden by constant definitions.")
+
+(* Inversion stored in lemmas *)
+
+(* ALGORITHM:
+
+   An inversion stored in a lemma is computed from a term-pattern, in
+   a signature, as follows:
+
+   Suppose we have an inductive relation, (I abar), in a signature Gamma:
+
+       Gamma |- (I abar)
+
+   Then we compute the free-variables of abar.  Suppose that Gamma is
+   thinned out to only include these.
+
+   [We need technically to require that all free-variables of the
+    types of the free variables of abar are themselves free-variables
+    of abar.  This needs to be checked, but it should not pose a
+    problem - it is hard to imagine cases where it would not hold.]
+
+   Now, we pose the goal:
+
+       (P:(Gamma)Prop)(Gamma)(I abar)->(P vars[Gamma]).
+
+   We execute the tactic:
+
+   REPEAT Intro THEN (OnLastHyp (Inv NONE false o outSOME))
+
+   This leaves us with some subgoals.  All the assumptions after "P"
+   in these subgoals are new assumptions.  I.e. if we have a subgoal,
+
+       P:(Gamma)Prop, Gamma, Hbar:Tbar |- (P ybar)
+
+   then the assumption we needed to have was
+
+      (Hbar:Tbar)(P ybar)
+
+   So we construct all the assumptions we need, and rebuild the goal
+   with these assumptions.  Then, we can re-apply the same tactic as
+   above, but instead of stopping after the inversion, we just apply
+   the respective assumption in each subgoal.
+
+ *)
+ 
+let thin_ids env (hyps,vars) =
+  fst
+    (List.fold_left
+       (fun ((ids,globs) as sofar) (id,c,a) ->
+          if List.mem id globs then
+	    match c with
+	      | None -> (id::ids,(global_vars env a)@globs)
+	      | Some body ->
+                  (id::ids,(global_vars env body)@(global_vars env a)@globs)
+          else sofar)
+       ([],vars) hyps)
+
+(* returns the sub_signature of sign corresponding to those identifiers that
+ * are not global. *)
+(*
+let get_local_sign sign =
+  let lid = ids_of_sign sign in
+  let globsign = Global.named_context() in
+  let add_local id res_sign = 
+    if not (mem_sign globsign id) then 
+      add_sign (lookup_sign id sign) res_sign
+    else 
+      res_sign
+  in 
+  List.fold_right add_local lid nil_sign
+*)
+(* returs the identifier of lid that was the latest declared in sign.
+ * (i.e. is the identifier id of lid such that 
+ * sign_length (sign_prefix id sign) > sign_length (sign_prefix id' sign) >
+ * for any id'<>id in lid).
+ * it returns both the pair (id,(sign_prefix id sign)) *)
+(*
+let max_prefix_sign lid sign =
+  let rec max_rec (resid,prefix) = function
+    | [] -> (resid,prefix)
+    | (id::l) -> 
+	let pre = sign_prefix id sign in  
+	if sign_length pre > sign_length prefix then 
+          max_rec (id,pre) l
+        else 
+	  max_rec (resid,prefix) l
+  in
+  match lid with 
+    | [] -> nil_sign
+    | id::l -> snd (max_rec (id, sign_prefix id sign) l)
+*)
+let rec add_prods_sign env sigma t =
+  match kind_of_term (whd_betadeltaiota env sigma t) with
+    | Prod (na,c1,b) ->
+	let id = id_of_name_using_hdchar env t na in
+	let b'= subst1 (mkVar id) b in
+        add_prods_sign (push_named (id,None,c1) env) sigma b'
+    | LetIn (na,c1,t1,b) ->
+	let id = id_of_name_using_hdchar env t na in
+	let b'= subst1 (mkVar id) b in
+        add_prods_sign (push_named (id,Some c1,t1) env) sigma b'
+    | _ -> (env,t)
+
+(* [dep_option] indicates wether the inversion lemma is dependent or not.
+   If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then
+   the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) 
+   where P:(x_bar:T_bar)(H:(I x_bar))[sort].
+   The generalisation of such a goal at the moment of the dependent case should
+   be easy.
+
+   If it is non dependent, then if [I]=(I t_bar) and (x_bar:T_bar) are the
+   variables occurring in [I], then the stated goal will be:
+    (x_bar:T_bar)(I t_bar)->(P x_bar) 
+   where P: P:(x_bar:T_bar)[sort].
+*)
+
+let compute_first_inversion_scheme env sigma ind sort dep_option =
+  let indf,realargs = dest_ind_type ind in
+  let allvars = ids_of_context env in
+  let p = next_ident_away (id_of_string "P") allvars in
+  let pty,goal =
+    if dep_option  then
+      let pty = make_arity env true indf sort in
+      let goal = 
+	mkProd
+	  (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1]))
+      in
+      pty,goal
+    else
+      let i = mkAppliedInd ind in
+      let ivars = global_vars env i in
+      let revargs,ownsign =
+	fold_named_context
+	  (fun env (id,_,_ as d) (revargs,hyps) ->
+             if List.mem id ivars then 
+	       ((mkVar id)::revargs,add_named_decl d hyps)
+	     else 
+	       (revargs,hyps))
+          env ~init:([],[]) 
+      in
+      let pty = it_mkNamedProd_or_LetIn (mkSort sort) ownsign in
+      let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in
+      (pty,goal)
+  in
+  let npty = nf_betadeltaiota env sigma pty in
+  let extenv = push_named (p,None,npty) env in
+  extenv, goal
+
+(* [inversion_scheme sign I]
+
+   Given a local signature, [sign], and an instance of an inductive
+   relation, [I], inversion_scheme will prove the associated inversion
+   scheme on sort [sort]. Depending on the value of [dep_option] it will
+   build a dependent lemma or a non-dependent one *)
+
+let inversion_scheme env sigma t sort dep_option inv_op =
+  let (env,i) = add_prods_sign env sigma t in
+  let ind =
+    try find_rectype env sigma i
+    with Not_found ->
+      errorlabstrm "inversion_scheme" (no_inductive_inconstr env i) 
+  in
+  let (invEnv,invGoal) =
+    compute_first_inversion_scheme env sigma ind sort dep_option 
+  in
+  assert 
+    (list_subset 
+       (global_vars env invGoal) 
+       (ids_of_named_context (named_context invEnv)));
+  (*
+    errorlabstrm "lemma_inversion"
+    (str"Computed inversion goal was not closed in initial signature");
+  *)
+  let invSign = named_context invEnv in
+  let pfs = mk_pftreestate (mk_goal invSign invGoal) in
+  let pfs = solve_pftreestate (tclTHEN intro (onLastHyp inv_op)) pfs in
+  let (pfterm,meta_types) = extract_open_pftreestate pfs in
+  let global_named_context = Global.named_context () in
+  let ownSign =
+    fold_named_context
+      (fun env (id,_,_ as d) sign ->
+         if mem_named_context id global_named_context then sign
+	 else add_named_decl d sign)
+      invEnv ~init:empty_named_context 
+  in
+  let (_,ownSign,mvb) =
+    List.fold_left
+      (fun (avoid,sign,mvb) (mv,mvty) ->
+         let h = next_ident_away (id_of_string "H") avoid in
+	 (h::avoid, add_named_decl (h,None,mvty) sign, (mv,mkVar h)::mvb))
+      (ids_of_context invEnv, ownSign, [])
+      meta_types 
+  in
+  let invProof = 
+    it_mkNamedLambda_or_LetIn (local_strong (whd_meta mvb) pfterm) ownSign 
+  in
+  invProof
+
+let add_inversion_lemma name env sigma t sort dep inv_op =
+  let invProof = inversion_scheme env sigma t sort dep inv_op in
+  let _ = 
+    declare_constant name
+    (DefinitionEntry { const_entry_body = invProof;
+                     const_entry_type = None;
+                     const_entry_opaque = false }, 
+     IsProof Lemma)
+  in ()
+
+(* open Pfedit *)
+
+(* inv_op = Inv (derives de complete inv. lemma)
+ * inv_op = InvNoThining (derives de semi inversion lemma) *)
+
+let inversion_lemma_from_goal n na id sort dep_option inv_op =
+  let pts = get_pftreestate() in
+  let gl = nth_goal_of_pftreestate n pts in
+  let t = pf_get_hyp_typ gl id in
+  let env = pf_env gl and sigma = project gl in
+  let fv = global_vars env t in
+(* Pourquoi ??? 
+  let thin_ids = thin_ids (hyps,fv) in
+  if not(list_subset thin_ids fv) then
+    errorlabstrm "lemma_inversion"
+      (str"Cannot compute lemma inversion when there are" ++ spc () ++
+	 str"free variables in the types of an inductive" ++ spc () ++
+	 str"which are not free in its instance"); *)
+  add_inversion_lemma na env sigma t sort dep_option inv_op
+   
+let add_inversion_lemma_exn na com comsort bool tac =
+  let env = Global.env () and sigma = Evd.empty in
+  let c = Constrintern.interp_type sigma env com in
+  let sort = Pretyping.interp_sort comsort in
+  try
+    add_inversion_lemma na env sigma c sort bool tac
+  with 
+    |   UserError ("Case analysis",s) -> (* référence à Indrec *)
+	  errorlabstrm "Inv needs Nodep Prop Set" s
+
+(* ================================= *)
+(* Applying a given inversion lemma  *)
+(* ================================= *)
+
+let lemInv id c gls =
+  try
+    let (wc,kONT) = startWalk gls in
+    let clause = mk_clenv_type_of wc c in
+    let clause = clenv_constrain_with_bindings [(-1,mkVar id)] clause in
+    elim_res_pf kONT clause true gls
+  with 
+    |  UserError (a,b) -> 
+	 errorlabstrm "LemInv" 
+	   (str "Cannot refine current goal with the lemma " ++ 
+	      prterm_env (Global.env()) c) 
+
+let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
+
+let lemInvIn id c ids gls =
+  let hyps = List.map (pf_get_hyp gls) ids in
+  let intros_replace_ids gls =
+    let nb_of_new_hyp  = nb_prod (pf_concl gls) - List.length ids in 
+    if nb_of_new_hyp < 1  then 
+      intros_replacing ids gls
+    else 
+      (tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids)) gls
+  in 
+  ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
+    (intros_replace_ids)) gls)
+
+let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id
+
+let lemInv_clause id c = function
+  | [] -> lemInv_gen id c
+  | l -> lemInvIn_gen id c l
diff --git a/tactics/leminv.mli b/tactics/leminv.mli
new file mode 100644
index 00000000..6617edf2
--- /dev/null
+++ b/tactics/leminv.mli
@@ -0,0 +1,19 @@
+
+open Names
+open Term
+open Rawterm
+open Proof_type
+open Topconstr
+
+val lemInv_gen : quantified_hypothesis -> constr -> tactic
+val lemInvIn_gen : quantified_hypothesis -> constr -> identifier list -> tactic
+
+val lemInv_clause : 
+  quantified_hypothesis -> constr -> identifier list -> tactic
+
+val inversion_lemma_from_goal :
+  int -> identifier -> identifier -> sorts -> bool ->
+    (identifier -> tactic) -> unit
+val add_inversion_lemma_exn :
+  identifier -> constr_expr -> rawsort -> bool -> (identifier -> tactic) ->
+    unit
diff --git a/tactics/nbtermdn.ml b/tactics/nbtermdn.ml
new file mode 100644
index 00000000..bd4fb60e
--- /dev/null
+++ b/tactics/nbtermdn.ml
@@ -0,0 +1,83 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: nbtermdn.ml,v 1.7.16.1 2004/07/16 19:30:54 herbelin Exp $ *)
+
+open Util
+open Names
+open Term
+open Libobject
+open Library
+open Pattern
+
+(* Named, bounded-depth, term-discrimination nets.
+   Implementation:
+   Term-patterns are stored in discrimination-nets, which are
+   themselves stored in a hash-table, indexed by the first label.
+   They are also stored by name in a table on-the-side, so that we can
+   override them if needed. *)
+
+(* The former comments are from Chet.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+
+type ('na,'a) t = {
+  mutable table : ('na,constr_pattern * 'a) Gmap.t;
+  mutable patterns : (constr_label option,'a Btermdn.t) Gmap.t }
+
+type ('na,'a) frozen_t = 
+    ('na,constr_pattern * 'a) Gmap.t
+    * (constr_label option,'a Btermdn.t) Gmap.t
+
+let create () =
+  { table = Gmap.empty;
+    patterns = Gmap.empty }
+
+let get_dn dnm hkey =
+  try Gmap.find hkey dnm with Not_found -> Btermdn.create ()
+
+let add dn (na,(pat,valu)) =
+  let hkey = option_app fst (Termdn.constr_pat_discr pat) in 
+  dn.table <- Gmap.add na (pat,valu) dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Btermdn.add (get_dn dnm hkey) (pat,valu)) dnm
+    
+let rmv dn na =
+  let (pat,valu) = Gmap.find na dn.table in
+  let hkey = option_app fst (Termdn.constr_pat_discr pat) in 
+  dn.table <- Gmap.remove na dn.table;
+  let dnm = dn.patterns in
+  dn.patterns <- Gmap.add hkey (Btermdn.rmv (get_dn dnm hkey) (pat,valu)) dnm
+
+let in_dn dn na = Gmap.mem na dn.table
+			  
+let remap ndn na (pat,valu) =
+  rmv ndn na;
+  add ndn (na,(pat,valu))
+
+let lookup dn valu =
+  let hkey = option_app fst (Termdn.constr_val_discr valu) in 
+  try Btermdn.lookup (Gmap.find hkey  dn.patterns) valu with Not_found -> []
+
+let app f dn = Gmap.iter f dn.table
+		       
+let dnet_depth = Btermdn.dnet_depth
+		   
+let freeze dn = (dn.table, dn.patterns)
+
+let unfreeze (fnm,fdnm) dn =
+  dn.table <- fnm;
+  dn.patterns <- fdnm
+
+let empty dn = 
+  dn.table <- Gmap.empty;
+  dn.patterns <- Gmap.empty
+
+let to2lists dn = 
+  (Gmap.to_list dn.table, Gmap.to_list dn.patterns)
+
diff --git a/tactics/nbtermdn.mli b/tactics/nbtermdn.mli
new file mode 100644
index 00000000..90656619
--- /dev/null
+++ b/tactics/nbtermdn.mli
@@ -0,0 +1,37 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: nbtermdn.mli,v 1.8.16.1 2004/07/16 19:30:54 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+
+(* Named, bounded-depth, term-discrimination nets. *)
+
+type ('na,'a) t
+type ('na,'a) frozen_t
+
+val create : unit -> ('na,'a) t
+
+val add : ('na,'a) t -> ('na * (constr_pattern * 'a)) -> unit
+val rmv : ('na,'a) t -> 'na -> unit
+val in_dn : ('na,'a) t -> 'na -> bool
+val remap : ('na,'a) t -> 'na -> (constr_pattern * 'a) -> unit
+
+val lookup : ('na,'a) t -> constr -> (constr_pattern * 'a) list
+val app : ('na -> (constr_pattern * 'a) -> unit) -> ('na,'a) t -> unit
+
+val dnet_depth : int ref
+
+val freeze : ('na,'a) t -> ('na,'a) frozen_t
+val unfreeze : ('na,'a) frozen_t -> ('na,'a) t -> unit
+val empty : ('na,'a) t -> unit
+val to2lists : ('na,'a) t -> ('na * (constr_pattern * 'a)) list * 
+                             (constr_label option * 'a Btermdn.t) list
diff --git a/tactics/refine.ml b/tactics/refine.ml
new file mode 100644
index 00000000..4a2fb01b
--- /dev/null
+++ b/tactics/refine.ml
@@ -0,0 +1,346 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: refine.ml,v 1.34.2.2 2004/07/16 19:30:54 herbelin Exp $ *)
+
+(* JCF -- 6 janvier 1998  EXPERIMENTAL *)
+
+(*
+ *  L'idée est, en quelque sorte, d'avoir de "vraies" métavariables
+ *  dans Coq, c'est-à-dire de donner des preuves incomplètes -- mais
+ *  où les trous sont typés -- et que les sous-buts correspondants
+ *  soient engendrés pour finir la preuve.
+ *
+ *  Exemple : 
+ *    J'ai le but
+ *        (x:nat) { y:nat | (minus y x) = x }
+ *    et je donne la preuve incomplète
+ *        [x:nat](exist nat [y:nat]((minus y x)=x) (plus x x) ?)
+ *    ce qui engendre le but
+ *        (minus (plus x x) x)=x
+ *)
+
+(*  Pour cela, on procède de la manière suivante :
+ *
+ *  1. Un terme de preuve incomplet est un terme contenant des variables
+ *     existentielles Evar i.e. "?" en syntaxe concrète.
+ *     La résolution de ces variables n'est plus nécessairement totale
+ *     (ise_resolve called with fail_evar=false) et les variables
+ *     existentielles restantes sont remplacées par des méta-variables
+ *     castées par leur types (celui est connu : soit donné, soit trouvé
+ *     pendant la phase de résolution).
+ *
+ *  2. On met ensuite le terme "à plat" i.e. on n'autorise des MV qu'au
+ *     permier niveau et pour chacune d'elles, si nécessaire, on donne
+ *     à son tour un terme de preuve incomplet pour la résoudre.
+ *     Exemple: le terme (f a ? [x:nat](e ?)) donne
+ *         (f a ?1 ?2) avec ?2 => [x:nat]?3 et ?3 => (e ?4)
+ *         ?1 et ?4 donneront des buts
+ *
+ *  3. On écrit ensuite une tactique tcc qui engendre les sous-buts
+ *     à partir d'une preuve incomplète.
+ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Tacmach
+open Sign
+open Environ
+open Reduction
+open Typing
+open Tactics
+open Tacticals
+open Printer
+
+type term_with_holes = TH of constr * metamap * sg_proofs
+and  sg_proofs       = (term_with_holes option) list
+
+(* pour debugger *)
+
+let rec pp_th (TH(c,mm,sg)) =
+  (str"TH=[ " ++ hov 0 (prterm c ++ fnl () ++
+			      (* pp_mm mm ++ fnl () ++ *)
+			   pp_sg sg) ++ str "]")
+and pp_mm l =
+  hov 0 (prlist_with_sep (fun _ -> (fnl ())) 
+	   (fun (n,c) -> (int n ++ str" --> " ++ prterm c)) l)
+and pp_sg sg =
+  hov 0 (prlist_with_sep (fun _ -> (fnl ()))
+	   (function None -> (str"None") | Some th -> (pp_th th)) sg)
+     
+(*  compute_metamap : constr -> 'a evar_map -> term_with_holes
+ *  réalise le 2. ci-dessus
+ *
+ *  Pour cela, on renvoie une meta_map qui indique pour chaque meta-variable
+ *  si elle correspond à un but (None) ou si elle réduite à son tour
+ *  par un terme de preuve incomplet (Some c).
+ *
+ *  On a donc l'INVARIANT suivant : le terme c rendu est "de niveau 1"
+ *  -- i.e. à plat -- et la meta_map contient autant d'éléments qu'il y 
+ *  a de meta-variables dans c. On suppose de plus que l'ordre dans la
+ *  meta_map correspond à celui des buts qui seront engendrés par le refine.
+ *)
+
+let replace_by_meta env gmm = function
+  | TH (m, mm, sgp) when isMeta (strip_outer_cast m) -> m,mm,sgp
+  | (TH (c,mm,_)) as th ->
+      let n = Clenv.new_meta() in
+      let m = mkMeta n in
+      (* quand on introduit une mv on calcule son type *)
+      let ty = match kind_of_term c with
+	| Lambda (Name id,c1,c2) when isCast c2 ->
+	    mkNamedProd id c1 (snd (destCast c2))
+	| Lambda (Anonymous,c1,c2) when isCast c2 ->
+	    mkArrow c1 (snd (destCast c2))
+	| _ -> (* (App _ | Case _) -> *)
+	    Retyping.get_type_of_with_meta env Evd.empty (gmm@mm) c
+	(*
+	| Fix ((_,j),(v,_,_)) ->
+	    v.(j) (* en pleine confiance ! *)
+	| _ -> invalid_arg "Tcc.replace_by_meta (TO DO)" 
+        *)
+      in
+      mkCast (m,ty),[n,ty],[Some th]
+
+exception NoMeta
+
+let replace_in_array env gmm a =
+  if array_for_all (function (TH (_,_,[])) -> true | _ -> false) a then
+    raise NoMeta;
+  let a' = Array.map (function
+			| (TH (c,mm,[])) -> c,mm,[]
+			| th -> replace_by_meta env gmm th) a 
+  in
+  let v' = Array.map (fun (x,_,_) -> x) a' in
+  let mm = Array.fold_left (@) [] (Array.map (fun (_,x,_) -> x) a') in
+  let sgp = Array.fold_left (@) [] (Array.map (fun (_,_,x) -> x) a') in
+  v',mm,sgp
+    
+let fresh env n =
+  let id = match n with Name x -> x | _ -> id_of_string "_" in
+  next_global_ident_away true id (ids_of_named_context (named_context env))
+
+let rec compute_metamap env gmm c = match kind_of_term c with
+  (* le terme est directement une preuve *)
+  | (Const _ | Evar _ | Ind _ | Construct _ |
+    Sort _ | Var _ | Rel _) -> 
+      TH (c,[],[])
+  (* le terme est une mv => un but *)
+  | Meta n ->
+      (* 
+      Pp.warning (Printf.sprintf ("compute_metamap: MV(%d) sans type !\n") n);
+      let ty = Retyping.get_type_of_with_meta env Evd.empty lmeta c in 
+      *)
+      TH (c,[],[None])
+  | Cast (m,ty) when isMeta m -> 
+      TH (c,[destMeta m,ty],[None])
+
+  (* abstraction => il faut décomposer si le terme dessous n'est pas pur
+   *    attention : dans ce cas il faut remplacer (Rel 1) par (Var x)
+   *    où x est une variable FRAICHE *)
+  | Lambda (name,c1,c2) ->
+      let v = fresh env name in
+      let env' = push_named (v,None,c1) env in
+      begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with
+	(* terme de preuve complet *)
+	| TH (_,_,[]) -> TH (c,[],[])
+	(* terme de preuve incomplet *)    
+	| th ->
+	    let m,mm,sgp = replace_by_meta env' gmm th in
+	    TH (mkLambda (Name v,c1,m), mm, sgp)
+      end
+
+  | LetIn (name, c1, t1, c2) ->
+      if occur_meta c1 then 
+	error "Refine: body of let-in cannot contain existentials";
+      let v = fresh env name in
+      let env' = push_named (v,Some c1,t1) env in
+      begin match compute_metamap env' gmm (subst1 (mkVar v) c2) with
+	(* terme de preuve complet *)
+	| TH (_,_,[]) -> TH (c,[],[])
+	(* terme de preuve incomplet *)    
+	| th ->
+	    let m,mm,sgp = replace_by_meta env' gmm th in
+	    TH (mkLetIn (Name v,c1,t1,m), mm, sgp)
+      end
+
+  (* 4. Application *)
+  | App (f,v) ->
+      let a = Array.map (compute_metamap env gmm) (Array.append [|f|] v) in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env gmm a in
+          let v'' = Array.sub v' 1 (Array.length v) in
+          TH (mkApp(v'.(0), v''),mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+  | Case (ci,p,cc,v) ->
+      (* bof... *)
+      let nbr = Array.length v in
+      let v = Array.append [|p;cc|] v in
+      let a = Array.map (compute_metamap env gmm) v in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env gmm a in
+	  let v'' = Array.sub v' 2 nbr in
+	  TH (mkCase (ci,v'.(0),v'.(1),v''),mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+  (* 5. Fix. *)
+  | Fix ((ni,i),(fi,ai,v)) ->
+      (* TODO: use a fold *)
+      let vi = Array.map (fresh env) fi in
+      let fi' = Array.map (fun id -> Name id) vi in
+      let env' = push_named_rec_types (fi',ai,v) env in
+      let a = Array.map
+		(compute_metamap env' gmm)
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+      in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env' gmm a in
+	  let fix = mkFix ((ni,i),(fi',ai,v')) in
+	  TH (fix,mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+	      
+  (* Cast. Est-ce bien exact ? *)
+  | Cast (c,t) -> compute_metamap env gmm c
+      (*let TH (c',mm,sgp) = compute_metamap sign c in
+	TH (mkCast (c',t),mm,sgp) *)
+      
+  (* Produit. Est-ce bien exact ? *)
+  | Prod (_,_,_) ->
+      if occur_meta c then
+	error "Refine: proof term contains metas in a product"
+      else
+      	TH (c,[],[])
+
+  (* Cofix. *)
+  | CoFix (i,(fi,ai,v)) ->
+      let vi = Array.map (fresh env) fi in
+      let fi' = Array.map (fun id -> Name id) vi in
+      let env' = push_named_rec_types (fi',ai,v) env in
+      let a = Array.map
+		(compute_metamap env' gmm)
+		(Array.map (substl (List.map mkVar (Array.to_list vi))) v) 
+      in
+      begin
+	try
+	  let v',mm,sgp = replace_in_array env' gmm a in
+	  let cofix = mkCoFix (i,(fi',ai,v')) in
+	  TH (cofix,mm,sgp)
+	with NoMeta ->
+	  TH (c,[],[])
+      end
+
+
+(*  tcc_aux : term_with_holes -> tactic
+ * 
+ *  Réalise le 3. ci-dessus
+ *)
+
+let rec tcc_aux subst (TH (c,mm,sgp) as th) gl =
+  let c = substl subst c in
+  match (kind_of_term c,sgp) with
+    (* mv => sous-but : on ne fait rien *)
+    | Meta _ , _ ->
+	tclIDTAC gl
+
+    | Cast (c,_), _ when isMeta c ->
+	tclIDTAC gl
+	  
+    (* terme pur => refine *)
+    | _,[] ->
+	refine c gl
+	
+    (* abstraction => intro *)
+    | Lambda (Name id,_,m), _ when isMeta (strip_outer_cast m) ->
+	begin match sgp with
+	  | [None] -> introduction id gl
+	  | [Some th] ->
+              tclTHEN (introduction id)
+                (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th)) gl
+	  | _ -> assert false
+	end
+	
+    | Lambda _, _ ->
+	anomaly "invalid lambda passed to function tcc_aux"
+
+    (* let in *)
+    | LetIn (Name id,c1,t1,c2), _ when isMeta (strip_outer_cast c2) ->
+	let c = pf_concl gl in
+	let newc = mkNamedLetIn id c1 t1 c in
+	tclTHEN 
+	  (change_in_concl None newc) 
+	  (match sgp with 
+	     | [None] -> introduction id
+	     | [Some th] ->
+                 tclTHEN (introduction id)
+                   (onLastHyp (fun id -> tcc_aux (mkVar id::subst) th))
+	     | _ -> assert false) 
+	  gl
+
+    | LetIn _, _ ->
+	anomaly "invalid let-in passed to function tcc_aux"
+
+    (* fix => tactique Fix *)
+    | Fix ((ni,_),(fi,ai,_)) , _ ->
+	let out_name = function
+	  | Name id -> id
+          | _ -> error "recursive functions must have names !"
+	in
+	let fixes = array_map3 (fun f n c -> (out_name f,succ n,c)) fi ni ai in
+	tclTHENS
+	  (mutual_fix (out_name fi.(0)) (succ ni.(0))
+	    (List.tl (Array.to_list fixes)))
+	  (List.map (function
+		       | None -> tclIDTAC 
+		       | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+    (* cofix => tactique CoFix *)
+    | CoFix (_,(fi,ai,_)) , _ ->
+	let out_name = function
+	  | Name id -> id
+          | _ -> error "recursive functions must have names !"
+	in
+	let cofixes = array_map2 (fun f c -> (out_name f,c)) fi ai in
+	tclTHENS
+	  (mutual_cofix (out_name fi.(0)) (List.tl (Array.to_list cofixes)))
+	  (List.map (function
+		       | None -> tclIDTAC 
+		       | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+    (* sinon on fait refine du terme puis appels rec. sur les sous-buts.
+     * c'est le cas pour App et MutCase. *)
+    | _ ->
+	tclTHENS
+	  (refine c)
+	  (List.map
+            (function None -> tclIDTAC | Some th -> tcc_aux subst th) sgp)
+	  gl
+
+(* Et finalement la tactique refine elle-même : *)
+
+let refine oc gl =
+  let sigma = project gl in
+  let env = pf_env gl in
+  let (gmm,c) = Clenv.exist_to_meta sigma oc in
+  let th = compute_metamap env gmm c in
+  tcc_aux [] th gl
+
diff --git a/tactics/refine.mli b/tactics/refine.mli
new file mode 100644
index 00000000..e053aea6
--- /dev/null
+++ b/tactics/refine.mli
@@ -0,0 +1,14 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: refine.mli,v 1.7.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+open Term
+open Tacmach
+
+val refine : Pretyping.open_constr -> tactic
diff --git a/tactics/setoid_replace.ml b/tactics/setoid_replace.ml
new file mode 100644
index 00000000..74b062e0
--- /dev/null
+++ b/tactics/setoid_replace.ml
@@ -0,0 +1,686 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: setoid_replace.ml,v 1.31.2.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Tacmach
+open Proof_type
+open Libobject
+open Reductionops
+open Term
+open Termops
+open Names
+open Entries
+open Libnames
+open Nameops
+open Util
+open Pp
+open Printer
+open Environ
+open Tactics 
+open Tacticals
+open Vernacexpr
+open Safe_typing
+open Nametab
+open Decl_kinds
+open Constrintern
+
+type setoid =
+    { set_a : constr;
+      set_aeq : constr;
+      set_th : constr
+    }
+
+type morphism =
+    { lem : constr;
+      profil : bool list;
+      arg_types : constr list;
+      lem2 : constr option
+    }
+
+let constr_of c = Constrintern.interp_constr Evd.empty (Global.env()) c
+
+let constant dir s = Coqlib.gen_constant "Setoid_replace" ("Setoids"::dir) s
+
+let global_constant dir s =Coqlib.gen_constant "Setoid_replace" ("Init"::dir) s
+
+let current_constant id =
+  try
+    global_reference id
+  with Not_found ->
+    anomaly ("Setoid: cannot find "^(string_of_id id))
+
+(* Setoid_theory *)
+
+let coq_Setoid_Theory = lazy(constant ["Setoid"] "Setoid_Theory")
+
+let coq_seq_refl = lazy(constant ["Setoid"] "Seq_refl")
+let coq_seq_sym = lazy(constant ["Setoid"] "Seq_sym")
+let coq_seq_trans = lazy(constant ["Setoid"] "Seq_trans")
+
+let coq_fleche = lazy(constant ["Setoid"] "fleche")
+
+(* Coq constants *)
+
+let coqeq = lazy(global_constant ["Logic"] "eq")
+
+let coqconj = lazy(global_constant ["Logic"] "conj")
+let coqand = lazy(global_constant ["Logic"] "and")
+let coqproj1 = lazy(global_constant ["Logic"] "proj1")
+let coqproj2 = lazy(global_constant ["Logic"] "proj2")
+
+(************************* Table of declared setoids **********************)
+
+
+(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
+
+module Cmap = Map.Make(struct type t = constr let compare = compare end)
+
+let setoid_table = ref Gmap.empty
+
+let setoid_table_add (s,th) = setoid_table := Gmap.add s th !setoid_table
+let setoid_table_find s = Gmap.find s !setoid_table
+let setoid_table_mem s = Gmap.mem s !setoid_table
+
+let subst_setoid subst setoid = 
+  let set_a' = subst_mps subst setoid.set_a in
+  let set_aeq' = subst_mps subst setoid.set_aeq in
+  let set_th' = subst_mps subst setoid.set_th in
+    if set_a' == setoid.set_a
+      && set_aeq' == setoid.set_aeq
+      && set_th' == setoid.set_th
+    then
+      setoid
+    else
+      { set_a = set_a' ;
+	set_aeq = set_aeq' ;
+	set_th = set_th' ;
+      }
+      
+let equiv_list () = List.map (fun x -> x.set_aeq) (Gmap.rng !setoid_table)
+
+let _ = 
+  Summary.declare_summary "setoid-table"
+    { Summary.freeze_function = (fun () -> !setoid_table);
+      Summary.unfreeze_function = (fun t -> setoid_table := t);
+      Summary.init_function = (fun () -> setoid_table := Gmap .empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* Declare a new type of object in the environment : "setoid-theory". *)
+
+let (setoid_to_obj, obj_to_setoid)=
+  let cache_set (_,(s, th)) = setoid_table_add (s,th)
+  and subst_set (_,subst,(s,th as obj)) =
+    let s' = subst_mps subst s in
+    let th' = subst_setoid subst th in
+      if s' == s && th' == th then obj else
+	(s',th')
+  and export_set x = Some x 
+  in 
+    declare_object {(default_object "setoid-theory") with
+		      cache_function = cache_set;
+		      open_function = (fun i o -> if i=1 then cache_set o);
+		      subst_function = subst_set;
+		      classify_function = (fun (_,x) -> Substitute x);
+		      export_function = export_set}
+
+(******************************* Table of declared morphisms ********************)
+
+(* Setoids are stored in a table which is synchronised with the Reset mechanism. *)
+
+let morphism_table = ref Gmap.empty
+
+let morphism_table_add (m,c) = morphism_table := Gmap.add m c !morphism_table
+let morphism_table_find m = Gmap.find m !morphism_table
+let morphism_table_mem m = Gmap.mem m !morphism_table
+
+let subst_morph subst morph = 
+  let lem' = subst_mps subst morph.lem in
+  let arg_types' = list_smartmap (subst_mps subst) morph.arg_types in
+  let lem2' = option_smartmap (subst_mps subst) morph.lem2 in
+    if lem' == morph.lem
+      && arg_types' == morph.arg_types
+      && lem2' == morph.lem2
+    then
+      morph
+    else
+      { lem = lem' ;
+	profil = morph.profil ;
+	arg_types = arg_types' ;
+	lem2 = lem2' ;
+      }
+
+
+let _ = 
+  Summary.declare_summary "morphism-table"
+    { Summary.freeze_function = (fun () -> !morphism_table);
+      Summary.unfreeze_function = (fun t -> morphism_table := t);
+      Summary.init_function = (fun () -> morphism_table := Gmap .empty);
+      Summary.survive_module = false;
+      Summary.survive_section = false }
+
+(* Declare a new type of object in the environment : "morphism-definition". *)
+
+let (morphism_to_obj, obj_to_morphism)=
+  let cache_set (_,(m, c)) = morphism_table_add (m, c)
+  and subst_set (_,subst,(m,c as obj)) = 
+    let m' = subst_mps subst m in
+    let c' = subst_morph subst c in
+      if m' == m && c' == c then obj else
+	(m',c')
+  and export_set x = Some x 
+  in 
+    declare_object {(default_object "morphism-definition") with
+		      cache_function = cache_set;
+		      open_function = (fun i o -> if i=1 then cache_set o);
+		      subst_function = subst_set;
+		      classify_function = (fun (_,x) -> Substitute x);
+		      export_function = export_set}
+
+(************************** Adding a setoid to the database *********************)
+
+(* Find the setoid theory associated with a given type A.
+This implies that only one setoid theory can be declared for
+a given type A. *)
+
+let find_theory a =
+  try 
+    setoid_table_find a 
+  with Not_found ->
+    errorlabstrm "Setoid" 
+      (str "No Declared Setoid Theory for " ++
+	 prterm a ++ fnl () ++
+	 str "Use Add Setoid to declare it")
+    
+(* Add a Setoid to the database after a type verification. *)
+
+let eq_lem_common_sign env a eq =
+  let na = named_hd env a Anonymous in
+  let ne = named_hd env eq Anonymous in
+  [(ne,None,mkApp (eq, [|(mkRel 3);(mkRel 2)|]));
+   (ne,None,mkApp (eq, [|(mkRel 4);(mkRel 3)|]));
+   (na,None,a);(na,None,a);(na,None,a);(na,None,a)]
+
+(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->(eq a c)->(eq b d) *)
+let eq_lem_proof env a eq sym trans = 
+  let sign = eq_lem_common_sign env a eq in
+  let ne = named_hd env eq Anonymous in
+  let sign = (ne,None,mkApp (eq, [|(mkRel 6);(mkRel 4)|]))::sign in
+  let ccl = mkApp (eq, [|(mkRel 6);(mkRel 4)|]) in
+  let body =
+    mkApp (trans,
+      [|(mkRel 6);(mkRel 7);(mkRel 4);
+        (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|]));
+	  (mkApp (trans,
+	    [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|]) in
+  let p = it_mkLambda_or_LetIn body sign in
+  let t = it_mkProd_or_LetIn ccl sign in
+  (p,t)
+
+(* Proof of (a,b,c,d:A)(eq a b)->(eq c d)->((eq a c)<->(eq b d)) *)
+let eq_lem2_proof env a eq sym trans =
+  let sign = eq_lem_common_sign env a eq in
+  let ccl1 =
+    mkArrow
+      (mkApp (eq, [|(mkRel 6);(mkRel 4)|]))
+      (mkApp (eq, [|(mkRel 6);(mkRel 4)|])) in
+  let ccl2 =
+    mkArrow
+      (mkApp (eq, [|(mkRel 5);(mkRel 3)|]))
+      (mkApp (eq, [|(mkRel 7);(mkRel 5)|])) in
+  let ccl = mkApp (Lazy.force coqand, [|ccl1;ccl2|]) in
+  let body =
+    mkApp ((Lazy.force coqconj),
+    [|ccl1;ccl2;
+      lambda_create env
+	(mkApp (eq, [|(mkRel 6);(mkRel 4)|]),
+	(mkApp (trans,
+	  [|(mkRel 6);(mkRel 7);(mkRel 4);
+	    (mkApp (sym, [|(mkRel 7);(mkRel 6);(mkRel 3)|]));
+	    (mkApp (trans,
+	      [|(mkRel 7);(mkRel 5);(mkRel 4);(mkRel 1);(mkRel 2)|]))|])));
+      lambda_create env
+        (mkApp (eq, [|(mkRel 5);(mkRel 3)|]),
+        (mkApp (trans,
+          [|(mkRel 7);(mkRel 6);(mkRel 5);(mkRel 3);
+            (mkApp (trans,
+              [|(mkRel 6);(mkRel 4);(mkRel 5);(mkRel 1);
+                (mkApp (sym, [|(mkRel 5);(mkRel 4);(mkRel 2)|]))|]))|])))|])
+  in
+  let p = it_mkLambda_or_LetIn body sign in
+  let t = it_mkProd_or_LetIn ccl sign in
+  (p,t)
+
+let gen_eq_lem_name =
+  let i = ref 0 in
+    function () -> 
+      incr i;
+      make_ident "setoid_eq_ext" (Some !i)
+
+let add_setoid a aeq th =
+  if setoid_table_mem a 
+  then errorlabstrm "Add Setoid"
+    (str "A Setoid Theory is already declared for " ++ prterm a)
+  else let env = Global.env () in
+    if (is_conv env Evd.empty (Typing.type_of env Evd.empty th)
+	  (mkApp ((Lazy.force coq_Setoid_Theory), [| a; aeq |])))
+    then (Lib.add_anonymous_leaf 
+	    (setoid_to_obj 
+	       (a, { set_a = a;
+		     set_aeq = aeq;
+		     set_th = th}));
+	  let sym = mkApp ((Lazy.force coq_seq_sym), [|a; aeq; th|]) in
+	  let trans = mkApp ((Lazy.force coq_seq_trans), [|a; aeq; th|]) in
+	  let (eq_morph, eq_morph_typ) = eq_lem_proof env a aeq sym trans in
+	  let (eq_morph2, eq_morph2_typ) = eq_lem2_proof env a aeq sym trans in
+	    Options.if_verbose ppnl (prterm a ++str " is registered as a setoid");
+	    let eq_ext_name = gen_eq_lem_name () in 
+	    let eq_ext_name2 = gen_eq_lem_name () in 
+	    let _ = Declare.declare_constant eq_ext_name
+		      ((DefinitionEntry {const_entry_body = eq_morph; 
+		                       const_entry_type = Some eq_morph_typ;
+                                       const_entry_opaque = true}),
+		       IsProof Lemma) in
+	    let _ = Declare.declare_constant eq_ext_name2
+		      ((DefinitionEntry {const_entry_body = eq_morph2; 
+				       const_entry_type = Some eq_morph2_typ;
+                                       const_entry_opaque = true}),
+		       IsProof Lemma) in
+	    let eqmorph = (current_constant eq_ext_name) in
+	    let eqmorph2 = (current_constant eq_ext_name2) in
+	      (Lib.add_anonymous_leaf
+		 (morphism_to_obj (aeq, 
+				   { lem = eqmorph;
+				     profil = [true; true];
+				     arg_types = [a;a];
+				     lem2 = (Some eqmorph2)})));
+	      Options.if_verbose ppnl (prterm aeq ++str " is registered as a morphism"))
+    else errorlabstrm "Add Setoid" (str "Not a valid setoid theory")
+
+(* The vernac command "Add Setoid" *)
+let add_setoid a aeq th =
+  add_setoid (constr_of a) (constr_of aeq) (constr_of th)
+
+(***************** Adding a morphism to the database ****************************)
+
+(* We maintain a table of the currently edited proofs of morphism lemma
+   in order to add them in the morphism_table when the user does Save *)
+
+let edited = ref Gmap.empty
+
+let new_edited id m profil = 
+  edited := Gmap.add id (m,profil)  !edited
+
+let is_edited id =
+  Gmap.mem id !edited
+
+let no_more_edited id =
+  edited := Gmap.remove id !edited
+
+let what_edited id =
+  Gmap.find id !edited
+
+let check_is_dependent t n =
+  let rec aux t i n =
+    if (i<n)
+    then (dependent (mkRel i) t) || (aux t (i+1) n)
+    else false
+  in aux t 0 n
+
+let gen_lem_name m = match kind_of_term m with 
+  | Var id -> add_suffix id "_ext"
+  | Const kn -> add_suffix (id_of_label (label kn)) "_ext"
+  | Ind (kn, i) -> add_suffix (id_of_label (label kn)) ((string_of_int i)^"_ext")
+  | Construct ((kn,i),j) -> add_suffix
+      (id_of_label (label kn)) ((string_of_int i)^(string_of_int j)^"_ext")
+  | _ -> errorlabstrm "New Morphism" (str "The term " ++ prterm m ++ str "is not a known name")
+
+let gen_lemma_tail m lisset body n =
+  let l = (List.length lisset) in
+  let a1 = Array.create l (mkRel 0) in
+  let a2 = Array.create l (mkRel 0) in
+  let rec aux i n = function
+    | true::q -> 
+	a1.(i) <- (mkRel n);
+	a2.(i) <- (mkRel (n-1));
+	aux (i+1) (n-2) q
+    | false::q ->
+	a1.(i) <- (mkRel n);
+	a2.(i) <- (mkRel n);
+	aux (i+1) (n-1) q
+    | [] -> () in 
+    aux 0 n lisset;
+    if (eq_constr body mkProp)
+    then mkArrow (mkApp (m,a1)) (lift 1 (mkApp (m, a2)))
+    else if (setoid_table_mem body)
+    then mkApp ((setoid_table_find body).set_aeq, [|(mkApp (m, a1)); (mkApp (m, a2))|])
+    else mkApp ((Lazy.force coqeq), [|body; (mkApp (m, a1)); (mkApp (m, a2))|])
+
+let gen_lemma_middle m larg lisset body n =
+  let rec aux la li i n = match (la, li) with
+    | ([], []) -> gen_lemma_tail m lisset body n
+    | (t::q, true::lq) -> 
+	mkArrow (mkApp ((setoid_table_find t).set_aeq, 
+			[|(mkRel i); (mkRel (i-1))|])) (aux q lq (i-1) (n+1))
+    | (t::q, false::lq) -> aux q lq (i-1) n
+    | _ -> assert false
+  in aux larg lisset n n
+
+let gen_compat_lemma env m body larg lisset = 
+  let rec aux la li n = match (la, li) with
+    | (t::q, true::lq) -> 
+	prod_create env (t,(prod_create env (t, (aux q lq (n+2)))))
+    | (t::q, false::lq) -> 
+	prod_create env (t, (aux q lq (n+1)))
+    | ([],[]) -> gen_lemma_middle m larg lisset body n
+    | _ -> assert false
+  in aux larg lisset 0
+
+let new_morphism m id hook =
+  if morphism_table_mem m
+  then errorlabstrm "New Morphism"
+    (str "The term " ++ prterm m ++ str " is already declared as a morphism")
+  else 
+    let env = Global.env() in
+    let typeofm = (Typing.type_of env Evd.empty m) in
+    let typ = (nf_betaiota typeofm) in  (* nf_bdi avant, mais bug *)
+    let (argsrev, body) = (decompose_prod typ) in
+    let args = (List.rev argsrev) in
+      if (args=[])
+      then errorlabstrm "New Morphism"
+	(str "The term " ++ prterm m ++ str " is not a product")
+      else if (check_is_dependent typ (List.length args))
+      then  errorlabstrm "New Morphism"
+	(str "The term " ++ prterm m ++ str " should not be a dependent product")
+      else (
+	let args_t = (List.map snd args) in
+	let poss = (List.map setoid_table_mem args_t) in
+	let lem = (gen_compat_lemma env m body args_t poss) in
+	new_edited id m poss;
+	Pfedit.start_proof id (IsGlobal (Proof Lemma)) 
+	  (Declare.clear_proofs (Global.named_context ()))
+	  lem hook;
+	(Options.if_verbose msg (Pfedit.pr_open_subgoals ())))
+
+let rec sub_bool l1 n = function
+  | [] -> []
+  | true::q -> ((List.hd l1), n)::(sub_bool (List.tl l1) (n-2) q)
+  | false::q -> (sub_bool (List.tl l1) (n-1) q)
+
+let gen_lemma_iff_tail m mext larg lisset n k =
+  let a1 = Array.create k (mkRel 0) in
+  let a2 = Array.create k (mkRel 0) in
+  let nb = List.length lisset in
+  let b1 = Array.create nb (mkRel 0) in
+  let b2 = Array.create nb (mkRel 0) in
+  let rec aux i j = function
+    |[] -> ()
+    |true::q ->
+       (a1.(i) <- (mkRel j);
+	a1.(i+1) <- (mkRel (j-1));
+	a2.(i) <- (mkRel (j-1));
+	a2.(i+1) <- (mkRel j);
+	aux (i+2) (j-2) q)
+    |false::q ->
+       (a1.(i) <- (mkRel j);
+	a2.(i) <- (mkRel j);
+	aux (i+1) (j-1) q) in
+  let rec aux2 i j = function
+    | (t,p)::q -> 
+	let th = (setoid_table_find t).set_th
+	and equiv = (setoid_table_find t).set_aeq in
+	  a1.(i) <- (mkRel j);
+	  a2.(i) <- mkApp ((Lazy.force coq_seq_sym),
+			   [|t; equiv; th; (mkRel p); (mkRel (p-1)); (mkRel j)|]);
+	  aux2 (i+1) (j-1) q
+    | [] -> () in
+  let rec aux3 i j = function
+    | true::q -> 
+	b1.(i) <- (mkRel j);
+	b2.(i) <- (mkRel (j-1));
+	aux3 (i+1) (j-2) q
+    | false::q ->
+	b1.(i) <- (mkRel j);
+	b2.(i) <- (mkRel j);
+	aux3 (i+1) (j-1) q
+    | [] -> () in 
+    aux 0 k lisset;
+    aux2 n (k-n) (sub_bool larg k lisset);
+    aux3 0 k lisset;
+    mkApp ((Lazy.force coqconj),
+	   [|(mkArrow (mkApp (m,b1)) (lift 1 (mkApp (m, b2))));
+	     (mkArrow (mkApp (m,b2)) (lift 1 (mkApp (m, b1))));
+	     (mkApp (mext, a1));(mkApp (mext, a2))|])
+
+let gen_lemma_iff_middle env m mext larg lisset n =
+  let rec aux la li i k = match (la, li) with
+    | ([], []) -> gen_lemma_iff_tail m mext larg lisset n k
+    | (t::q, true::lq) -> 
+	lambda_create env ((mkApp ((setoid_table_find t).set_aeq, [|(mkRel i); (mkRel (i-1))|])),
+			   (aux q lq (i-1) (k+1)))
+    | (t::q, false::lq) -> aux q lq (i-1) k
+    | _ -> assert false
+  in aux larg lisset n n
+
+let gen_lem_iff env m mext larg lisset =
+  let rec aux la li n = match (la, li) with
+    | (t::q, true::lq) -> 
+	lambda_create env (t,(lambda_create env (t, (aux q lq (n+2)))))
+    | (t::q, false::lq) -> 
+	lambda_create env (t, (aux q lq (n+1)))
+    | ([],[]) -> gen_lemma_iff_middle env m mext larg lisset n
+    | _ -> assert false
+  in aux larg lisset 0
+
+let add_morphism lem_name (m,profil) =
+  if morphism_table_mem m
+  then errorlabstrm "New Morphism"
+    (str "The term " ++ prterm m ++ str " is already declared as a morpism")
+  else 
+    let env = Global.env() in
+    let mext = (current_constant lem_name) in
+    let typeofm = (Typing.type_of env Evd.empty m) in
+    let typ = (nf_betaiota typeofm) in
+    let (argsrev, body) = (decompose_prod typ) in
+    let args = List.rev argsrev in
+    let args_t = (List.map snd args) in
+    let poss = (List.map setoid_table_mem args_t) in
+    let _ = assert (poss=profil) in
+      (if (eq_constr body mkProp)
+       then
+	 (let lem_2 = gen_lem_iff env m mext args_t poss in
+	  let lem2_name = add_suffix lem_name "2" in
+	  let _ = Declare.declare_constant lem2_name
+		    ((DefinitionEntry {const_entry_body = lem_2; 
+				     const_entry_type = None;
+                                     const_entry_opaque = true}),
+		     IsProof Lemma) in
+	  let lem2 = (current_constant lem2_name) in
+	    (Lib.add_anonymous_leaf
+	       (morphism_to_obj (m, 
+				 { lem = mext;
+				   profil = poss;
+				   arg_types = args_t;
+				   lem2 = (Some lem2)})));
+	    Options.if_verbose message ((string_of_id lem2_name) ^ " is defined"))
+       else
+	 (Lib.add_anonymous_leaf
+	    (morphism_to_obj (m, 
+			      { lem = mext;
+				profil = poss;
+				arg_types = args_t;
+				lem2 = None}))));
+      Options.if_verbose ppnl (prterm m ++str " is registered as a morphism")   
+let morphism_hook stre ref =
+  let pf_id = id_of_global ref in
+  if (is_edited pf_id)
+  then 
+    (add_morphism pf_id (what_edited pf_id); no_more_edited pf_id)
+
+let new_named_morphism id m = new_morphism (constr_of m) id morphism_hook
+
+(****************************** The tactic itself *******************************)
+
+type constr_with_marks =
+  | MApp of constr_with_marks array 
+  | Toreplace
+  | Tokeep
+  | Mimp of constr_with_marks * constr_with_marks
+
+let is_to_replace = function
+  | Tokeep -> false
+  | Toreplace -> true
+  | MApp _ -> true
+  | Mimp _ -> true
+
+let get_mark a = 
+  Array.fold_left (||) false (Array.map is_to_replace a)
+
+let rec mark_occur t in_c =
+  if (eq_constr t in_c) then Toreplace else
+    match kind_of_term in_c with
+      | App (c,al) -> 
+	  let a = Array.map (mark_occur t) al
+	  in if (get_mark a) then (MApp a) else Tokeep
+      | Prod (_, c1, c2) -> 
+	  if (dependent (mkRel 1) c2)
+	  then Tokeep
+	  else 
+	    let c1m = mark_occur t c1 in
+	    let c2m = mark_occur t c2 in
+	      if ((is_to_replace c1m)||(is_to_replace c2m))
+	      then (Mimp (c1m, c2m))
+	      else Tokeep
+      | _ -> Tokeep
+
+let create_args ca ma bl c1 c2 = 
+  let rec aux i = function
+    | [] -> []
+    | true::q -> 
+	if (is_to_replace ma.(i)) 
+	then (replace_term c1 c2 ca.(i))::ca.(i)::(aux (i+1) q)
+	else ca.(i)::ca.(i)::(aux (i+1) q)
+    | false::q -> ca.(i)::(aux (i+1) q)
+  in
+    aux 0 bl
+
+
+let res_tac c a hyp =
+  let sa = setoid_table_find a in
+  let fin = match hyp with
+    | None -> Auto.full_trivial
+    | Some h -> 
+	tclORELSE (tclTHEN (tclTRY (apply h)) (tclFAIL 0 "")) 
+	(tclORELSE (tclTHEN (tclTRY (tclTHEN (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|]))) (apply h))) (tclFAIL 0 ""))
+	   Auto.full_trivial) in
+    tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th;c|])))) (tclFAIL 0 ""))
+      (tclORELSE assumption
+	 (tclORELSE (tclTHEN (tclTRY (apply (mkApp ((Lazy.force coq_seq_sym), [|sa.set_a; sa.set_aeq; sa.set_th|])))) assumption)
+	    fin))
+
+let id_res_tac c a = 
+  let sa = setoid_table_find a in
+    (tclTRY (apply (mkApp ((Lazy.force coq_seq_refl), [|sa.set_a; sa.set_aeq; sa.set_th; c|]))))
+
+(* An exception to catchs errors *)
+
+exception Nothing_found of constr;;
+
+let rec create_tac_list i a al c1 c2 hyp args_t = function
+  | [] -> []
+  | false::q -> create_tac_list (i+1) a al c1 c2 hyp args_t q
+  | true::q -> 
+      if (is_to_replace a.(i))
+      then (zapply false al.(i) a.(i) c1 c2 hyp)::(create_tac_list (i+1) a al c1 c2 hyp args_t q)
+      else (id_res_tac al.(i) (List.nth args_t i))::(create_tac_list (i+1) a al c1 c2 hyp args_t q)
+(*      else tclIDTAC::(create_tac_list (i+1) a al c1 c2 hyp q) *)
+
+and zapply is_r gl gl_m c1 c2 hyp glll = (match ((kind_of_term gl), gl_m) with
+  | ((App (c,al)),(MApp a)) -> (
+      try 
+	let m = morphism_table_find c in
+	let args = Array.of_list (create_args al a m.profil c1 c2) in
+	  if is_r
+	  then tclTHENS (apply (mkApp (m.lem, args)))
+	    ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC])
+ 	  else (match m.lem2 with
+		  | None -> 
+		      tclTHENS (apply (mkApp (m.lem, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)
+		  | Some xom -> 
+		      tclTHENS (apply (mkApp (xom, args))) (create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil))
+      with Not_found -> errorlabstrm "Setoid_replace" 
+	  (str "The term " ++ prterm c ++ str " has not been declared as a morphism"))
+  | ((Prod (_,hh, cc)),(Mimp (hhm, ccm))) ->
+      let al = [|hh; cc|] in
+      let a = [|hhm; ccm|] in
+      let fleche_constr = (Lazy.force coq_fleche) in
+      let fleche_cp = destConst fleche_constr in
+      let new_concl = (mkApp (fleche_constr, al)) in
+	if is_r 
+	then
+	  let m = morphism_table_find fleche_constr in
+	  let args = Array.of_list (create_args al a m.profil c1 c2) in  
+	    tclTHEN (change_in_concl None new_concl)
+	      (tclTHENS (apply (mkApp (m.lem, args)))
+		 ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[unfold_constr (ConstRef fleche_cp)]))
+(*		 ((create_tac_list 0 a al c1 c2 hyp m.arg_types m.profil)@[tclIDTAC])) *)
+	else (zapply is_r new_concl (MApp a) c1 c2 hyp)
+(*      let args = Array.of_list (create_args [|hh; cc|] [|hhm; ccm|] [true;true] c1 c2) in
+	if is_r
+	then tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext), args)))
+	  ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC])
+	else tclTHENS (apply (mkApp ((Lazy.force coq_fleche_ext2), args)))
+	  ((create_tac_list 0 [|hhm; ccm|] [|hh; cc|] c1 c2 hyp [mkProp; mkProp] [true;true])@[tclIDTAC])
+*)
+  | (_, Toreplace) -> 
+      if is_r 
+      then (match hyp with
+	      | None -> errorlabstrm "Setoid_replace"
+		  (str "You should use the tactic Replace here")
+	      | Some h ->
+		  let hypt = pf_type_of glll h in
+		  let (heq, hargs) = decompose_app hypt in
+		  let rec get_last_two = function
+		    | [c1;c2] -> (c1, c2)
+		    | x::y::z -> get_last_two (y::z)
+		    | _ -> assert false in
+		  let (hc1,hc2) = get_last_two hargs in
+		    if c1 = hc1
+		    then 				     
+		      apply (mkApp (Lazy.force coqproj2,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|]))
+		    else 
+		      apply (mkApp (Lazy.force coqproj1,[|(mkArrow hc1 hc2);(mkArrow hc2 hc1);h|]))
+	   )
+      else (res_tac gl (pf_type_of glll gl) hyp) (* tclORELSE Auto.full_trivial tclIDTAC *)
+  | (_, Tokeep) -> (match hyp with 
+		      | None -> errorlabstrm "Setoid_replace"
+			  (str "No replacable occurence of " ++ prterm c1 ++ str " found")
+		      | Some _ ->errorlabstrm "Setoid_replace"
+			  (str "No rewritable occurence of " ++ prterm c1 ++ str " found"))
+  | _ -> anomaly ("Bug in Setoid_replace")) glll
+
+let setoid_replace c1 c2 hyp gl =
+  let but = (pf_concl gl) in
+    (zapply true but (mark_occur c1 but) c1 c2 hyp) gl
+
+let general_s_rewrite lft2rgt c gl =
+  let ctype = pf_type_of gl c in
+  let (equiv, args) = decompose_app ctype in
+  let rec get_last_two = function
+    | [c1;c2] -> (c1, c2)
+    | x::y::z -> get_last_two (y::z)
+    | _ -> error "The term provided is not an equivalence" in 
+  let (c1,c2) = get_last_two args in
+    if lft2rgt
+    then setoid_replace c1 c2 (Some c) gl
+    else setoid_replace c2 c1 (Some c) gl
+
+let setoid_rewriteLR = general_s_rewrite true
+
+let setoid_rewriteRL = general_s_rewrite false
diff --git a/tactics/setoid_replace.mli b/tactics/setoid_replace.mli
new file mode 100644
index 00000000..565ae169
--- /dev/null
+++ b/tactics/setoid_replace.mli
@@ -0,0 +1,27 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: setoid_replace.mli,v 1.3.6.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Term
+open Proof_type
+open Topconstr
+
+val equiv_list : unit -> constr list
+
+val setoid_replace : constr -> constr -> constr option -> tactic
+
+val setoid_rewriteLR : constr -> tactic
+
+val setoid_rewriteRL : constr -> tactic
+
+val general_s_rewrite : bool -> constr -> tactic
+
+val add_setoid : constr_expr -> constr_expr -> constr_expr -> unit
+
+val new_named_morphism : Names.identifier -> constr_expr -> unit
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
new file mode 100644
index 00000000..2080b5dc
--- /dev/null
+++ b/tactics/tacinterp.ml
@@ -0,0 +1,2236 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tacinterp.ml,v 1.84.2.4 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Constrintern
+open Closure
+open RedFlags
+open Declarations
+open Entries
+open Dyn
+open Libobject
+open Pattern
+open Matching
+open Pp
+open Rawterm
+open Sign
+open Tacred
+open Util
+open Names
+open Nameops
+open Libnames
+open Nametab
+open Pfedit
+open Proof_type
+open Refiner
+open Tacmach
+open Tactic_debug
+open Topconstr
+open Ast
+open Term
+open Termops
+open Tacexpr
+open Safe_typing
+open Typing
+open Hiddentac
+open Genarg
+open Decl_kinds
+
+let strip_meta id = (* For Grammar v7 compatibility *)
+  let s = string_of_id id in
+  if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
+  else id
+
+let error_syntactic_metavariables_not_allowed loc =
+  user_err_loc 
+    (loc,"out_ident",
+     str "Syntactic metavariables allowed only in quotations")
+
+let skip_metaid = function
+  | AI x -> x
+  | MetaId (loc,_) -> error_syntactic_metavariables_not_allowed loc
+
+type ltac_type =
+  | LtacFun of ltac_type
+  | LtacBasic
+  | LtacTactic
+
+(* Values for interpretation *)
+type value =
+  | VTactic of loc * tactic  (* For mixed ML/Ltac tactics (e.g. Tauto) *)
+  | VRTactic of (goal list sigma * validation) (* For Match results *)
+                                               (* Not a true value *)
+  | VFun of (identifier*value) list * identifier option list * glob_tactic_expr
+  | VVoid
+  | VInteger of int
+  | VIntroPattern of intro_pattern_expr (* includes idents which are not *)
+                        (* bound as in "Intro H" but which may be bound *)
+                        (* later, as in "tac" in "Intro H; tac" *)
+  | VConstr of constr   (* includes idents known bound and references *)
+  | VConstr_context of constr
+  | VRec of value ref
+
+let locate_tactic_call loc = function
+  | VTactic (_,t) -> VTactic (loc,t)
+  | v -> v
+
+let locate_error_in_file dir = function
+  | Stdpp.Exc_located (loc,e) -> Error_in_file ("",(true,dir,loc),e)
+  | e -> Error_in_file ("",(true,dir,dummy_loc),e)
+
+let catch_error loc tac g =
+  try tac g
+  with e when loc <> dummy_loc ->
+    match e with
+      |	Stdpp.Exc_located (_,e) -> raise (Stdpp.Exc_located (loc,e))
+      |	e -> raise (Stdpp.Exc_located (loc,e))
+
+(* Signature for interpretation: val_interp and interpretation functions *)
+type interp_sign =
+  { lfun : (identifier * value) list;
+    debug : debug_info }
+
+let check_is_value = function
+  | VRTactic _ -> (* These are goals produced by Match *)
+   error "Immediate match producing tactics not allowed in local definitions"
+  | _ -> ()
+
+(* For tactic_of_value *)
+exception NotTactic
+
+(* Gives the constr corresponding to a Constr_context tactic_arg *)
+let constr_of_VConstr_context = function
+  | VConstr_context c -> c
+  | _ ->
+    errorlabstrm "constr_of_VConstr_context" (str "not a context variable")
+
+(* Displays a value *)
+let pr_value env = function
+  | VVoid -> str "()"
+  | VInteger n -> int n
+  | VIntroPattern ipat -> pr_intro_pattern ipat
+  | VConstr c -> Printer.prterm_env env c
+  | VConstr_context c -> Printer.prterm_env env c
+  | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "<fun>"
+
+(* Transforms a named_context into a (string * constr) list *)
+let make_hyps = List.map (fun (id,_,typ) -> (id, typ))
+
+(* Transforms an id into a constr if possible, or fails *)
+let constr_of_id env id = 
+  construct_reference (Environ.named_context env) id
+
+(* To embed several objects in Coqast.t *)
+let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t),
+     (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) =
+  create "tactic"
+
+let ((value_in : value -> Dyn.t),
+     (value_out : Dyn.t -> value)) = create "value"
+
+let tacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
+let tacticOut = function
+  | TacArg (TacDynamic (_,d)) ->
+    if (tag d) = "tactic" then
+      tactic_out d
+    else
+      anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
+  | ast ->
+    anomalylabstrm "tacticOut"
+      (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
+
+let valueIn t = TacDynamic (dummy_loc,value_in t)
+let valueOut = function
+  | TacDynamic (_,d) ->
+    if (tag d) = "value" then
+      value_out d
+    else
+      anomalylabstrm "valueOut" (str "Dynamic tag should be value")
+  | ast ->
+    anomalylabstrm "valueOut" (str "Not a Dynamic ast: ")
+
+(* To embed constr in Coqast.t *)
+let constrIn t = CDynamic (dummy_loc,Pretyping.constr_in t)
+let constrOut = function
+  | CDynamic (_,d) ->
+    if (Dyn.tag d) = "constr" then
+      Pretyping.constr_out d
+    else
+      anomalylabstrm "constrOut" (str "Dynamic tag should be constr")
+  | ast ->
+    anomalylabstrm "constrOut" (str "Not a Dynamic ast")
+let loc = dummy_loc
+
+(* Table of interpretation functions *)
+let interp_tab =
+  (Hashtbl.create 17 : (string , interp_sign -> Coqast.t -> value) Hashtbl.t)
+
+(* Adds an interpretation function *)
+let interp_add (ast_typ,interp_fun) =
+  try
+    Hashtbl.add interp_tab ast_typ interp_fun
+  with
+      Failure _ ->
+        errorlabstrm "interp_add"
+          (str "Cannot add the interpretation function for " ++ str ast_typ ++            str " twice")
+
+(* Adds a possible existing interpretation function *)
+let overwriting_interp_add (ast_typ,interp_fun) =
+  if Hashtbl.mem interp_tab ast_typ then
+  begin
+    Hashtbl.remove interp_tab ast_typ;
+    warning ("Overwriting definition of tactic interpreter command " ^ ast_typ)
+  end;
+  Hashtbl.add interp_tab ast_typ interp_fun
+
+(* Finds the interpretation function corresponding to a given ast type *)
+let look_for_interp = Hashtbl.find interp_tab
+
+(* Globalizes the identifier *)
+
+let find_reference env qid =
+  (* We first look for a variable of the current proof *)
+  match repr_qualid qid with
+    | (d,id) when repr_dirpath d = [] & List.mem id (ids_of_context env)
+	-> VarRef id
+    | _ -> Nametab.locate qid
+
+let coerce_to_reference env = function
+  | VConstr c ->
+      (try reference_of_constr c
+      with Not_found -> invalid_arg_loc (loc, "Not a reference"))
+  | v -> errorlabstrm "coerce_to_reference"
+      (str "The value" ++ spc () ++ pr_value env v ++ 
+       str "cannot be coerced to a reference")
+
+(* turns a value into an evaluable reference *)
+let error_not_evaluable s =
+  errorlabstrm "evalref_of_ref" 
+    (str "Cannot coerce" ++ spc ()  ++ s ++ spc () ++
+     str "to an evaluable reference")
+
+let coerce_to_evaluable_ref env c =
+  let ev = match c with
+    | VConstr c when isConst c -> EvalConstRef (destConst c)
+    | VConstr c when isVar c -> EvalVarRef (destVar c)
+    | VIntroPattern (IntroIdentifier id)
+        when Environ.evaluable_named id env -> EvalVarRef id
+    | _ -> error_not_evaluable (pr_value env c)
+  in
+  if not (Tacred.is_evaluable env ev) then
+    error_not_evaluable (pr_value env c);
+  ev
+
+let coerce_to_inductive = function
+  | VConstr c when isInd c -> destInd c
+  | x ->
+      try
+	let r = match x with
+	  | VConstr c -> reference_of_constr c
+	  | _ -> failwith "" in
+	errorlabstrm "coerce_to_inductive"
+          (Printer.pr_global r ++ str " is not an inductive type")
+      with _ ->
+	errorlabstrm "coerce_to_inductive"
+          (str "Found an argument which should be an inductive type")
+
+
+(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *)
+let atomic_mactab = ref Idmap.empty
+let add_primitive_tactic s tac =
+  (if not !Options.v7 then
+    let id = id_of_string s in
+    atomic_mactab := Idmap.add id tac !atomic_mactab)
+
+let _ =
+  if not !Options.v7 then
+    (let nocl = {onhyps=Some[];onconcl=true; concl_occs=[]} in
+    List.iter
+      (fun (s,t) -> add_primitive_tactic s (TacAtom(dummy_loc,t)))
+      [ "red", TacReduce(Red false,nocl);
+        "hnf", TacReduce(Hnf,nocl);
+        "simpl", TacReduce(Simpl None,nocl);
+        "compute", TacReduce(Cbv all_flags,nocl);
+        "intro", TacIntroMove(None,None);
+        "intros", TacIntroPattern [];
+        "assumption", TacAssumption;
+        "cofix", TacCofix None;
+        "trivial", TacTrivial None;
+        "auto", TacAuto(None,None);
+        "left", TacLeft NoBindings;
+        "right", TacRight NoBindings;
+        "split", TacSplit(false,NoBindings);
+        "constructor", TacAnyConstructor None;
+        "reflexivity", TacReflexivity;
+        "symmetry", TacSymmetry nocl
+      ];
+    List.iter
+      (fun (s,t) -> add_primitive_tactic s t)
+      [ "idtac",TacId "";
+        "fail", TacFail(ArgArg 0,"");
+        "fresh", TacArg(TacFreshId None)
+      ])
+ 
+let lookup_atomic id = Idmap.find id !atomic_mactab
+let is_atomic id = Idmap.mem id !atomic_mactab
+let is_atomic_kn kn =
+  let (_,_,l) = repr_kn kn in
+  is_atomic (id_of_label l)
+
+(* Summary and Object declaration *)
+let mactab = ref Gmap.empty
+
+let lookup r = Gmap.find r !mactab
+
+let _ =
+  let init () = mactab := Gmap.empty in
+  let freeze () = !mactab in
+  let unfreeze fs = mactab := fs in
+  Summary.declare_summary "tactic-definition"
+    { Summary.freeze_function   = freeze;
+      Summary.unfreeze_function = unfreeze;
+      Summary.init_function     = init;
+      Summary.survive_module = false;
+      Summary.survive_section   = false }
+
+(* Interpretation of extra generic arguments *)
+type glob_sign = {
+  ltacvars : identifier list * identifier list;
+     (* ltac variables and the subset of vars introduced by Intro/Let/... *)
+  ltacrecvars : (identifier * ltac_constant) list;
+     (* ltac recursive names *)
+  gsigma : Evd.evar_map;
+  genv : Environ.env }
+
+type interp_genarg_type =
+  (glob_sign -> raw_generic_argument -> glob_generic_argument) *
+  (interp_sign -> goal sigma -> glob_generic_argument -> 
+    closed_generic_argument) *
+  (Names.substitution -> glob_generic_argument -> glob_generic_argument)
+
+let extragenargtab =
+  ref (Gmap.empty : (string,interp_genarg_type) Gmap.t)
+let add_interp_genarg id f =
+  extragenargtab := Gmap.add id f !extragenargtab
+let lookup_genarg id = 
+  try Gmap.find id !extragenargtab
+  with Not_found -> failwith ("No interpretation function found for entry "^id)
+
+let lookup_genarg_glob   id = let (f,_,_) = lookup_genarg id in f
+let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
+let lookup_genarg_subst  id = let (_,_,f) = lookup_genarg id in f
+
+(* Unboxes VRec *)
+let unrec = function
+  | VRec v -> !v
+  | a -> a
+
+(*****************)
+(* Globalization *)
+(*****************)
+
+(* We have identifier <| global_reference <| constr *)
+
+let find_ident id sign = 
+  List.mem id (fst sign.ltacvars) or 
+  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+
+let find_recvar qid sign = List.assoc qid sign.ltacrecvars
+
+(* a "var" is a ltac var or a var introduced by an intro tactic *)
+let find_var id sign = List.mem id (fst sign.ltacvars)
+
+(* a "ctxvar" is a var introduced by an intro tactic (Intro/LetTac/...) *)
+let find_ctxvar id sign = List.mem id (snd sign.ltacvars)
+
+(* a "ltacvar" is an ltac var (Let-In/Fun/...) *)
+let find_ltacvar id sign = find_var id sign & not (find_ctxvar id sign)
+
+let find_hyp id sign =
+  List.mem id (ids_of_named_context (Environ.named_context sign.genv))
+
+(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *)
+(* be fresh in which case it is binding later on *)
+let intern_ident l ist id =
+  (* We use identifier both for variables and new names; thus nothing to do *)
+  if not (find_ident id ist) then l:=(id::fst !l,id::snd !l);
+  id
+
+let intern_name l ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (intern_ident l ist id)
+
+let vars_of_ist (lfun,_,_,env) =
+  List.fold_left (fun s id -> Idset.add id s)
+    (vars_of_env env) lfun
+
+let get_current_context () =
+    try Pfedit.get_current_goal_context ()
+    with e when Logic.catchable_exception e -> 
+      (Evd.empty, Global.env())
+
+let strict_check = ref false
+
+let adjust_loc loc = if !strict_check then dummy_loc else loc
+
+(* Globalize a name which must be bound -- actually just check it is bound *)
+let intern_hyp ist (loc,id as locid) =
+  let (_,env) = get_current_context () in
+  if not !strict_check then
+    locid
+  else if find_ident id ist then
+    (dummy_loc,id)
+  else
+    Pretype_errors.error_var_not_found_loc loc id
+
+let intern_hyp_or_metaid ist id = intern_hyp ist (skip_metaid id)
+
+let intern_int_or_var ist = function
+  | ArgVar locid as x -> ArgVar (intern_hyp ist locid)
+  | ArgArg n as x -> x
+
+let intern_inductive ist = function
+  | Ident (loc,id) when find_var id ist -> ArgVar (loc,id)
+  | r -> ArgArg (Nametab.global_inductive r)
+
+exception NotSyntacticRef
+
+let locate_reference qid =
+  match Nametab.extended_locate qid with
+    | TrueGlobal ref -> ref
+    | SyntacticDef kn -> 
+	match Syntax_def.search_syntactic_definition loc kn with
+	  | Rawterm.RRef (_,ref) -> ref
+	  | _ -> raise NotSyntacticRef
+
+let intern_global_reference ist = function
+  | Ident (loc,id) as r when find_var id ist -> ArgVar (loc,id)
+  | r -> 
+      let loc,qid = qualid_of_reference r in
+      try ArgArg (loc,locate_reference qid)
+      with _ -> 
+	error_global_not_found_loc loc qid
+
+let intern_tac_ref ist = function
+  | Ident (loc,id) when find_ltacvar id ist -> ArgVar (loc,id)
+  | Ident (loc,id) ->
+      ArgArg (loc,
+         try find_recvar id ist 
+         with Not_found -> locate_tactic (make_short_qualid id))
+  | r -> 
+      let (loc,qid) = qualid_of_reference r in
+      ArgArg (loc,locate_tactic qid)
+
+let intern_tactic_reference ist r =
+  try intern_tac_ref ist r
+  with Not_found -> 
+    let (loc,qid) = qualid_of_reference r in
+    error_global_not_found_loc loc qid
+
+let intern_constr_reference strict ist = function
+  | Ident (_,id) when (not strict & find_hyp id ist) or find_ctxvar id ist ->
+      RVar (loc,id), None
+  | r ->
+      let loc,qid = qualid_of_reference r in
+      RRef (loc,locate_reference qid), if strict then None else Some (CRef r)
+
+let intern_reference strict ist = function
+  | Ident (loc,id) when is_atomic id -> Tacexp (lookup_atomic id)
+  | r ->
+      (try Reference (intern_tac_ref ist r)
+      with Not_found ->
+        (try
+          ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r))
+        with Not_found ->
+          (match r with
+            | Ident (loc,id) when not strict -> 
+		IntroPattern (IntroIdentifier id)
+            | _ ->
+                let (loc,qid) = qualid_of_reference r in
+                error_global_not_found_loc loc qid)))
+
+let rec intern_intro_pattern lf ist = function
+  | IntroOrAndPattern l ->
+      IntroOrAndPattern (intern_case_intro_pattern lf ist l)
+  | IntroWildcard ->
+      IntroWildcard
+  | IntroIdentifier id ->
+      IntroIdentifier (intern_ident lf ist id)
+
+and intern_case_intro_pattern lf ist =
+  List.map (List.map (intern_intro_pattern lf ist))
+
+let intern_quantified_hypothesis ist x =
+  (* We use identifier both for variables and quantified hyps (no way to
+     statically check the existence of a quantified hyp); thus nothing to do *)
+  x
+
+let intern_constr {ltacvars=lfun; gsigma=sigma; genv=env} c =
+  let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in
+  let c' = 
+    warn (Constrintern.interp_rawconstr_gen false sigma env 
+      false (fst lfun,[])) c in
+  begin if Options.do_translate () then try
+      (* Try to infer old case and type annotations *)
+      let _ = Pretyping.understand_gen_tcc sigma env [] None c' in 
+      (* msgerrnl (str "Typage tactique OK");*)
+      ()
+    with e -> (*msgerrnl (str "Warning: can't type tactic");*) () end;
+  (c',if !strict_check then None else Some c)
+
+(* Globalize bindings *)
+let intern_binding ist (loc,b,c) =
+  (loc,intern_quantified_hypothesis ist b,intern_constr ist c)
+
+let intern_bindings ist = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l)
+
+let intern_constr_with_bindings ist (c,bl) =
+  (intern_constr ist c, intern_bindings ist bl)
+
+let intern_clause_pattern ist (l,occl) =
+  let rec check = function
+    | (hyp,l) :: rest -> (intern_hyp ist (skip_metaid hyp),l)::(check rest)
+    | [] -> []
+  in (l,check occl)
+
+  (* TODO: catch ltac vars *)
+let intern_induction_arg ist = function
+  | ElimOnConstr c -> ElimOnConstr (intern_constr ist c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent (loc,id) as x ->
+      if !strict_check then
+	(* If in a defined tactic, no intros-until *)
+	ElimOnConstr (intern_constr ist (CRef (Ident (dummy_loc,id))))
+      else
+	ElimOnIdent (loc,id)
+
+(* Globalizes a reduction expression *)
+let intern_evaluable ist = function
+  | Ident (loc,id) as r when find_ltacvar id ist -> ArgVar (loc,id)
+  | Ident (_,id) when
+      (not !strict_check & find_hyp id ist) or find_ctxvar id ist ->
+      ArgArg (EvalVarRef id, None)
+  | r ->
+      let loc,qid = qualid_of_reference r in
+      try
+	let e = match locate_reference qid with
+	  | ConstRef c -> EvalConstRef c
+	  | VarRef c -> EvalVarRef c
+	  | _ -> error_not_evaluable (pr_reference r) in
+        let short_name = match r with
+	  | Ident (loc,id) when not !strict_check -> Some (loc,id)
+	  | _ -> None in
+        ArgArg (e,short_name)
+      with
+	| NotSyntacticRef -> error_not_evaluable (pr_reference r)
+	| Not_found ->
+	match r with 
+	  | Ident (loc,id) when not !strict_check ->
+	      ArgArg (EvalVarRef id, Some (loc,id))
+	  | _ -> error_global_not_found_loc loc qid
+
+let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid)
+
+let intern_flag ist red =
+  { red with rConst = List.map (intern_evaluable ist) red.rConst }
+
+let intern_constr_occurrence ist (l,c) = (l,intern_constr ist c)
+
+let intern_redexp ist = function
+  | Unfold l -> Unfold (List.map (intern_unfold ist) l)
+  | Fold l -> Fold (List.map (intern_constr ist) l)
+  | Cbv f -> Cbv (intern_flag ist f)
+  | Lazy f -> Lazy (intern_flag ist f)
+  | Pattern l -> Pattern (List.map (intern_constr_occurrence ist) l)
+  | Simpl o -> Simpl (option_app (intern_constr_occurrence ist) o)
+  | (Red _ | Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s, intern_constr ist c)
+
+let intern_inversion_strength lf ist = function
+  | NonDepInversion (k,idl,ids) ->
+      NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl,
+      option_app (intern_intro_pattern lf ist) ids)
+  | DepInversion (k,copt,ids) ->
+      DepInversion (k, option_app (intern_constr ist) copt,
+      option_app (intern_intro_pattern lf ist) ids)
+  | InversionUsing (c,idl) ->
+      InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl)
+
+(* Interprets an hypothesis name *)
+let intern_hyp_location ist (id,occs,hl) =
+  (intern_hyp ist (skip_metaid id), occs, hl)
+
+(* Reads a pattern *)
+let intern_pattern evc env lfun = function
+  | Subterm (ido,pc) ->
+      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      ido, metas, Subterm (ido,pat)
+  | Term pc ->
+      let (metas,pat) = interp_constrpattern_gen evc env lfun pc  in
+      None, metas, Term pat
+
+let intern_constr_may_eval ist = function
+  | ConstrEval (r,c) -> ConstrEval (intern_redexp ist r,intern_constr ist c)
+  | ConstrContext (locid,c) ->
+      ConstrContext (intern_hyp ist locid,intern_constr ist c)
+  | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c)
+  | ConstrTerm c -> ConstrTerm (intern_constr ist c)
+
+(* Reads the hypotheses of a Match Context rule *)
+let rec intern_match_context_hyps evc env lfun = function
+  | (Hyp ((_,na) as locna,mp))::tl ->
+      let ido, metas1, pat = intern_pattern evc env lfun mp in
+      let lfun, metas2, hyps = intern_match_context_hyps evc env lfun tl in
+      let lfun' = name_cons na (option_cons ido lfun) in
+      lfun', metas1@metas2, Hyp (locna,pat)::hyps
+  | [] -> lfun, [], []
+
+(* Utilities *)
+let rec filter_some = function
+  | None :: l -> filter_some l
+  | Some a :: l -> a :: filter_some l
+  | [] -> []
+
+let extract_names lrc =
+  List.fold_right 
+    (fun ((loc,name),_) l ->
+      if List.mem name l then
+	user_err_loc
+	  (loc, "intern_tactic", str "This variable is bound several times");
+      name::l)
+    lrc []
+
+let extract_let_names lrc =
+  List.fold_right 
+    (fun ((loc,name),_,_) l ->
+      if List.mem name l then
+	user_err_loc
+	  (loc, "glob_tactic", str "This variable is bound several times");
+      name::l)
+    lrc []
+
+
+let clause_app f = function
+    { onhyps=None; onconcl=b;concl_occs=nl } ->
+      { onhyps=None; onconcl=b; concl_occs=nl }
+  | { onhyps=Some l; onconcl=b;concl_occs=nl } ->
+      { onhyps=Some(List.map f l); onconcl=b;concl_occs=nl}
+
+(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *)
+let rec intern_atomic lf ist x =
+  match (x:raw_atomic_tactic_expr) with 
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
+  | TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
+  | TacIntroMove (ido,ido') ->
+      TacIntroMove (option_app (intern_ident lf ist) ido,
+          option_app (intern_hyp ist) ido')
+  | TacAssumption -> TacAssumption
+  | TacExact c -> TacExact (intern_constr ist c)
+  | TacApply cb -> TacApply (intern_constr_with_bindings ist cb)
+  | TacElim (cb,cbo) ->
+      TacElim (intern_constr_with_bindings ist cb,
+               option_app (intern_constr_with_bindings ist) cbo)
+  | TacElimType c -> TacElimType (intern_constr ist c)
+  | TacCase cb -> TacCase (intern_constr_with_bindings ist cb)
+  | TacCaseType c -> TacCaseType (intern_constr ist c)
+  | TacFix (idopt,n) -> TacFix (option_app (intern_ident lf ist) idopt,n)
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (intern_ident lf ist id,n,intern_constr ist c) in
+      TacMutualFix (intern_ident lf ist id, n, List.map f l)
+  | TacCofix idopt -> TacCofix (option_app (intern_ident lf ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (intern_ident lf ist id,intern_constr ist c) in
+      TacMutualCofix (intern_ident lf ist id, List.map f l)
+  | TacCut c -> TacCut (intern_constr ist c)
+  | TacTrueCut (na,c) ->
+      TacTrueCut (intern_name lf ist na, intern_constr ist c)
+  | TacForward (b,na,c) ->
+      TacForward (b,intern_name lf ist na,intern_constr ist c)
+  | TacGeneralize cl -> TacGeneralize (List.map (intern_constr ist) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (intern_constr ist c)
+  | TacLetTac (na,c,cls) ->
+      let na = intern_name lf ist na in
+      TacLetTac (na,intern_constr ist c,
+                 (clause_app (intern_hyp_location ist) cls))
+  | TacInstantiate (n,c,cls) -> 
+      TacInstantiate (n,intern_constr ist c,
+		      (clause_app (intern_hyp_location ist) cls))
+
+  (* Automation tactics *)
+  | TacTrivial l -> TacTrivial l
+  | TacAuto (n,l) -> TacAuto (n,l)
+  | TacAutoTDB n -> TacAutoTDB n
+  | TacDestructHyp (b,id) -> TacDestructHyp(b,intern_hyp ist id)
+  | TacDestructConcl -> TacDestructConcl
+  | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
+  | TacDAuto (n,p) -> TacDAuto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction (h,ids) ->
+      TacSimpleInduction (intern_quantified_hypothesis ist h,ids)
+  | TacNewInduction (c,cbo,(ids,ids')) ->
+      TacNewInduction (intern_induction_arg ist c,
+               option_app (intern_constr_with_bindings ist) cbo,
+               (option_app (intern_intro_pattern lf ist) ids,ids'))
+  | TacSimpleDestruct h ->
+      TacSimpleDestruct (intern_quantified_hypothesis ist h)
+  | TacNewDestruct (c,cbo,(ids,ids')) ->
+      TacNewDestruct (intern_induction_arg ist c,
+               option_app (intern_constr_with_bindings ist) cbo,
+	       (option_app (intern_intro_pattern lf ist) ids,ids'))
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = intern_quantified_hypothesis ist h1 in
+      let h2 = intern_quantified_hypothesis ist h2 in
+      TacDoubleInduction (h1,h2)
+  | TacDecomposeAnd c -> TacDecomposeAnd (intern_constr ist c)
+  | TacDecomposeOr c -> TacDecomposeOr (intern_constr ist c)
+  | TacDecompose (l,c) -> let l = List.map (intern_inductive ist) l in
+      TacDecompose (l,intern_constr ist c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,intern_constr_with_bindings ist l)
+  | TacLApply c -> TacLApply (intern_constr ist c)
+
+  (* Context management *)
+  | TacClear l -> TacClear (List.map (intern_hyp_or_metaid ist) l)
+  | TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
+  | TacMove (dep,id1,id2) ->
+    TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2)
+  | TacRename (id1,id2) -> TacRename (intern_hyp_or_metaid ist id1, intern_hyp_or_metaid ist id2)
+
+  (* Constructors *)
+  | TacLeft bl -> TacLeft (intern_bindings ist bl)
+  | TacRight bl -> TacRight (intern_bindings ist bl)
+  | TacSplit (b,bl) -> TacSplit (b,intern_bindings ist bl)
+  | TacAnyConstructor t -> TacAnyConstructor (option_app (intern_tactic ist) t)
+  | TacConstructor (n,bl) -> TacConstructor (n, intern_bindings ist bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      TacReduce (intern_redexp ist r, clause_app (intern_hyp_location ist) cl)
+  | TacChange (occl,c,cl) ->
+      TacChange (option_app (intern_constr_occurrence ist) occl,
+        intern_constr ist c, clause_app (intern_hyp_location ist) cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity -> TacReflexivity
+  | TacSymmetry idopt -> 
+      TacSymmetry (clause_app (intern_hyp_location ist) idopt)
+  | TacTransitivity c -> TacTransitivity (intern_constr ist c)
+
+  (* Equality and inversion *)
+  | TacInversion (inv,hyp) ->
+      TacInversion (intern_inversion_strength lf ist inv,
+        intern_quantified_hypothesis ist hyp)
+
+  (* For extensions *)
+  | TacExtend (loc,opn,l) ->
+      let _ = lookup_tactic opn in
+      TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l)
+  | TacAlias (loc,s,l,(dir,body)) ->
+      let (l1,l2) = ist.ltacvars in
+      let ist' = { ist with ltacvars = ((List.map fst l)@l1,l2) } in
+      let l = List.map (fun (id,a) -> (strip_meta id,intern_genarg ist a)) l in
+      try TacAlias (loc,s,l,(dir,intern_tactic ist' body))
+      with e -> raise (locate_error_in_file (string_of_dirpath dir) e)
+
+and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr)
+
+and intern_tactic_seq ist = function
+  (* Traducteur v7->v8 *)
+  | TacAtom (_,TacReduce (Unfold [_,Ident (_,id)],_))
+      when string_of_id id = "INZ" & !Options.translate_syntax
+        -> ist.ltacvars, (TacId "")
+  (* Fin traducteur v7->v8 *)
+
+  | TacAtom (loc,t) ->
+      let lf = ref ist.ltacvars in
+      let t = intern_atomic lf ist t in
+      !lf, TacAtom (adjust_loc loc, t)
+  | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun)
+  | TacLetRecIn (lrc,u) ->
+      let names = extract_names lrc in
+      let (l1,l2) = ist.ltacvars in
+      let ist = { ist with ltacvars = (names@l1,l2) } in
+      let lrc = List.map (fun (n,b) -> (n,intern_tactic_fun ist b)) lrc in
+      ist.ltacvars, TacLetRecIn (lrc,intern_tactic ist u)
+  | TacLetIn (l,u) ->
+      let l = List.map
+        (fun (n,c,b) ->
+          (n,option_app (intern_tactic ist) c, intern_tacarg !strict_check ist b)) l in
+      let (l1,l2) = ist.ltacvars in
+      let ist' = { ist with ltacvars = ((extract_let_names l)@l1,l2) } in
+      ist.ltacvars, TacLetIn (l,intern_tactic ist' u)
+  | TacMatchContext (lr,lmr) ->
+      ist.ltacvars, TacMatchContext(lr, intern_match_rule ist lmr)
+  | TacMatch (c,lmr) ->
+      ist.ltacvars, TacMatch (intern_tactic ist c,intern_match_rule ist lmr)
+  | TacId _ as x -> ist.ltacvars, x
+  | TacFail (n,x) -> ist.ltacvars, TacFail (intern_int_or_var ist n,x)
+  | TacProgress tac -> ist.ltacvars, TacProgress (intern_tactic ist tac)
+  | TacAbstract (tac,s) -> ist.ltacvars, TacAbstract (intern_tactic ist tac,s)
+  | TacThen (t1,t2) ->
+      let lfun', t1 = intern_tactic_seq ist t1 in
+      let lfun'', t2 = intern_tactic_seq { ist with ltacvars = lfun' } t2 in
+      lfun'', TacThen (t1,t2)
+  | TacThens (t,tl) ->
+      let lfun', t = intern_tactic_seq ist t in
+      (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *)
+      lfun',
+      TacThens (t, List.map (intern_tactic { ist with ltacvars = lfun' }) tl)
+  | TacDo (n,tac) -> 
+      ist.ltacvars, TacDo (intern_int_or_var ist n,intern_tactic ist tac)
+  | TacTry tac -> ist.ltacvars, TacTry (intern_tactic ist tac)
+  | TacInfo tac -> ist.ltacvars, TacInfo (intern_tactic ist tac)
+  | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_tactic ist tac)
+  | TacOrelse (tac1,tac2) ->
+      ist.ltacvars, TacOrelse (intern_tactic ist tac1,intern_tactic ist tac2)
+  | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_tactic ist) l)
+  | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_tactic ist) l)
+  | TacArg a -> ist.ltacvars, TacArg (intern_tacarg true ist a)
+
+and intern_tactic_fun ist (var,body) = 
+  let (l1,l2) = ist.ltacvars in
+  let lfun' = List.rev_append (filter_some var) l1 in
+  (var,intern_tactic { ist with ltacvars = (lfun',l2) } body)
+
+and intern_tacarg strict ist = function
+  | TacVoid -> TacVoid
+  | Reference r -> intern_reference strict ist r
+  | IntroPattern ipat -> 
+      let lf = ref([],[]) in (*How to know what names the intropattern binds?*)
+      IntroPattern (intern_intro_pattern lf ist ipat)
+  | Integer n -> Integer n
+  | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c)
+  | MetaIdArg (loc,s) ->
+      (* $id can occur in Grammar tactic... *)
+      let id = id_of_string s in
+      if find_ltacvar id ist or Options.do_translate()
+      then Reference (ArgVar (adjust_loc loc,strip_meta id))
+      else error_syntactic_metavariables_not_allowed loc
+  | TacCall (loc,f,l) ->
+      TacCall (loc,
+        intern_tactic_reference ist f,
+        List.map (intern_tacarg !strict_check ist) l)
+  | TacFreshId _ as x -> x
+  | Tacexp t -> Tacexp (intern_tactic ist t)
+  | TacDynamic(loc,t) as x ->
+      (match tag t with
+	| "tactic" | "value" | "constr" -> x
+	| s -> anomaly_loc (loc, "",
+                 str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and intern_match_rule ist = function
+  | (All tc)::tl ->
+      All (intern_tactic ist tc) :: (intern_match_rule ist tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let {ltacvars=(lfun,l2); gsigma=sigma; genv=env} = ist in
+      let lfun',metas1,hyps = intern_match_context_hyps sigma env lfun rl in
+      let ido,metas2,pat = intern_pattern sigma env lfun mp in
+      let metas = list_uniquize (metas1@metas2) in
+      let ist' = { ist with ltacvars = (metas@(option_cons ido lfun'),l2) } in
+      Pat (hyps,pat,intern_tactic ist' tc) :: (intern_match_rule ist tl)
+  | [] -> []
+
+and intern_genarg ist x =
+  match genarg_tag x with
+  | BoolArgType -> in_gen globwit_bool (out_gen rawwit_bool x)
+  | IntArgType -> in_gen globwit_int (out_gen rawwit_int x)
+  | IntOrVarArgType ->
+      in_gen globwit_int_or_var
+        (intern_int_or_var ist (out_gen rawwit_int_or_var x))
+  | StringArgType ->
+      in_gen globwit_string (out_gen rawwit_string x)
+  | PreIdentArgType ->
+      in_gen globwit_pre_ident (out_gen rawwit_pre_ident x)
+  | IntroPatternArgType ->
+      let lf = ref ([],[]) in
+      (* how to know which names are bound by the intropattern *)
+      in_gen globwit_intro_pattern
+        (intern_intro_pattern lf ist (out_gen rawwit_intro_pattern x))
+  | IdentArgType ->
+      let lf = ref ([],[]) in
+      in_gen globwit_ident(intern_ident lf ist (out_gen rawwit_ident x))
+  | HypArgType ->
+      in_gen globwit_var (intern_hyp ist (out_gen rawwit_var x))
+  | RefArgType ->
+      in_gen globwit_ref (intern_global_reference ist (out_gen rawwit_ref x))
+  | SortArgType ->
+      in_gen globwit_sort (out_gen rawwit_sort x)
+  | ConstrArgType ->
+      in_gen globwit_constr (intern_constr ist (out_gen rawwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen globwit_constr_may_eval 
+        (intern_constr_may_eval ist (out_gen rawwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen globwit_quant_hyp
+        (intern_quantified_hypothesis ist (out_gen rawwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen globwit_red_expr (intern_redexp ist (out_gen rawwit_red_expr x))
+  | TacticArgType ->
+      in_gen globwit_tactic (intern_tactic ist (out_gen rawwit_tactic x))
+  | CastedOpenConstrArgType ->
+      in_gen globwit_casted_open_constr 
+        (intern_constr ist (out_gen rawwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen globwit_constr_with_bindings
+        (intern_constr_with_bindings ist (out_gen rawwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen globwit_bindings
+        (intern_bindings ist (out_gen rawwit_bindings x))
+  | List0ArgType _ -> app_list0 (intern_genarg ist) x
+  | List1ArgType _ -> app_list1 (intern_genarg ist) x
+  | OptArgType _ -> app_opt (intern_genarg ist) x
+  | PairArgType _ -> app_pair (intern_genarg ist) (intern_genarg ist) x
+  | ExtraArgType s -> lookup_genarg_glob s ist x
+
+(************* End globalization ************)
+
+(***************************************************************************)
+(* Evaluation/interpretation *)
+
+(* Associates variables with values and gives the remaining variables and
+   values *)
+let head_with_value (lvar,lval) =
+  let rec head_with_value_rec lacc = function
+    | ([],[]) -> (lacc,[],[])
+    | (vr::tvr,ve::tve) ->
+      (match vr with
+      |	None -> head_with_value_rec lacc (tvr,tve)
+      | Some v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve))
+    | (vr,[]) -> (lacc,vr,[])
+    | ([],ve) -> (lacc,[],ve)
+  in
+    head_with_value_rec [] (lvar,lval)
+
+(* Gives a context couple if there is a context identifier *)
+let give_context ctxt = function
+  | None -> []
+  | Some id -> [id,VConstr_context ctxt]
+
+(* Reads a pattern by substituing vars of lfun *)
+let eval_pattern lfun c = 
+  let lvar = List.map (fun (id,c) -> (id,pattern_of_constr c)) lfun in
+  instantiate_pattern lvar c
+
+let read_pattern evc env lfun = function
+  | Subterm (ido,pc) -> Subterm (ido,eval_pattern lfun pc)
+  | Term pc -> Term (eval_pattern lfun pc)
+
+(* Reads the hypotheses of a Match Context rule *)
+let cons_and_check_name id l =
+  if List.mem id l then
+    user_err_loc (loc,"read_match_context_hyps",
+      str ("Hypothesis pattern-matching variable "^(string_of_id id)^
+      " used twice in the same pattern"))
+  else id::l
+
+let rec read_match_context_hyps evc env lfun lidh = function
+  | (Hyp ((loc,na) as locna,mp))::tl ->
+      let lidh' = name_fold cons_and_check_name na lidh in
+      Hyp (locna,read_pattern evc env lfun mp)::
+	(read_match_context_hyps evc env lfun lidh' tl)
+  | [] -> []
+
+(* Reads the rules of a Match Context or a Match *)
+let rec read_match_rule evc env lfun = function
+  | (All tc)::tl -> (All tc)::(read_match_rule evc env lfun tl)
+  | (Pat (rl,mp,tc))::tl ->
+      Pat (read_match_context_hyps evc env lfun [] rl,
+      read_pattern evc env lfun mp,tc)
+       ::(read_match_rule evc env lfun tl)
+  | [] -> []
+
+(* For Match Context and Match *)
+exception No_match
+exception Not_coherent_metas
+exception Eval_fail of string
+
+let is_failure = function
+  | FailError _ | Stdpp.Exc_located (_,FailError _) -> true
+  | _ -> false
+
+let is_match_catchable = function
+  | No_match | Eval_fail _ -> true
+  | e -> is_failure e or Logic.catchable_exception e
+
+(* Verifies if the matched list is coherent with respect to lcm *)
+let rec verify_metas_coherence gl lcm = function
+  | (num,csr)::tl ->
+    if (List.for_all (fun (a,b) -> a<>num or pf_conv_x gl b csr) lcm) then
+      (num,csr)::(verify_metas_coherence gl lcm tl)
+    else
+      raise Not_coherent_metas
+  | [] -> []
+
+(* Tries to match a pattern and a constr *)
+let apply_matching pat csr =
+  try
+    (matches pat csr)
+  with
+     PatternMatchingFailure -> raise No_match
+
+(* Tries to match one hypothesis pattern with a list of hypotheses *)
+let apply_one_mhyp_context ist env gl lmatch (hypname,pat) (lhyps,nocc) =
+  let get_id_couple id = function
+(*    | Name idpat -> [idpat,VIdentifier id]*)
+    | Name idpat -> [idpat,VConstr (mkVar id)]
+    | Anonymous -> [] in
+  let rec apply_one_mhyp_context_rec nocc = function
+    | (id,hyp)::tl as hyps ->
+      (match pat with
+      | Term t ->
+        (try
+          let lmeta = verify_metas_coherence gl lmatch (matches t hyp) in
+          (get_id_couple id hypname,lmeta,(id,hyp),(tl,0))
+        with
+	| PatternMatchingFailure | Not_coherent_metas ->
+            apply_one_mhyp_context_rec 0 tl)
+      | Subterm (ic,t) ->
+        (try
+          let (lm,ctxt) = sub_match nocc t hyp in
+          let lmeta = verify_metas_coherence gl lmatch lm in
+          ((get_id_couple id hypname)@(give_context ctxt ic),
+	   lmeta,(id,hyp),(hyps,nocc + 1))
+         with
+         | NextOccurrence _ ->
+             apply_one_mhyp_context_rec 0 tl
+         | Not_coherent_metas ->
+             apply_one_mhyp_context_rec (nocc + 1) hyps))
+    | [] ->
+        db_hyp_pattern_failure ist.debug env (hypname,pat);
+        raise No_match
+      in
+  apply_one_mhyp_context_rec nocc lhyps
+
+let constr_to_id loc = function
+  | VConstr c when isVar c -> destVar c
+  | _ -> invalid_arg_loc (loc, "Not an identifier")
+
+let constr_to_qid loc c =
+  try shortest_qualid_of_global Idset.empty (reference_of_constr c)
+  with _ -> invalid_arg_loc (loc, "Not a global reference")
+
+(* Debug reference *)
+let debug = ref DebugOff
+
+(* Sets the debugger mode *)
+let set_debug pos = debug := pos
+
+(* Gives the state of debug *)
+let get_debug () = !debug
+
+(* Interprets an identifier which must be fresh *)
+let interp_ident ist id =
+  try match List.assoc id ist.lfun with
+  | VIntroPattern (IntroIdentifier id) -> id
+  | VConstr c as v when isVar c ->
+      (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
+      (* c is then expected not to belong to the proof context *)
+      (* would be checkable if env were known from interp_ident *)
+      destVar c
+  | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ 
+         str ") should have been bound to an identifier")
+  with Not_found -> id
+
+let interp_intro_pattern_var ist id =
+  try match List.assoc id ist.lfun with
+  | VIntroPattern ipat -> ipat
+  | VConstr c as v when isVar c ->
+      (* This happends e.g. in definitions like "Tac H = Clear H; Intro H" *)
+      (* c is then expected not to belong to the proof context *)
+      (* would be checkable if env were known from interp_ident *)
+      IntroIdentifier (destVar c)
+  | _ -> user_err_loc(loc,"interp_ident", str "An ltac name (" ++ pr_id id ++ 
+         str ") should have been bound to an introduction pattern")
+  with Not_found -> IntroIdentifier id
+
+let interp_int lfun (loc,id) =
+  try match List.assoc id lfun with
+  | VInteger n -> n
+  | _ -> user_err_loc(loc,"interp_int",str "should be bound to an integer")
+  with Not_found -> user_err_loc (loc,"interp_int",str "Unbound variable")
+
+let interp_int_or_var ist = function
+  | ArgVar locid -> interp_int ist.lfun locid
+  | ArgArg n -> n
+
+let constr_of_value env = function
+  | VConstr csr -> csr
+  | VIntroPattern (IntroIdentifier id) -> constr_of_id env id
+  | _ -> raise Not_found
+
+let is_variable env id =
+  List.mem id (ids_of_named_context (Environ.named_context env))
+
+let variable_of_value env = function
+  | VConstr c as v when isVar c -> destVar c
+  | VIntroPattern (IntroIdentifier id) when is_variable env id -> id
+  | _ -> raise Not_found
+
+(* Extract a variable from a value, if any *)
+let id_of_Identifier = variable_of_value
+
+(* Extract a constr from a value, if any *)
+let constr_of_VConstr = constr_of_value
+
+(* Interprets an variable *)
+let interp_var ist gl (loc,id) =
+  (* Look first in lfun for a value coercible to a variable *)
+  try 
+    let v = List.assoc id ist.lfun in
+    try variable_of_value (pf_env gl) v
+    with Not_found ->
+      errorlabstrm "coerce_to_variable"
+      (str "Cannot coerce" ++ spc () ++ pr_value (pf_env gl) v ++ spc () ++
+      str "to a variable")
+  with Not_found -> 
+  (* Then look if bound in the proof context at calling time *)
+  if is_variable (pf_env gl) id then id
+  else
+    user_err_loc (loc,"eval_variable",pr_id id ++ str " not found")
+
+(* Interprets an existing hypothesis (i.e. a declared variable) *)
+let interp_hyp = interp_var
+
+let interp_name ist = function
+  | Anonymous -> Anonymous
+  | Name id -> Name (interp_ident ist id)
+
+let interp_clause_pattern ist gl (l,occl) =
+  let rec check acc = function
+    | (hyp,l) :: rest ->
+	let hyp = interp_hyp ist gl hyp in
+	if List.mem hyp acc then
+	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice");
+	(hyp,l)::(check (hyp::acc) rest)
+    | [] -> []
+  in (l,check [] occl)
+
+(* Interprets a qualified name *)
+let interp_reference ist env = function
+  | ArgArg (_,r) -> r
+  | ArgVar (loc,id) -> coerce_to_reference env (unrec (List.assoc id ist.lfun))
+
+let pf_interp_reference ist gl = interp_reference ist (pf_env gl)
+
+let interp_inductive ist = function
+  | ArgArg r -> r
+  | ArgVar (_,id) -> coerce_to_inductive (unrec (List.assoc id ist.lfun))
+
+let interp_evaluable ist env = function
+  | ArgArg (r,Some (loc,id)) ->
+      (* Maybe [id] has been introduced by Intro-like tactics *)
+      (try match Environ.lookup_named id env with
+        | (_,Some _,_) -> EvalVarRef id
+        | _ -> error_not_evaluable (pr_id id)
+      with Not_found ->
+	match r with
+	  | EvalConstRef _ -> r
+	  | _ -> Pretype_errors.error_var_not_found_loc loc id)
+  | ArgArg (r,None) -> r
+  | ArgVar (_,id) -> 
+      coerce_to_evaluable_ref env (unrec (List.assoc id ist.lfun))
+
+(* Interprets an hypothesis name *)
+let interp_hyp_location ist gl (id,occs,hl) = (interp_hyp ist gl id,occs,hl)
+
+let interp_clause ist gl { onhyps=ol; onconcl=b; concl_occs=occs } =
+  { onhyps=option_app(List.map (interp_hyp_location ist gl)) ol;
+    onconcl=b;
+    concl_occs=occs }
+
+(* Interpretation of constructions *)
+
+(* Extract the constr list from lfun *)
+let rec constr_list_aux env = function
+  | (id,v)::tl -> 
+      let (l1,l2) = constr_list_aux env tl in
+      (try ((id,constr_of_value env v)::l1,l2)
+       with Not_found -> 
+	 let ido = match v with
+	   | VIntroPattern (IntroIdentifier id0) -> Some id0
+	   | _ -> None in
+	 (l1,(id,ido)::l2))
+  | [] -> ([],[])
+
+let constr_list ist env = constr_list_aux env ist.lfun
+
+(*Extract the identifier list from lfun: join all branches (what to do else?)*)
+let rec intropattern_ids = function
+  | IntroIdentifier id -> [id]
+  | IntroOrAndPattern ll -> 
+      List.flatten (List.map intropattern_ids (List.flatten ll))
+  | IntroWildcard -> []
+
+let rec extract_ids = function
+  | (id,VIntroPattern ipat)::tl -> intropattern_ids ipat @ extract_ids tl
+  | _::tl -> extract_ids tl
+  | [] -> []
+
+let retype_list sigma env lst =
+  List.fold_right (fun (x,csr) a ->
+    try (x,Retyping.get_judgment_of env sigma csr)::a with
+    | Anomaly _ -> a) lst []
+
+let interp_casted_constr ocl ist sigma env (c,ce) =
+  let (l1,l2) = constr_list ist env in
+  let tl1 = retype_list sigma env l1 in
+  let csr = 
+    match ce with
+    | None ->
+	Pretyping.understand_gen_ltac sigma env (tl1,l2) ocl c
+      (* If at toplevel (ce<>None), the error can be due to an incorrect
+         context at globalization time: we retype with the now known
+         intros/lettac/inversion hypothesis names *)
+    | Some c -> interp_constr_gen sigma env (l1,l2) c ocl
+  in
+  db_constr ist.debug env csr;
+  csr
+
+let interp_constr ist sigma env c =
+  interp_casted_constr None ist sigma env c
+
+(* Interprets an open constr expression casted by the current goal *)
+let pf_interp_casted_openconstr ist gl (c,ce) =
+  let sigma = project gl in
+  let env = pf_env gl in
+  let (ltacvars,l) = constr_list ist env in
+  let typs = retype_list sigma env ltacvars in
+  let ocl = Some (pf_concl gl) in
+  match ce with
+  | None ->
+      Pretyping.understand_gen_tcc sigma env typs ocl c
+    (* If at toplevel (ce<>None), the error can be due to an incorrect
+       context at globalization time: we retype with the now known
+       intros/lettac/inversion hypothesis names *)
+  | Some c -> interp_openconstr_gen sigma env (ltacvars,l) c ocl
+
+(* Interprets a constr expression *)
+let pf_interp_constr ist gl =
+  interp_constr ist (project gl) (pf_env gl)
+
+(* Interprets a constr expression casted by the current goal *)
+let pf_interp_casted_constr ist gl c =
+  interp_casted_constr (Some(pf_concl gl)) ist (project gl) (pf_env gl) c
+
+(* Interprets a reduction expression *)
+let interp_unfold ist env (l,qid) =
+  (l,interp_evaluable ist env qid)
+
+let interp_flag ist env red =
+  { red with rConst = List.map (interp_evaluable ist env) red.rConst }
+
+let interp_pattern ist sigma env (l,c) = (l,interp_constr ist sigma env c)
+
+let pf_interp_pattern ist gl = interp_pattern ist (project gl) (pf_env gl)
+
+let redexp_interp ist sigma env = function
+  | Unfold l -> Unfold (List.map (interp_unfold ist env) l)
+  | Fold l -> Fold (List.map (interp_constr ist sigma env) l)
+  | Cbv f -> Cbv (interp_flag ist env f)
+  | Lazy f -> Lazy (interp_flag ist env f)
+  | Pattern l -> Pattern (List.map (interp_pattern ist sigma env) l)
+  | Simpl o -> Simpl (option_app (interp_pattern ist sigma env) o)
+  | (Red _ |  Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s,interp_constr ist sigma env c)
+
+let pf_redexp_interp ist gl = redexp_interp ist (project gl) (pf_env gl)
+
+let interp_may_eval f ist gl = function
+  | ConstrEval (r,c) ->
+      let redexp = pf_redexp_interp ist gl  r in
+      pf_reduction_of_redexp gl redexp (f ist gl c)
+  | ConstrContext ((loc,s),c) ->
+      (try
+	let ic = f ist gl c
+	and ctxt = constr_of_VConstr_context (List.assoc s ist.lfun) in
+	subst_meta [special_meta,ic] ctxt
+      with
+	| Not_found ->
+	    user_err_loc (loc, "interp_may_eval",
+	    str "Unbound context identifier" ++ pr_id s))
+  | ConstrTypeOf c -> pf_type_of gl (f ist gl c)
+  | ConstrTerm c -> f ist gl c
+
+(* Interprets a constr expression possibly to first evaluate *)
+let interp_constr_may_eval ist gl c =
+  let csr = interp_may_eval pf_interp_constr ist gl c in
+  begin
+    db_constr ist.debug (pf_env gl) csr;
+    csr
+  end
+
+let rec interp_intro_pattern ist = function
+  | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist l)
+  | IntroWildcard -> IntroWildcard
+  | IntroIdentifier id -> interp_intro_pattern_var ist id
+
+and interp_case_intro_pattern ist =
+  List.map (List.map (interp_intro_pattern ist))
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let interp_quantified_hypothesis ist = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      try match List.assoc id ist.lfun with
+	| VInteger n -> AnonHyp n
+	| VIntroPattern (IntroIdentifier id) -> NamedHyp id
+	| _ -> raise Not_found
+      with Not_found -> NamedHyp id
+
+(* Quantified named or numbered hypothesis or hypothesis in context *)
+(* (as in Inversion) *)
+let interp_declared_or_quantified_hypothesis ist gl = function
+  | AnonHyp n -> AnonHyp n
+  | NamedHyp id ->
+      try match List.assoc id ist.lfun with
+	| VInteger n -> AnonHyp n
+	| v -> NamedHyp (variable_of_value (pf_env gl) v)
+      with Not_found -> NamedHyp id
+
+let interp_induction_arg ist gl = function
+  | ElimOnConstr c -> ElimOnConstr (pf_interp_constr ist gl c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent (loc,id) ->
+      if Tactics.is_quantified_hypothesis id gl then ElimOnIdent (loc,id)
+      else ElimOnConstr
+	(pf_interp_constr ist gl (RVar (loc,id),Some (CRef (Ident (loc,id)))))
+
+let interp_binding ist gl (loc,b,c) =
+  (loc,interp_quantified_hypothesis ist b,pf_interp_constr ist gl c)
+
+let interp_bindings ist gl = function
+| NoBindings -> NoBindings
+| ImplicitBindings l -> ImplicitBindings (List.map (pf_interp_constr ist gl) l)
+| ExplicitBindings l -> ExplicitBindings (List.map (interp_binding ist gl) l)
+
+let interp_constr_with_bindings ist gl (c,bl) =
+  (pf_interp_constr ist gl c, interp_bindings ist gl bl)
+
+(* Interprets an l-tac expression into a value *)
+let rec val_interp ist gl (tac:glob_tactic_expr) =
+
+  let value_interp ist = match tac with
+  (* Immediate evaluation *)
+  | TacFun (it,body) -> VFun (ist.lfun,it,body)
+  | TacLetRecIn (lrc,u) -> letrec_interp ist gl lrc u
+  | TacLetIn (l,u) ->
+      let addlfun = interp_letin ist gl l in
+      val_interp { ist with lfun=addlfun@ist.lfun } gl u
+  | TacMatchContext (lr,lmr) -> interp_match_context ist gl lr lmr 
+  | TacMatch (c,lmr) -> interp_match ist gl c lmr
+  | TacArg a -> interp_tacarg ist gl a
+  (* Delayed evaluation *)
+  | t -> VTactic (dummy_loc,eval_tactic ist t)
+
+  in check_for_interrupt (); 
+    match ist.debug with
+    | DebugOn lev ->
+	debug_prompt lev gl tac (fun v -> value_interp {ist with debug=v})
+    | _ -> value_interp ist
+
+and eval_tactic ist = function
+  | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl
+  | TacFun (it,body) -> assert false
+  | TacLetRecIn (lrc,u) -> assert false
+  | TacLetIn (l,u) -> assert false
+  | TacMatchContext _ -> assert false
+  | TacMatch (c,lmr) -> assert false
+  | TacId s -> tclIDTAC_MESSAGE s
+  | TacFail (n,s) -> tclFAIL (interp_int_or_var ist n) s
+  | TacProgress tac -> tclPROGRESS (interp_tactic ist tac)
+  | TacAbstract (tac,s) -> Tactics.tclABSTRACT s (interp_tactic ist tac)
+  | TacThen (t1,t2) -> tclTHEN (interp_tactic ist t1) (interp_tactic ist t2)
+  | TacThens (t,tl) ->
+      tclTHENS (interp_tactic ist t) (List.map (interp_tactic ist) tl)
+  | TacDo (n,tac) -> tclDO (interp_int_or_var ist n) (interp_tactic ist tac)
+  | TacTry tac -> tclTRY (interp_tactic ist tac)
+  | TacInfo tac -> tclINFO (interp_tactic ist tac)
+  | TacRepeat tac -> tclREPEAT (interp_tactic ist tac)
+  | TacOrelse (tac1,tac2) ->
+        tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2)
+  | TacFirst l -> tclFIRST (List.map (interp_tactic ist) l)
+  | TacSolve l -> tclSOLVE (List.map (interp_tactic ist) l)
+  | TacArg a -> assert false
+
+and interp_ltac_reference isapplied ist gl = function
+  | ArgVar (loc,id) -> unrec (List.assoc id ist.lfun)
+  | ArgArg (loc,r) ->
+      let v = val_interp {lfun=[];debug=ist.debug} gl (lookup r) in
+      if isapplied then v else locate_tactic_call loc v
+
+and interp_tacarg ist gl = function
+  | TacVoid -> VVoid
+  | Reference r -> interp_ltac_reference false ist gl r
+  | Integer n -> VInteger n
+  | IntroPattern ipat -> VIntroPattern ipat
+  | ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
+  | MetaIdArg (loc,id) -> assert false
+  | TacCall (loc,f,l) ->
+      let fv = interp_ltac_reference true ist gl f
+      and largs = List.map (interp_tacarg ist gl) l in
+      List.iter check_is_value largs;
+      interp_app ist gl fv largs loc
+  | TacFreshId idopt -> 
+      let s = match idopt with None -> "H" | Some s -> s in
+      let id = Tactics.fresh_id (extract_ids ist.lfun) (id_of_string s) gl in
+      VIntroPattern (IntroIdentifier id)
+  | Tacexp t -> val_interp ist gl t
+  | TacDynamic(_,t) ->
+      let tg = (tag t) in
+      if tg = "tactic" then
+        let f = (tactic_out t) in 
+        val_interp ist gl
+          (intern_tactic {
+            ltacvars = (List.map fst ist.lfun,[]); ltacrecvars = [];
+            gsigma = project gl; genv = pf_env gl }
+            (f ist))
+      else if tg = "value" then
+        value_out t
+      else if tg = "constr" then
+        VConstr (Pretyping.constr_out t)
+      else
+        anomaly_loc (loc, "Tacinterp.val_interp",
+          (str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
+
+(* Interprets an application node *)
+and interp_app ist gl fv largs loc =
+  match fv with
+    | VFun(olfun,var,body) ->
+      let (newlfun,lvar,lval)=head_with_value (var,largs) in
+      if lvar=[] then
+	let v = val_interp { ist with lfun=newlfun@olfun } gl body in
+        if lval=[] then locate_tactic_call loc v
+	else interp_app ist gl v lval loc
+      else
+        VFun(newlfun@olfun,lvar,body)
+    | _ ->
+	user_err_loc (loc, "Tacinterp.interp_app",
+          (str"Illegal tactic application"))
+
+(* Gives the tactic corresponding to the tactic value *)
+and tactic_of_value vle g =
+  match vle with
+  | VRTactic res -> res
+  | VTactic (loc,tac) -> catch_error loc tac g
+  | VFun _ -> error "A fully applied tactic is expected"
+  | _ -> raise NotTactic
+
+(* Evaluation with FailError catching *)
+and eval_with_fail ist tac goal =
+  try
+    (match val_interp ist goal tac with
+    | VTactic (loc,tac) -> VRTactic (catch_error loc tac goal)
+    | a -> a)
+  with
+    | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) ->
+	raise (Eval_fail s)
+    | Stdpp.Exc_located (s',FailError (lvl,s)) ->
+	raise (Stdpp.Exc_located (s',FailError (lvl - 1, s)))
+    | FailError (lvl,s) ->
+	raise (FailError (lvl - 1, s))
+
+(* Interprets recursive expressions *)
+and letrec_interp ist gl lrc u =
+  let lref = Array.to_list (Array.make (List.length lrc) (ref VVoid)) in
+  let lenv =
+    List.fold_right2 (fun ((loc,name),_) vref l -> (name,VRec vref)::l)
+      lrc lref [] in
+  let lve = List.map (fun ((loc,name),(var,body)) ->
+                          (name,VFun(lenv@ist.lfun,var,body))) lrc in
+  begin
+    List.iter2 (fun vref (_,ve) -> vref:=ve) lref lve;
+    val_interp { ist with lfun=lve@ist.lfun } gl u
+  end
+
+(* Interprets the clauses of a LetIn *)
+and interp_letin ist gl = function
+  | [] -> []
+  | ((loc,id),None,t)::tl -> 
+      let v = interp_tacarg ist gl t in
+      check_is_value v;
+      (id,v):: (interp_letin ist gl tl)
+  | ((loc,id),Some com,tce)::tl ->
+    let env = pf_env gl in
+    let typ = constr_of_value env (val_interp ist gl com)
+    and v = interp_tacarg ist gl tce in
+    let csr = 
+      try
+	constr_of_value env v
+      with Not_found ->
+      try
+	let t = tactic_of_value v in
+	let ndc = Environ.named_context env in
+	start_proof id IsLocal ndc typ (fun _ _ -> ());
+	by t;
+	let (_,({const_entry_body = pft},_,_)) = cook_proof () in
+	delete_proof (dummy_loc,id);
+        pft
+      with | NotTactic ->
+	delete_proof (dummy_loc,id);
+	errorlabstrm "Tacinterp.interp_letin"
+          (str "Term or fully applied tactic expected in Let")
+    in (id,VConstr (mkCast (csr,typ)))::(interp_letin ist gl tl)
+
+(* Interprets the Match Context expressions *)
+and interp_match_context ist g lr lmr =
+  let rec apply_goal_sub ist env goal nocc (id,c) csr mt mhyps hyps =
+    try
+      let (lgoal,ctxt) = sub_match nocc c csr in
+      let lctxt = give_context ctxt id in
+      if mhyps = [] then
+	let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in
+        eval_with_fail { ist with lfun=lgoal@lctxt@ist.lfun } mt goal
+      else
+        apply_hyps_context ist env goal mt lgoal mhyps hyps
+    with
+    | e when is_failure e -> raise e
+    | NextOccurrence _ -> raise No_match
+    | e when is_match_catchable e ->
+      apply_goal_sub ist env goal (nocc + 1) (id,c) csr mt mhyps hyps in
+  let rec apply_match_context ist env goal nrs lex lpt = 
+    begin
+    if lex<>[] then db_pattern_rule ist.debug nrs (List.hd lex);
+    match lpt with
+    | (All t)::tl ->
+      begin
+        db_mc_pattern_success ist.debug;
+        try eval_with_fail ist t goal
+         with e when is_match_catchable e ->
+           apply_match_context ist env goal (nrs+1) (List.tl lex) tl
+      end
+    | (Pat (mhyps,mgoal,mt))::tl ->
+      let hyps = make_hyps (pf_hyps goal) in
+      let hyps = if lr then List.rev hyps else hyps in
+      let mhyps = List.rev mhyps (* Sens naturel *) in
+      let concl = pf_concl goal in
+      (match mgoal with
+      |	Term mg ->
+        (try
+           (let lgoal = apply_matching mg concl in
+            begin
+            db_matched_concl ist.debug (pf_env goal) concl;
+            if mhyps = [] then
+            begin
+              db_mc_pattern_success ist.debug;
+	      let lgoal = List.map (fun (id,c) -> (id,VConstr c)) lgoal in
+              eval_with_fail {ist with lfun=lgoal@ist.lfun} mt goal
+            end
+            else
+              apply_hyps_context ist env goal mt lgoal mhyps hyps
+            end)
+        with 
+        | e when is_match_catchable e ->
+          begin 
+            (match e with
+            | No_match -> db_matching_failure ist.debug
+            | Eval_fail s -> db_eval_failure ist.debug s
+            | _ -> db_logic_failure ist.debug e);
+            apply_match_context ist env goal (nrs+1) (List.tl lex) tl
+          end)
+      |	Subterm (id,mg) ->
+        (try apply_goal_sub ist env goal 0 (id,mg) concl mt mhyps hyps
+         with e when is_match_catchable e ->
+           apply_match_context ist env goal (nrs+1) (List.tl lex) tl))
+    | _ ->
+      errorlabstrm "Tacinterp.apply_match_context" (str
+        "No matching clauses for match goal")
+        (v 0 (str "No matching clauses for match goal" ++
+        (if ist.debug=DebugOff then
+           fnl() ++ str "(use \"Debug On\" for more info)"
+         else mt())))
+    end in
+  let env = pf_env g in
+  apply_match_context ist env g 0 lmr
+    (read_match_rule (project g) env (fst (constr_list ist env)) lmr)
+
+(* Tries to match the hypotheses in a Match Context *)
+and apply_hyps_context ist env goal mt lgmatch mhyps hyps =
+  let rec apply_hyps_context_rec lfun lmatch lhyps_rest current = function
+    | Hyp ((_,hypname),mhyp)::tl as mhyps ->
+        let (lids,lm,hyp_match,next) =
+          apply_one_mhyp_context ist env goal lmatch (hypname,mhyp) current in
+        db_matched_hyp ist.debug (pf_env goal) hyp_match hypname;
+        begin 
+	  try
+            let nextlhyps = list_except hyp_match lhyps_rest in
+            apply_hyps_context_rec (lfun@lids) (lmatch@lm) nextlhyps
+	      (nextlhyps,0) tl
+          with
+          | e when is_failure e -> raise e
+	  | e when is_match_catchable e -> 
+	      apply_hyps_context_rec lfun lmatch lhyps_rest next mhyps
+        end
+    | [] ->
+	let lmatch = List.map (fun (id,c) -> (id,VConstr c)) lmatch in
+        db_mc_pattern_success ist.debug;
+        eval_with_fail {ist with lfun=lmatch@lfun@ist.lfun} mt goal
+  in
+  apply_hyps_context_rec [] lgmatch hyps (hyps,0) mhyps
+
+  (* Interprets extended tactic generic arguments *)
+and interp_genarg ist goal x =
+  match genarg_tag x with
+  | BoolArgType -> in_gen wit_bool (out_gen globwit_bool x)
+  | IntArgType -> in_gen wit_int (out_gen globwit_int x)
+  | IntOrVarArgType ->
+      in_gen wit_int_or_var
+        (ArgArg (interp_int_or_var ist (out_gen globwit_int_or_var x)))
+  | StringArgType ->
+      in_gen wit_string (out_gen globwit_string x)
+  | PreIdentArgType ->
+      in_gen wit_pre_ident (out_gen globwit_pre_ident x)
+  | IntroPatternArgType ->
+      in_gen wit_intro_pattern
+        (interp_intro_pattern ist (out_gen globwit_intro_pattern x))
+  | IdentArgType ->
+      in_gen wit_ident (interp_ident ist (out_gen globwit_ident x))
+  | HypArgType ->
+      in_gen wit_var (mkVar (interp_hyp ist goal (out_gen globwit_var x)))
+  | RefArgType ->
+      in_gen wit_ref (pf_interp_reference ist goal (out_gen globwit_ref x))
+  | SortArgType ->
+      in_gen wit_sort
+        (destSort 
+	  (pf_interp_constr ist goal 
+	    (RSort (dummy_loc,out_gen globwit_sort x), None)))
+  | ConstrArgType ->
+      in_gen wit_constr (pf_interp_constr ist goal (out_gen globwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen wit_constr_may_eval (interp_constr_may_eval ist goal (out_gen globwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen wit_quant_hyp
+        (interp_declared_or_quantified_hypothesis ist goal
+          (out_gen globwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen wit_red_expr (pf_redexp_interp ist goal (out_gen globwit_red_expr x))
+  | TacticArgType -> in_gen wit_tactic (out_gen globwit_tactic x)
+  | CastedOpenConstrArgType ->
+      in_gen wit_casted_open_constr 
+        (pf_interp_casted_openconstr ist goal (out_gen globwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen wit_constr_with_bindings
+        (interp_constr_with_bindings ist goal (out_gen globwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen wit_bindings
+        (interp_bindings ist goal (out_gen globwit_bindings x))
+  | List0ArgType _ -> app_list0 (interp_genarg ist goal) x
+  | List1ArgType _ -> app_list1 (interp_genarg ist goal) x
+  | OptArgType _ -> app_opt (interp_genarg ist goal) x
+  | PairArgType _ -> app_pair (interp_genarg ist goal) (interp_genarg ist goal) x
+  | ExtraArgType s -> lookup_interp_genarg s ist goal x
+
+(* Interprets the Match expressions *)
+and interp_match ist g constr lmr =
+  let rec apply_sub_match ist nocc (id,c) csr mt =
+    try 
+      let (lm,ctxt) = sub_match nocc c csr in
+      let lctxt = give_context ctxt id in
+      let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+      val_interp {ist with lfun=lm@lctxt@ist.lfun} g mt
+    with | NextOccurrence _ -> raise No_match
+  in
+  let rec apply_match ist csr = function
+    | (All t)::_ ->
+        (try val_interp ist g t
+         with e when is_match_catchable e -> apply_match ist csr [])
+    | (Pat ([],Term c,mt))::tl ->
+        (try
+	  let lm = apply_matching c csr in
+	  let lm = List.map (fun (id,c) -> (id,VConstr c)) lm in
+          val_interp
+            { ist with lfun=lm@ist.lfun } g mt
+         with e when is_match_catchable e -> apply_match ist csr tl)
+    | (Pat ([],Subterm (id,c),mt))::tl ->
+        (try
+          apply_sub_match ist 0 (id,c) csr mt
+         with | No_match ->
+	   apply_match ist csr tl)
+    | _ ->
+      errorlabstrm "Tacinterp.apply_match" (str
+        "No matching clauses for match") in
+  let env = pf_env g in
+  let csr =
+    try constr_of_value env (val_interp ist g constr)
+    with Not_found ->
+      errorlabstrm "Tacinterp.apply_match" 
+        (str "Argument of match does not evaluate to a term") in
+  let ilr = read_match_rule (project g) env (fst (constr_list ist env)) lmr in
+  apply_match ist csr ilr
+
+(* Interprets tactic expressions : returns a "tactic" *)
+and interp_tactic ist tac gl =
+  try tactic_of_value (val_interp ist gl tac) gl
+  with | NotTactic ->
+    errorlabstrm "Tacinterp.interp_tactic" (str
+      "Must be a command or must give a tactic value")
+
+(* Interprets a primitive tactic *)
+and interp_atomic ist gl = function
+  (* Basic tactics *)
+  | TacIntroPattern l ->
+      h_intro_patterns (List.map (interp_intro_pattern ist) l)
+  | TacIntrosUntil hyp ->
+      h_intros_until (interp_quantified_hypothesis ist hyp)
+  | TacIntroMove (ido,ido') ->
+      h_intro_move (option_app (interp_ident ist) ido)
+      (option_app (interp_hyp ist gl) ido')
+  | TacAssumption -> h_assumption
+  | TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
+  | TacApply cb -> h_apply (interp_constr_with_bindings ist gl cb)
+  | TacElim (cb,cbo) ->
+      h_elim (interp_constr_with_bindings ist gl cb)
+                (option_app (interp_constr_with_bindings ist gl) cbo)
+  | TacElimType c -> h_elim_type (pf_interp_constr ist gl c)
+  | TacCase cb -> h_case (interp_constr_with_bindings ist gl cb)
+  | TacCaseType c -> h_case_type (pf_interp_constr ist gl c)
+  | TacFix (idopt,n) -> h_fix (option_app (interp_ident ist) idopt) n
+  | TacMutualFix (id,n,l) ->
+      let f (id,n,c) = (interp_ident ist id,n,pf_interp_constr ist gl c) in
+      h_mutual_fix (interp_ident ist id) n (List.map f l)
+  | TacCofix idopt -> h_cofix (option_app (interp_ident ist) idopt)
+  | TacMutualCofix (id,l) ->
+      let f (id,c) = (interp_ident ist id,pf_interp_constr ist gl c) in
+      h_mutual_cofix (interp_ident ist id) (List.map f l)
+  | TacCut c -> h_cut (pf_interp_constr ist gl c)
+  | TacTrueCut (na,c) ->
+      h_true_cut (interp_name ist na) (pf_interp_constr ist gl c)
+  | TacForward (b,na,c) ->
+      h_forward b (interp_name ist na) (pf_interp_constr ist gl c)
+  | TacGeneralize cl -> h_generalize (List.map (pf_interp_constr ist gl) cl)
+  | TacGeneralizeDep c -> h_generalize_dep (pf_interp_constr ist gl c)
+  | TacLetTac (na,c,clp) ->
+      let clp = interp_clause ist gl clp in
+      h_let_tac (interp_name ist na) (pf_interp_constr ist gl c) clp
+  | TacInstantiate (n,c,ido) -> h_instantiate n (pf_interp_constr ist gl c)
+      (clause_app (interp_hyp_location ist gl) ido)
+
+  (* Automation tactics *)
+  | TacTrivial l -> Auto.h_trivial l
+  | TacAuto (n, l) -> Auto.h_auto n l
+  | TacAutoTDB n -> Dhyp.h_auto_tdb n
+  | TacDestructHyp (b,id) -> Dhyp.h_destructHyp b (interp_hyp ist gl id)
+  | TacDestructConcl -> Dhyp.h_destructConcl
+  | TacSuperAuto (n,l,b1,b2) -> Auto.h_superauto n l b1 b2
+  | TacDAuto (n,p) -> Auto.h_dauto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction (h,ids) ->
+      let h =
+        if !Options.v7 then interp_declared_or_quantified_hypothesis ist gl h
+        else interp_quantified_hypothesis ist h in
+      h_simple_induction (h,ids)
+  | TacNewInduction (c,cbo,(ids,ids')) ->
+      h_new_induction (interp_induction_arg ist gl c)
+        (option_app (interp_constr_with_bindings ist gl) cbo)
+        (option_app (interp_intro_pattern ist) ids,ids')
+  | TacSimpleDestruct h ->
+      h_simple_destruct (interp_quantified_hypothesis ist h)
+  | TacNewDestruct (c,cbo,(ids,ids')) -> 
+      h_new_destruct (interp_induction_arg ist gl c)
+        (option_app (interp_constr_with_bindings ist gl) cbo)
+        (option_app (interp_intro_pattern ist) ids,ids')
+  | TacDoubleInduction (h1,h2) ->
+      let h1 = interp_quantified_hypothesis ist h1 in
+      let h2 = interp_quantified_hypothesis ist h2 in
+      Elim.h_double_induction h1 h2
+  | TacDecomposeAnd c -> Elim.h_decompose_and (pf_interp_constr ist gl c)
+  | TacDecomposeOr c -> Elim.h_decompose_or (pf_interp_constr ist gl c)
+  | TacDecompose (l,c) ->
+      let l = List.map (interp_inductive ist) l in
+      Elim.h_decompose l (pf_interp_constr ist gl c)
+  | TacSpecialize (n,l) ->
+      h_specialize n (interp_constr_with_bindings ist gl l)
+  | TacLApply c -> h_lapply (pf_interp_constr ist gl c)
+
+  (* Context management *)
+  | TacClear l -> h_clear (List.map (interp_hyp ist gl) l)
+  | TacClearBody l -> h_clear_body (List.map (interp_hyp ist gl) l)
+  | TacMove (dep,id1,id2) ->
+      h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2)
+  | TacRename (id1,id2) ->
+      h_rename (interp_hyp ist gl id1) (interp_ident ist (snd id2))
+
+  (* Constructors *)
+  | TacLeft bl -> h_left (interp_bindings ist gl bl)
+  | TacRight bl -> h_right (interp_bindings ist gl bl)
+  | TacSplit (_,bl) -> h_split (interp_bindings ist gl bl)
+  | TacAnyConstructor t ->
+      abstract_tactic (TacAnyConstructor t)
+        (Tactics.any_constructor (option_app (interp_tactic ist) t))
+  | TacConstructor (n,bl) ->
+      h_constructor (skip_metaid n) (interp_bindings ist gl bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) ->
+      h_reduce (pf_redexp_interp ist gl r) (interp_clause ist gl cl)
+  | TacChange (occl,c,cl) ->
+      h_change (option_app (pf_interp_pattern ist gl) occl)
+        (pf_interp_constr ist gl c) (interp_clause ist gl cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity -> h_reflexivity
+  | TacSymmetry c -> h_symmetry (interp_clause ist gl c)
+  | TacTransitivity c -> h_transitivity (pf_interp_constr ist gl c)
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,ids),hyp) ->
+      Inv.dinv k (option_app (pf_interp_constr ist gl) c)
+        (option_app (interp_intro_pattern ist) ids)
+        (interp_declared_or_quantified_hypothesis ist gl hyp)
+  | TacInversion (NonDepInversion (k,idl,ids),hyp) ->
+      Inv.inv_clause k 
+        (option_app (interp_intro_pattern ist) ids)
+        (List.map (interp_hyp ist gl) idl)
+        (interp_declared_or_quantified_hypothesis ist gl hyp)
+  | TacInversion (InversionUsing (c,idl),hyp) ->
+      Leminv.lemInv_clause (interp_declared_or_quantified_hypothesis ist gl hyp)
+        (pf_interp_constr ist gl c)
+        (List.map (interp_hyp ist gl) idl)
+
+  (* For extensions *)
+  | TacExtend (loc,opn,l) ->
+      fun gl -> vernac_tactic (opn,List.map (interp_genarg ist gl) l) gl
+  | TacAlias (loc,_,l,(_,body)) -> fun gl ->
+    let rec f x = match genarg_tag x with
+    | IntArgType -> VInteger (out_gen globwit_int x)
+    | IntOrVarArgType -> 
+	VInteger (interp_int_or_var ist (out_gen globwit_int_or_var x))
+    | PreIdentArgType ->
+	failwith "pre-identifiers cannot be bound"
+    | IntroPatternArgType ->
+	VIntroPattern (out_gen globwit_intro_pattern x)
+    | IdentArgType -> 
+        VIntroPattern (IntroIdentifier (out_gen globwit_ident x))
+    | HypArgType ->
+	VConstr (mkVar (interp_var ist gl (out_gen globwit_var x)))
+    | RefArgType -> 
+        VConstr (constr_of_reference 
+          (pf_interp_reference ist gl (out_gen globwit_ref x)))
+    | SortArgType ->
+	VConstr (mkSort (Pretyping.interp_sort (out_gen globwit_sort x)))
+    | ConstrArgType ->
+        VConstr (pf_interp_constr ist gl (out_gen globwit_constr x))
+    | ConstrMayEvalArgType ->
+	VConstr
+          (interp_constr_may_eval ist gl (out_gen globwit_constr_may_eval x))
+    | TacticArgType -> 
+	val_interp ist gl (out_gen globwit_tactic x)
+    | StringArgType | BoolArgType
+    | QuantHypArgType | RedExprArgType 
+    | CastedOpenConstrArgType | ConstrWithBindingsArgType | BindingsArgType 
+    | ExtraArgType _ | List0ArgType _ | List1ArgType _ | OptArgType _ | PairArgType _ 
+	-> error "This generic type is not supported in alias"
+    in
+    let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
+    let v = locate_tactic_call loc (val_interp { ist with lfun=lfun } gl body)
+    in tactic_of_value v gl
+
+(* Initial call for interpretation *)
+let interp_tac_gen lfun debug t gl = 
+  interp_tactic { lfun=lfun; debug=debug } 
+    (intern_tactic {
+      ltacvars = (List.map fst lfun, []); ltacrecvars = [];
+      gsigma = project gl; genv = pf_env gl } t) gl
+
+let eval_tactic t = interp_tactic { lfun=[]; debug=get_debug() } t
+
+let interp t = interp_tac_gen [] (get_debug()) t
+
+(* Hides interpretation for pretty-print *)
+let hide_interp t ot gl =
+  let ist = { ltacvars = ([],[]); ltacrecvars = []; 
+            gsigma = project gl; genv = pf_env gl } in
+  let te = intern_tactic ist t in
+  let t = eval_tactic te in
+  match ot with 
+  | None -> abstract_tactic_expr (TacArg (Tacexp te)) t gl
+  | Some t' -> abstract_tactic_expr (TacArg (Tacexp te)) (tclTHEN t t') gl
+
+(***************************************************************************)
+(* Substitution at module closing time *)
+
+let subst_quantified_hypothesis _ x = x
+
+let subst_declared_or_quantified_hypothesis _ x = x
+
+let subst_inductive subst (kn,i) = (subst_kn subst kn,i)
+
+let subst_rawconstr subst (c,e) =
+  assert (e=None); (* e<>None only for toplevel tactics *)
+  (subst_raw subst c,None)
+
+let subst_binding subst (loc,b,c) =
+  (loc,subst_quantified_hypothesis subst b,subst_rawconstr subst c)
+
+let subst_bindings subst = function
+  | NoBindings -> NoBindings
+  | ImplicitBindings l -> ImplicitBindings (List.map (subst_rawconstr subst) l)
+  | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l)
+
+let subst_raw_with_bindings subst (c,bl) =
+  (subst_rawconstr subst c, subst_bindings subst bl)
+
+let subst_induction_arg subst = function
+  | ElimOnConstr c -> ElimOnConstr (subst_rawconstr subst c)
+  | ElimOnAnonHyp n as x -> x
+  | ElimOnIdent id as x -> x
+
+let subst_evaluable_reference subst = function
+  | EvalVarRef id -> EvalVarRef id
+  | EvalConstRef kn -> EvalConstRef (subst_kn subst kn)
+
+let subst_and_short_name f (c,n) =
+  assert (n=None); (* since tacdef are strictly globalized *)
+  (f c,None)
+
+let subst_or_var f =  function
+  | ArgVar _ as x -> x
+  | ArgArg (x) -> ArgArg (f x)
+
+let subst_located f (_loc,id) = (loc,f id)
+
+let subst_reference subst = 
+  subst_or_var (subst_located (subst_kn subst))
+
+let subst_global_reference subst = 
+  subst_or_var (subst_located (subst_global subst))
+
+let subst_evaluable subst =
+  subst_or_var (subst_and_short_name (subst_evaluable_reference subst))
+
+let subst_unfold subst (l,e) = 
+  (l,subst_evaluable subst e)
+
+let subst_flag subst red =
+  { red with rConst = List.map (subst_evaluable subst) red.rConst }
+
+let subst_constr_occurrence subst (l,c) = (l,subst_rawconstr subst c)
+
+let subst_redexp subst = function
+  | Unfold l -> Unfold (List.map (subst_unfold subst) l)
+  | Fold l -> Fold (List.map (subst_rawconstr subst) l)
+  | Cbv f -> Cbv (subst_flag subst f)
+  | Lazy f -> Lazy (subst_flag subst f)
+  | Pattern l -> Pattern (List.map (subst_constr_occurrence subst) l)
+  | Simpl o -> Simpl (option_app (subst_constr_occurrence subst) o)
+  | (Red _ | Hnf as r) -> r
+  | ExtraRedExpr (s,c) -> ExtraRedExpr (s, subst_rawconstr subst c)
+
+let subst_raw_may_eval subst = function
+  | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_rawconstr subst c)
+  | ConstrContext (locid,c) -> ConstrContext (locid,subst_rawconstr subst c)
+  | ConstrTypeOf c -> ConstrTypeOf (subst_rawconstr subst c)
+  | ConstrTerm c -> ConstrTerm (subst_rawconstr subst c)
+
+let subst_match_pattern subst = function
+  | Subterm (ido,pc) -> Subterm (ido,subst_pattern subst pc)
+  | Term pc -> Term (subst_pattern subst pc)
+
+let rec subst_match_context_hyps subst = function
+  | Hyp (locs,mp) :: tl ->
+      Hyp (locs,subst_match_pattern subst mp)
+      :: subst_match_context_hyps subst tl
+  | [] -> []
+
+let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
+  (* Basic tactics *)
+  | TacIntroPattern _ | TacIntrosUntil _ | TacIntroMove _ as x -> x
+  | TacAssumption as x -> x
+  | TacExact c -> TacExact (subst_rawconstr subst c)
+  | TacApply cb -> TacApply (subst_raw_with_bindings subst cb)
+  | TacElim (cb,cbo) ->
+      TacElim (subst_raw_with_bindings subst cb,
+               option_app (subst_raw_with_bindings subst) cbo)
+  | TacElimType c -> TacElimType (subst_rawconstr subst c)
+  | TacCase cb -> TacCase (subst_raw_with_bindings subst cb)
+  | TacCaseType c -> TacCaseType (subst_rawconstr subst c)
+  | TacFix (idopt,n) as x -> x
+  | TacMutualFix (id,n,l) ->
+      TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_rawconstr subst c)) l)
+  | TacCofix idopt as x -> x
+  | TacMutualCofix (id,l) ->
+      TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_rawconstr subst c)) l)
+  | TacCut c -> TacCut (subst_rawconstr subst c)
+  | TacTrueCut (ido,c) -> TacTrueCut (ido, subst_rawconstr subst c)
+  | TacForward (b,na,c) -> TacForward (b,na,subst_rawconstr subst c)
+  | TacGeneralize cl -> TacGeneralize (List.map (subst_rawconstr subst) cl)
+  | TacGeneralizeDep c -> TacGeneralizeDep (subst_rawconstr subst c)
+  | TacLetTac (id,c,clp) -> TacLetTac (id,subst_rawconstr subst c,clp)
+  | TacInstantiate (n,c,ido) -> TacInstantiate (n,subst_rawconstr subst c,ido)
+
+  (* Automation tactics *)
+  | TacTrivial l -> TacTrivial l
+  | TacAuto (n,l) -> TacAuto (n,l)
+  | TacAutoTDB n -> TacAutoTDB n
+  | TacDestructHyp (b,id) -> TacDestructHyp(b,id)
+  | TacDestructConcl -> TacDestructConcl
+  | TacSuperAuto (n,l,b1,b2) -> TacSuperAuto (n,l,b1,b2)
+  | TacDAuto (n,p) -> TacDAuto (n,p)
+
+  (* Derived basic tactics *)
+  | TacSimpleInduction h as x -> x
+  | TacNewInduction (c,cbo,ids) ->
+      TacNewInduction (subst_induction_arg subst c,
+               option_app (subst_raw_with_bindings subst) cbo, ids)
+  | TacSimpleDestruct h as x -> x
+  | TacNewDestruct (c,cbo,ids) ->
+      TacNewDestruct (subst_induction_arg subst c,
+               option_app (subst_raw_with_bindings subst) cbo, ids)
+  | TacDoubleInduction (h1,h2) as x -> x
+  | TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
+  | TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
+  | TacDecompose (l,c) ->
+      let l = List.map (subst_or_var (subst_inductive subst)) l in
+      TacDecompose (l,subst_rawconstr subst c)
+  | TacSpecialize (n,l) -> TacSpecialize (n,subst_raw_with_bindings subst l)
+  | TacLApply c -> TacLApply (subst_rawconstr subst c)
+
+  (* Context management *)
+  | TacClear l as x -> x
+  | TacClearBody l as x -> x
+  | TacMove (dep,id1,id2) as x -> x
+  | TacRename (id1,id2) as x -> x
+
+  (* Constructors *)
+  | TacLeft bl -> TacLeft (subst_bindings subst bl)
+  | TacRight bl -> TacRight (subst_bindings subst bl)
+  | TacSplit (b,bl) -> TacSplit (b,subst_bindings subst bl)
+  | TacAnyConstructor t -> TacAnyConstructor (option_app (subst_tactic subst) t)
+  | TacConstructor (n,bl) -> TacConstructor (n, subst_bindings subst bl)
+
+  (* Conversion *)
+  | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl)
+  | TacChange (occl,c,cl) ->
+      TacChange (option_app (subst_constr_occurrence subst) occl,
+        subst_rawconstr subst c, cl)
+
+  (* Equivalence relations *)
+  | TacReflexivity | TacSymmetry _ as x -> x
+  | TacTransitivity c -> TacTransitivity (subst_rawconstr subst c)
+
+  (* Equality and inversion *)
+  | TacInversion (DepInversion (k,c,l),hyp) ->
+     TacInversion (DepInversion (k,option_app (subst_rawconstr subst) c,l),hyp)
+  | TacInversion (NonDepInversion _,_) as x -> x
+  | TacInversion (InversionUsing (c,cl),hyp) ->
+      TacInversion (InversionUsing (subst_rawconstr subst c,cl),hyp)
+
+  (* For extensions *)
+  | TacExtend (_loc,opn,l) ->
+      TacExtend (loc,opn,List.map (subst_genarg subst) l)
+  | TacAlias (_,s,l,(dir,body)) ->
+      TacAlias (loc,s,List.map (fun (id,a) -> (id,subst_genarg subst a)) l,
+        (dir,subst_tactic subst body))
+
+and subst_tactic subst (t:glob_tactic_expr) = match t with
+  | TacAtom (_loc,t) -> TacAtom (loc, subst_atomic subst t)
+  | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun)
+  | TacLetRecIn (lrc,u) ->
+      let lrc = List.map (fun (n,b) -> (n,subst_tactic_fun subst b)) lrc in
+      TacLetRecIn (lrc,(subst_tactic subst u:glob_tactic_expr))
+  | TacLetIn (l,u) ->
+      let l = List.map (fun (n,c,b) -> (n,option_app (subst_tactic subst) c,subst_tacarg subst b)) l in
+      TacLetIn (l,subst_tactic subst u)
+  | TacMatchContext (lr,lmr) ->
+      TacMatchContext(lr, subst_match_rule subst lmr)
+  | TacMatch (c,lmr) ->
+      TacMatch (subst_tactic subst c,subst_match_rule subst lmr)
+  | TacId _ | TacFail _ as x -> x
+  | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr)
+  | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s)
+  | TacThen (t1,t2) ->
+      TacThen (subst_tactic subst t1,subst_tactic subst t2)
+  | TacThens (t,tl) ->
+      TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl)
+  | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac)
+  | TacTry tac -> TacTry (subst_tactic subst tac)
+  | TacInfo tac -> TacInfo (subst_tactic subst tac)
+  | TacRepeat tac -> TacRepeat (subst_tactic subst tac)
+  | TacOrelse (tac1,tac2) ->
+      TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2)
+  | TacFirst l -> TacFirst (List.map (subst_tactic subst) l)
+  | TacSolve l -> TacSolve (List.map (subst_tactic subst) l)
+  | TacArg a -> TacArg (subst_tacarg subst a)
+
+and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body)
+
+and subst_tacarg subst = function
+  | Reference r -> Reference (subst_reference subst r)
+  | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c)
+  | MetaIdArg (_loc,_) -> assert false
+  | TacCall (_loc,f,l) ->
+      TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l)
+  | (TacVoid | IntroPattern _ | Integer _ | TacFreshId _) as x -> x
+  | Tacexp t -> Tacexp (subst_tactic subst t)
+  | TacDynamic(_,t) as x ->
+      (match tag t with
+	| "tactic" | "value" | "constr" -> x
+	| s -> anomaly_loc (loc, "Tacinterp.val_interp",
+                 str "Unknown dynamic: <" ++ str s ++ str ">"))
+
+(* Reads the rules of a Match Context or a Match *)
+and subst_match_rule subst = function
+  | (All tc)::tl ->
+      (All (subst_tactic subst tc))::(subst_match_rule subst tl)
+  | (Pat (rl,mp,tc))::tl ->
+      let hyps = subst_match_context_hyps subst rl in
+      let pat = subst_match_pattern subst mp in
+      Pat (hyps,pat,subst_tactic subst tc)
+      ::(subst_match_rule subst tl)
+  | [] -> []
+
+and subst_genarg subst (x:glob_generic_argument) =
+  match genarg_tag x with
+  | BoolArgType -> in_gen globwit_bool (out_gen globwit_bool x)
+  | IntArgType -> in_gen globwit_int (out_gen globwit_int x)
+  | IntOrVarArgType -> in_gen globwit_int_or_var (out_gen globwit_int_or_var x)
+  | StringArgType -> in_gen globwit_string (out_gen globwit_string x)
+  | PreIdentArgType -> in_gen globwit_pre_ident (out_gen globwit_pre_ident x)
+  | IntroPatternArgType ->
+      in_gen globwit_intro_pattern (out_gen globwit_intro_pattern x)
+  | IdentArgType -> in_gen globwit_ident (out_gen globwit_ident x)
+  | HypArgType -> in_gen globwit_var (out_gen globwit_var x)
+  | RefArgType ->
+      in_gen globwit_ref (subst_global_reference subst 
+	(out_gen globwit_ref x))
+  | SortArgType ->
+      in_gen globwit_sort (out_gen globwit_sort x)
+  | ConstrArgType ->
+      in_gen globwit_constr (subst_rawconstr subst (out_gen globwit_constr x))
+  | ConstrMayEvalArgType ->
+      in_gen globwit_constr_may_eval (subst_raw_may_eval subst (out_gen globwit_constr_may_eval x))
+  | QuantHypArgType ->
+      in_gen globwit_quant_hyp
+        (subst_declared_or_quantified_hypothesis subst 
+          (out_gen globwit_quant_hyp x))
+  | RedExprArgType ->
+      in_gen globwit_red_expr (subst_redexp subst (out_gen globwit_red_expr x))
+  | TacticArgType ->
+      in_gen globwit_tactic (subst_tactic subst (out_gen globwit_tactic x))
+  | CastedOpenConstrArgType ->
+      in_gen globwit_casted_open_constr 
+        (subst_rawconstr subst (out_gen globwit_casted_open_constr x))
+  | ConstrWithBindingsArgType ->
+      in_gen globwit_constr_with_bindings
+        (subst_raw_with_bindings subst (out_gen globwit_constr_with_bindings x))
+  | BindingsArgType ->
+      in_gen globwit_bindings
+        (subst_bindings subst (out_gen globwit_bindings x))
+  | List0ArgType _ -> app_list0 (subst_genarg subst) x
+  | List1ArgType _ -> app_list1 (subst_genarg subst) x
+  | OptArgType _ -> app_opt (subst_genarg subst) x
+  | PairArgType _ -> app_pair (subst_genarg subst) (subst_genarg subst) x
+  | ExtraArgType s -> lookup_genarg_subst s subst x
+
+(***************************************************************************)
+(* Tactic registration *)
+
+(* For bad tactic calls *)
+let bad_tactic_args s =
+  anomalylabstrm s
+    (str "Tactic " ++ str s ++ str " called with bad arguments")
+
+(* Declaration of the TAC-DEFINITION object *)
+let add (kn,td) = mactab := Gmap.add kn td !mactab
+
+let load_md i ((sp,kn),defs) =
+  let dp,_ = repr_path sp in
+  let mp,dir,_ = repr_kn kn in
+  List.iter (fun (id,t) -> 
+    let sp = Libnames.make_path dp id in
+    let kn = Names.make_kn mp dir (label_of_id id) in
+    Nametab.push_tactic (Until i) sp kn;
+    add (kn,t)) defs
+
+let open_md i((sp,kn),defs) =
+  let dp,_ = repr_path sp in
+  let mp,dir,_ = repr_kn kn in
+  List.iter (fun (id,t) -> 
+    let sp = Libnames.make_path dp id in
+    let kn = Names.make_kn mp dir (label_of_id id) in
+    Nametab.push_tactic (Exactly i) sp kn) defs
+
+let cache_md x = load_md 1 x
+
+let subst_md (_,subst,defs) =
+  List.map (fun (id,t) -> (id,subst_tactic subst t)) defs
+
+let (inMD,outMD) =
+  declare_object {(default_object "TAC-DEFINITION") with
+     cache_function  = cache_md;
+     load_function   = load_md;
+     open_function   = open_md;
+     subst_function = subst_md;
+     classify_function = (fun (_,o) -> Substitute o);       
+     export_function = (fun x -> Some x)}
+
+(* Adds a definition for tactics in the table *)
+let make_absolute_name (loc,id) =
+  let kn = Lib.make_kn id in
+  if Gmap.mem kn !mactab or is_atomic_kn kn then
+    user_err_loc (loc,"Tacinterp.add_tacdef",
+      str "There is already an Ltac named " ++ pr_id id);
+  kn
+
+let make_empty_glob_sign () =
+  { ltacvars = ([],[]); ltacrecvars = []; 
+    gsigma = Evd.empty; genv = Global.env() }
+
+let add_tacdef isrec tacl =
+(*  let isrec = if !Options.p1 then isrec else true in*)
+  let rfun = List.map (fun ((loc,id as locid),_) -> (id,make_absolute_name locid)) tacl in
+  let ist =
+    {(make_empty_glob_sign()) with ltacrecvars = if isrec then rfun else []} in
+  let gtacl =
+    List.map (fun ((_,id),def) ->
+      (id,Options.with_option strict_check (intern_tactic ist) def))
+      tacl in
+  let id0 = fst (List.hd rfun) in
+  let _ = Lib.add_leaf id0 (inMD gtacl) in
+  List.iter
+    (fun (id,_) -> Options.if_verbose msgnl (pr_id id ++ str " is defined"))
+    rfun
+
+(***************************************************************************)
+(* Other entry points *)
+
+let glob_tactic x = intern_tactic (make_empty_glob_sign ()) x
+
+let glob_tactic_env l env x = 
+  intern_tactic
+    { ltacvars = (l,[]); ltacrecvars = []; gsigma = Evd.empty; genv = env }
+    x
+
+let interp_redexp env evc r = 
+  let ist = { lfun=[]; debug=get_debug () } in
+  let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = evc } in
+  redexp_interp ist evc env (intern_redexp gist r)
+
+(***************************************************************************)
+(* Backwarding recursive needs of tactic glob/interp/eval functions *)
+
+let _ = Auto.set_extern_interp
+  (fun l -> 
+    let l = List.map (fun (id,c) -> (id,VConstr c)) l in
+    interp_tactic {lfun=l;debug=get_debug()})
+let _ = Auto.set_extern_intern_tac 
+  (fun l ->
+    Options.with_option strict_check
+    (intern_tactic {(make_empty_glob_sign()) with ltacvars=(l,[])}))
+let _ = Auto.set_extern_subst_tactic subst_tactic
+let _ = Dhyp.set_extern_interp eval_tactic
+let _ = Dhyp.set_extern_intern_tac
+  (fun t -> intern_tactic (make_empty_glob_sign()) t)
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
new file mode 100644
index 00000000..1f75b5a4
--- /dev/null
+++ b/tactics/tacinterp.mli
@@ -0,0 +1,126 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tacinterp.mli,v 1.13.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Dyn
+open Pp
+open Names
+open Proof_type
+open Tacmach
+open Tactic_debug
+open Term
+open Tacexpr
+open Genarg
+open Topconstr
+(*i*)
+
+(* Values for interpretation *)
+type value =
+  | VTactic of Util.loc * tactic  (* For mixed ML/Ltac tactics (e.g. Tauto) *)
+  | VRTactic of (goal list sigma * validation)
+  | VFun of (identifier * value) list * identifier option list * glob_tactic_expr
+  | VVoid
+  | VInteger of int
+  | VIntroPattern of intro_pattern_expr
+  | VConstr of constr
+  | VConstr_context of constr
+  | VRec of value ref
+
+(* Signature for interpretation: val\_interp and interpretation functions *)
+and interp_sign =
+  { lfun : (identifier * value) list;
+    debug : debug_info }
+
+(* Gives the identifier corresponding to an Identifier [tactic_arg] *)
+val id_of_Identifier : Environ.env -> value -> identifier
+
+(* Gives the constr corresponding to a Constr [value] *)
+val constr_of_VConstr : Environ.env -> value -> constr
+
+(* Transforms an id into a constr if possible *)
+val constr_of_id : Environ.env -> identifier -> constr
+
+(* To embed several objects in Coqast.t *)
+val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr
+val tacticOut : raw_tactic_expr -> (interp_sign -> raw_tactic_expr)
+val valueIn : value -> raw_tactic_arg
+val valueOut: raw_tactic_arg -> value
+val constrIn : constr -> constr_expr
+val constrOut : constr_expr -> constr
+
+(* Sets the debugger mode *)
+val set_debug : debug_info -> unit
+
+(* Gives the state of debug *)
+val get_debug : unit -> debug_info
+
+(* Adds a definition for tactics in the table *)
+val add_tacdef :
+  bool -> (identifier Util.located * raw_tactic_expr) list -> unit
+val add_primitive_tactic : string -> glob_tactic_expr -> unit
+
+(* Adds an interpretation function for extra generic arguments *)
+type glob_sign = {
+  ltacvars : identifier list * identifier list;
+  ltacrecvars : (identifier * Nametab.ltac_constant) list;
+  gsigma : Evd.evar_map;
+  genv : Environ.env }
+
+val add_interp_genarg :
+  string ->
+    (glob_sign -> raw_generic_argument -> glob_generic_argument) *
+    (interp_sign -> goal sigma -> glob_generic_argument -> 
+      closed_generic_argument) *
+    (Names.substitution -> glob_generic_argument -> glob_generic_argument)
+    -> unit
+
+val interp_genarg :
+  interp_sign -> goal sigma -> glob_generic_argument -> closed_generic_argument
+
+val intern_genarg :
+  glob_sign -> raw_generic_argument -> glob_generic_argument
+
+val subst_genarg :
+  Names.substitution -> glob_generic_argument -> glob_generic_argument
+
+(* Interprets any expression *)
+val val_interp : interp_sign -> goal sigma -> glob_tactic_expr -> value
+
+(* Interprets redexp arguments *)
+val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr
+  -> Tacred.red_expr
+
+(* Interprets tactic expressions *)
+val interp_tac_gen : (identifier * value) list -> 
+                 debug_info -> raw_tactic_expr -> tactic
+
+(* Initial call for interpretation *)
+val glob_tactic : raw_tactic_expr -> glob_tactic_expr
+
+val glob_tactic_env : identifier list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr
+
+val eval_tactic : glob_tactic_expr -> tactic
+
+val interp : raw_tactic_expr -> tactic
+
+val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr
+
+(* Hides interpretation for pretty-print *)
+
+val hide_interp : raw_tactic_expr -> tactic option -> tactic
+
+(* Adds an interpretation function *)
+val interp_add : string * (interp_sign -> Coqast.t -> value) -> unit
+
+(* Adds a possible existing interpretation function *)
+val overwriting_interp_add : string * (interp_sign -> Coqast.t -> value) ->
+                             unit
+
+
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
new file mode 100644
index 00000000..77898afb
--- /dev/null
+++ b/tactics/tacticals.ml
@@ -0,0 +1,457 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tacticals.ml,v 1.60.2.1 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Term
+open Termops
+open Sign
+open Declarations
+open Inductive
+open Reduction
+open Environ
+open Libnames
+open Refiner
+open Tacmach
+open Clenv
+open Pattern
+open Matching
+open Evar_refiner
+open Genarg
+open Tacexpr
+
+(******************************************)
+(*         Basic Tacticals                *)
+(******************************************)
+
+(*************************************************)
+(* Tacticals re-exported from the Refiner module.*)
+(*************************************************)
+
+let tclIDTAC         = tclIDTAC
+let tclIDTAC_MESSAGE = tclIDTAC_MESSAGE
+let tclORELSE        = tclORELSE
+let tclTHEN          = tclTHEN
+let tclTHENLIST      = tclTHENLIST
+let tclTHEN_i        = tclTHEN_i
+let tclTHENFIRST     = tclTHENFIRST
+let tclTHENLAST      = tclTHENLAST
+let tclTHENS         = tclTHENS
+let tclTHENSV        = Refiner.tclTHENSV
+let tclTHENSFIRSTn   = Refiner.tclTHENSFIRSTn
+let tclTHENSLASTn    = Refiner.tclTHENSLASTn
+let tclTHENFIRSTn    = Refiner.tclTHENFIRSTn
+let tclTHENLASTn     = Refiner.tclTHENLASTn
+let tclREPEAT        = Refiner.tclREPEAT
+let tclREPEAT_MAIN   = tclREPEAT_MAIN
+let tclFIRST         = Refiner.tclFIRST
+let tclSOLVE         = Refiner.tclSOLVE
+let tclTRY           = Refiner.tclTRY
+let tclINFO          = Refiner.tclINFO
+let tclCOMPLETE      = Refiner.tclCOMPLETE
+let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
+let tclFAIL          = Refiner.tclFAIL
+let tclDO            = Refiner.tclDO
+let tclPROGRESS      = Refiner.tclPROGRESS
+let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
+let tclNOTSAMEGOAL   = Refiner.tclNOTSAMEGOAL
+let tclTHENTRY       = tclTHENTRY
+let tclIFTHENELSE    = tclIFTHENELSE
+let tclIFTHENSELSE   = tclIFTHENSELSE
+let tclIFTHENSVELSE   = tclIFTHENSVELSE
+
+let unTAC            = unTAC
+
+(* [rclTHENSEQ [t1;..;tn] is equivalent to t1;..;tn *)
+let tclTHENSEQ = List.fold_left tclTHEN tclIDTAC
+
+(* map_tactical f [x1..xn] = (f x1);(f x2);...(f xn) *)
+(* tclMAP f [x1..xn] = (f x1);(f x2);...(f xn) *)
+let tclMAP tacfun l = 
+  List.fold_right (fun x -> (tclTHEN (tacfun x))) l tclIDTAC
+
+(* apply a tactic to the nth element of the signature  *)
+
+let tclNTH_HYP m (tac : constr->tactic) gl =
+  tac (try mkVar(let (id,_,_) = List.nth (pf_hyps gl) (m-1) in id) 
+       with Failure _ -> error "No such assumption") gl
+
+(* apply a tactic to the last element of the signature  *)
+
+let tclLAST_HYP = tclNTH_HYP 1
+
+let tclTRY_sign (tac : constr->tactic) sign gl =
+  let rec arec = function
+    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | [s]     -> tac (mkVar s) (*added in order to get useful error messages *)
+    | (s::sl) -> tclORELSE (tac (mkVar s)) (arec sl) 
+  in 
+  arec (ids_of_named_context sign) gl
+
+let tclTRY_HYPS (tac : constr->tactic) gl = 
+  tclTRY_sign tac (pf_hyps gl) gl
+
+(***************************************)
+(*           Clause Tacticals          *)
+(***************************************)
+
+(* The following functions introduce several tactic combinators and
+   functions useful for working with clauses. A clause is either None
+   or (Some id), where id is an identifier. This type is useful for
+   defining tactics that may be used either to transform the
+   conclusion (None) or to transform a hypothesis id (Some id).  --
+   --Eduardo (8/8/97) 
+*)
+
+(* The type of clauses *)
+
+type simple_clause = identifier gsimple_clause
+type clause = identifier gclause
+
+let allClauses = { onhyps=None; onconcl=true; concl_occs=[] }
+let allHyps = { onhyps=None; onconcl=false; concl_occs=[] }
+let onHyp id =
+  { onhyps=Some[(id,[],(InHyp, ref None))]; onconcl=false; concl_occs=[] }
+let onConcl = { onhyps=Some[]; onconcl=true; concl_occs=[] }
+
+let simple_clause_list_of cl gls =
+  let hyps =
+    match cl.onhyps with 
+        None ->
+          List.map (fun id -> Some(id,[],(InHyp,ref None))) (pf_ids_of_hyps gls)
+      | Some l -> List.map (fun h -> Some h) l in
+  if cl.onconcl then None::hyps else hyps
+
+
+(* OR-branch *)
+let tryClauses tac cl gls = 
+  let rec firstrec = function
+    | []      -> tclFAIL 0 "no applicable hypothesis"
+    | [cls]   -> tac cls (* added in order to get a useful error message *)
+    | cls::tl -> (tclORELSE (tac cls) (firstrec tl))
+  in
+  let hyps = simple_clause_list_of cl gls in
+  firstrec hyps gls
+
+(* AND-branch *)
+let onClauses tac cl gls = 
+  let hyps = simple_clause_list_of cl gls in
+  tclMAP tac hyps gls
+
+(* AND-branch reverse order*)
+let onClausesLR tac cl gls = 
+  let hyps = simple_clause_list_of cl gls in
+  tclMAP tac (List.rev hyps) gls
+
+(* A clause corresponding to the |n|-th hypothesis or None *)
+
+let nth_clause n gl =
+  if n = 0 then 
+    onConcl
+  else if n < 0 then 
+    let id = List.nth (List.rev (pf_ids_of_hyps gl)) (-n-1) in 
+    onHyp id
+  else 
+    let id = List.nth (pf_ids_of_hyps gl) (n-1) in 
+    onHyp id
+
+(* Gets the conclusion or the type of a given hypothesis *)
+
+let clause_type cls gl =
+  match simple_clause_of cls with
+    | None    -> pf_concl gl
+    | Some (id,_,_) -> pf_get_hyp_typ gl id
+
+(* Functions concerning matching of clausal environments *)
+
+let pf_is_matching gls pat n =
+  let (wc,_) = startWalk gls in 
+  is_matching_conv (w_env wc) (w_Underlying wc) pat n
+
+let pf_matches gls pat n =
+  matches_conv (pf_env gls) (project gls) pat n
+
+(* [OnCL clausefinder clausetac]
+ * executes the clausefinder to find the clauses, and then executes the
+ * clausetac on the clause so obtained. *)
+
+let onCL cfind cltac gl = cltac (cfind gl) gl
+
+
+(* [OnHyps hypsfinder hypstac]
+ * idem [OnCL] but only for hypotheses, not for conclusion *)
+
+let onHyps find tac gl = tac (find gl) gl
+
+
+
+(* Create a clause list with all the hypotheses from the context, occuring
+   after id *)
+
+let afterHyp id gl =
+  fst (list_splitby (fun (hyp,_,_) -> hyp = id) (pf_hyps gl))
+    
+
+(* Create a singleton clause list with the last hypothesis from then context *)
+
+let lastHyp gl = List.hd (pf_ids_of_hyps gl)
+
+
+(* Create a clause list with the n last hypothesis from then context *)
+
+let nLastHyps n gl =
+  try list_firstn n (pf_hyps gl)
+  with Failure "firstn" -> error "Not enough hypotheses in the goal"
+
+
+let onClause t cls gl  = t cls gl
+let tryAllClauses  tac = tryClauses tac allClauses
+let onAllClauses   tac = onClauses tac allClauses
+let onAllClausesLR tac = onClausesLR tac allClauses
+let onNthLastHyp n tac gls = tac (nth_clause n gls) gls
+
+let tryAllHyps     tac =
+  tryClauses (function Some(id,_,_) -> tac id | _ -> assert false) allHyps
+let onNLastHyps n  tac     = onHyps (nLastHyps n) (tclMAP tac)
+let onLastHyp      tac gls = tac (lastHyp gls) gls
+
+let clauseTacThen tac continuation =
+  (fun cls -> (tclTHEN (tac cls) continuation))
+
+let if_tac pred tac1 tac2 gl =
+  if pred gl then tac1 gl else tac2 gl
+
+let ifOnClause pred tac1 tac2 cls gl =
+  if pred (cls,clause_type cls gl) then
+    tac1 cls gl
+  else 
+    tac2 cls gl
+
+let ifOnHyp pred tac1 tac2 id gl =
+  if pred (id,pf_get_hyp_typ gl id) then
+    tac1 id gl
+  else 
+    tac2 id gl
+
+(***************************************)
+(*         Elimination Tacticals       *)
+(***************************************)
+
+(* The following tacticals allow to apply a tactic to the
+   branches generated by the application of an elimination
+  tactic. 
+
+  Two auxiliary types --branch_args and branch_assumptions-- are
+  used to keep track of some information about the ``branches'' of 
+  the elimination. *)
+
+type branch_args = {
+  ity        : inductive;   (* the type we were eliminating on *)
+  largs      : constr list; (* its arguments *)
+  branchnum  : int;         (* the branch number *)
+  pred       : constr;      (* the predicate we used *)
+  nassums    : int;         (* the number of assumptions to be introduced *)
+  branchsign : bool list;   (* the signature of the branch.
+                               true=recursive argument, false=constant *)
+  branchnames : intro_pattern_expr list}
+
+type branch_assumptions = {
+  ba        : branch_args;     (* the branch args *)
+  assums    : named_context}   (* the list of assumptions introduced *)
+
+let compute_induction_names n = function
+  | None ->
+      Array.make n []
+  | Some (IntroOrAndPattern names) when List.length names = n ->
+      Array.of_list names
+  | _ ->
+      errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names")
+
+let compute_construtor_signatures isrec (_,k as ity) =
+  let rec analrec c recargs =
+    match kind_of_term c, recargs with 
+    | Prod (_,_,c), recarg::rest ->
+	let b = match dest_recarg recarg with
+	  | Norec | Imbr _  -> false
+	  | Mrec j  -> isrec & j=k
+	in b :: (analrec c rest)
+    | LetIn (_,_,_,c), rest -> false :: (analrec c rest)
+    | _, [] -> []
+    | _ -> anomaly "compute_construtor_signatures"
+  in 
+  let (mib,mip) = Global.lookup_inductive ity in
+  let n = mip.mind_nparams in
+  let lc =
+    Array.map (fun c -> snd (decompose_prod_n_assum n c)) mip.mind_nf_lc in
+  let lrecargs = dest_subterms mip.mind_recargs in
+  array_map2 analrec lc lrecargs
+
+let elimination_sort_of_goal gl = 
+  match kind_of_term (hnf_type_of gl (pf_concl gl)) with 
+    | Sort s ->
+	(match s with
+	   | Prop Null -> InProp
+	   | Prop Pos -> InSet
+	   | Type _ -> InType)
+    | _        -> anomaly "goal should be a type"
+
+let elimination_sort_of_hyp id gl = 
+  match kind_of_term (hnf_type_of gl (pf_get_hyp_typ gl id)) with 
+    | Sort s ->
+	(match s with
+	   | Prop Null -> InProp
+	   | Prop Pos -> InSet
+	   | Type _ -> InType)
+    | _        -> anomaly "goal should be a type"
+
+
+(* Find the right elimination suffix corresponding to the sort of the goal *)
+(* c should be of type A1->.. An->B with B an inductive definition *)
+
+let last_arg c = match kind_of_term c with
+  | App (f,cl) -> array_last cl
+  | _ -> anomaly "last_arg"
+
+let general_elim_then_using 
+  elim isrec allnames tac predicate (indbindings,elimbindings) c gl =
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  (* applying elimination_scheme just a little modified *)
+  let (wc,kONT)  = startWalk gl in
+  let indclause  = mk_clenv_from wc (c,t) in
+  let indclause' = clenv_constrain_with_bindings indbindings indclause in
+  let elimclause = mk_clenv_from () (elim,w_type_of wc elim) in
+  let indmv = 
+    match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+      | Meta mv -> mv
+      | _         -> error "elimination"
+  in
+  let pmv =
+    let p, _ = decompose_app (clenv_template_type elimclause).rebus in
+    match kind_of_term p with
+      | Meta p -> p
+      | _ ->
+	  let name_elim =
+	    match kind_of_term elim with
+	      | Const kn -> string_of_kn kn
+	      | Var id -> string_of_id id
+	      | _ -> "\b"
+	  in
+	  error ("The elimination combinator " ^ name_elim ^ " is not known") 
+  in
+  let elimclause' = clenv_fchain indmv elimclause indclause' in
+  let elimclause' = clenv_constrain_with_bindings elimbindings elimclause' in
+  let branchsigns = compute_construtor_signatures isrec ity in
+  let brnames = compute_induction_names (Array.length branchsigns) allnames in
+  let after_tac ce i gl =
+    let (hd,largs) = decompose_app (clenv_template_type ce).rebus in
+    let ba = { branchsign = branchsigns.(i);
+               branchnames = brnames.(i);
+               nassums = 
+		 List.fold_left 
+                   (fun acc b -> if b then acc+2 else acc+1)
+                   0 branchsigns.(i);
+               branchnum = i+1;
+               ity = ity;
+               largs = List.map (clenv_instance_term ce) largs;
+               pred = clenv_instance_term ce hd }
+    in 
+    tac ba gl
+  in
+  let branchtacs ce = Array.init (Array.length branchsigns) (after_tac ce) in
+  let elimclause' =
+    match predicate with
+       | None   -> elimclause'
+       | Some p -> clenv_assign pmv p elimclause'
+  in 
+  elim_res_pf_THEN_i kONT elimclause' branchtacs gl
+
+
+let elimination_then_using tac predicate (indbindings,elimbindings) c gl = 
+  let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let elim =
+    Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in
+  general_elim_then_using
+    elim true None tac predicate (indbindings,elimbindings) c gl
+
+
+let elimination_then tac        = elimination_then_using tac None 
+let simple_elimination_then tac = elimination_then tac ([],[])
+
+let case_then_using allnames tac predicate (indbindings,elimbindings) c gl =
+  (* finding the case combinator *)
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma = project gl in 
+  let sort  = elimination_sort_of_goal gl  in
+  let elim  = Indrec.make_case_dep (pf_env gl) sigma ity sort in  
+  general_elim_then_using 
+    elim false allnames tac predicate (indbindings,elimbindings) c gl
+
+let case_nodep_then_using allnames tac predicate (indbindings,elimbindings)
+  c gl =
+  (* finding the case combinator *)
+  let (ity,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma = project gl in 
+  let sort  = elimination_sort_of_goal gl  in
+  let elim  = Indrec.make_case_nodep (pf_env gl) sigma ity sort in  
+  general_elim_then_using 
+    elim false allnames tac predicate (indbindings,elimbindings) c gl
+
+
+let make_elim_branch_assumptions ba gl =   
+  let rec makerec (assums,cargs,constargs,recargs,indargs) lb lc =
+    match lb,lc with 
+      | ([], _) -> 
+          { ba = ba;
+            assums    = assums}
+      | ((true::tl), ((idrec,_,_ as recarg)::(idind,_,_ as indarg)::idtl)) ->
+	  makerec (recarg::indarg::assums,
+		   idrec::cargs,
+		   idrec::recargs,
+		   constargs,
+		   idind::indargs) tl idtl
+      | ((false::tl), ((id,_,_ as constarg)::idtl))      ->
+	  makerec (constarg::assums,
+		   id::cargs,
+		   id::constargs,
+		   recargs,
+		   indargs) tl idtl
+      | (_, _) -> error "make_elim_branch_assumptions"
+  in 
+  makerec ([],[],[],[],[]) ba.branchsign
+    (try list_firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly "make_elim_branch_assumptions")
+
+let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl
+
+let make_case_branch_assumptions ba gl =
+  let rec makerec (assums,cargs,constargs,recargs) p_0 p_1 =
+    match p_0,p_1 with 
+      | ([], _) -> 
+          { ba = ba;
+            assums    = assums}
+      | ((true::tl), ((idrec,_,_ as recarg)::idtl)) ->
+	  makerec (recarg::assums,
+		   idrec::cargs,
+		   idrec::recargs,
+		   constargs) tl idtl
+      | ((false::tl), ((id,_,_ as constarg)::idtl)) ->
+	  makerec (constarg::assums,
+		   id::cargs,
+		   recargs,
+		   id::constargs) tl idtl
+      | (_, _) -> error "make_case_branch_assumptions"
+  in 
+  makerec ([],[],[],[]) ba.branchsign
+    (try list_firstn ba.nassums (pf_hyps gl)
+     with Failure _ -> anomaly "make_case_branch_assumptions")
+
+let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl
+
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
new file mode 100644
index 00000000..2cb63b40
--- /dev/null
+++ b/tactics/tacticals.mli
@@ -0,0 +1,162 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tacticals.mli,v 1.38.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Sign
+open Tacmach
+open Proof_type
+open Clenv
+open Reduction
+open Pattern
+open Genarg
+open Tacexpr
+(*i*)
+
+(* Tacticals i.e. functions from tactics to tactics. *)
+
+val tclIDTAC         : tactic
+val tclIDTAC_MESSAGE : string -> tactic
+val tclORELSE        : tactic -> tactic -> tactic
+val tclTHEN          : tactic -> tactic -> tactic
+val tclTHENSEQ       : tactic list -> tactic
+val tclTHENLIST      : tactic list -> tactic
+val tclTHEN_i        : tactic -> (int -> tactic) -> tactic
+val tclTHENFIRST     : tactic -> tactic -> tactic
+val tclTHENLAST      : tactic -> tactic -> tactic
+val tclTHENS         : tactic -> tactic list -> tactic
+val tclTHENSV        : tactic -> tactic array -> tactic
+val tclTHENSLASTn    : tactic -> tactic -> tactic array -> tactic
+val tclTHENLASTn     : tactic -> tactic array -> tactic
+val tclTHENSFIRSTn   : tactic -> tactic array -> tactic -> tactic
+val tclTHENFIRSTn    : tactic -> tactic array -> tactic
+val tclREPEAT        : tactic -> tactic
+val tclREPEAT_MAIN   : tactic -> tactic
+val tclFIRST         : tactic list -> tactic
+val tclSOLVE         : tactic list -> tactic
+val tclTRY           : tactic -> tactic
+val tclINFO          : tactic -> tactic
+val tclCOMPLETE      : tactic -> tactic
+val tclAT_LEAST_ONCE : tactic -> tactic
+val tclFAIL          : int -> string -> tactic
+val tclDO            : int -> tactic -> tactic
+val tclPROGRESS      : tactic -> tactic
+val tclWEAK_PROGRESS : tactic -> tactic
+val tclNOTSAMEGOAL   : tactic -> tactic
+val tclTHENTRY       : tactic -> tactic -> tactic
+
+val tclNTH_HYP       : int -> (constr -> tactic) -> tactic
+val tclMAP           : ('a -> tactic) -> 'a list -> tactic
+val tclLAST_HYP      : (constr -> tactic) -> tactic
+val tclTRY_sign      : (constr -> tactic) -> named_context -> tactic
+val tclTRY_HYPS      : (constr -> tactic) -> tactic
+
+val tclIFTHENELSE    : tactic -> tactic -> tactic -> tactic
+val tclIFTHENSELSE   : tactic -> tactic list -> tactic -> tactic
+val tclIFTHENSVELSE  : tactic -> tactic array -> tactic -> tactic
+
+
+
+val unTAC            : tactic -> goal sigma -> proof_tree sigma
+
+(*s Clause tacticals. *)
+
+type simple_clause = identifier gsimple_clause
+type clause = identifier gclause
+
+val allClauses : 'a gclause
+val allHyps : clause
+val onHyp : identifier -> clause
+val onConcl : 'a gclause
+
+val nth_clause  : int -> goal sigma -> clause
+val clause_type : clause -> goal sigma -> constr
+val simple_clause_list_of : clause -> goal sigma -> simple_clause list
+
+val pf_matches : goal sigma -> constr_pattern -> constr -> patvar_map
+val pf_is_matching : goal sigma -> constr_pattern -> constr -> bool
+
+val afterHyp   : identifier -> goal sigma -> named_context
+val lastHyp    : goal sigma -> identifier
+val nLastHyps  : int -> goal sigma -> named_context
+
+val onCL           : (goal sigma -> clause) -> 
+                     (clause -> tactic) -> tactic
+val tryAllClauses  : (simple_clause -> tactic) -> tactic
+val onAllClauses   : (simple_clause -> tactic) -> tactic
+val onClause       : (clause -> tactic) -> clause -> tactic
+val onClauses      : (simple_clause -> tactic) -> clause -> tactic
+val onAllClausesLR : (simple_clause -> tactic) -> tactic
+val onNthLastHyp   : int -> (clause -> tactic) -> tactic
+val clauseTacThen  : (clause -> tactic) -> tactic -> clause -> tactic
+val if_tac         : (goal sigma -> bool) -> tactic -> (tactic) -> tactic
+val ifOnClause     : 
+  (clause * types -> bool) ->
+    (clause -> tactic) -> (clause -> tactic) -> clause -> tactic
+val ifOnHyp        : 
+  (identifier * types -> bool) ->
+    (identifier -> tactic) -> (identifier -> tactic) -> identifier -> tactic
+
+val onHyps         : (goal sigma -> named_context) -> 
+                     (named_context -> tactic) -> tactic
+val tryAllHyps     : (identifier -> tactic) -> tactic
+val onNLastHyps    : int -> (named_declaration -> tactic) -> tactic
+val onLastHyp      : (identifier -> tactic) -> tactic
+
+(*s Elimination tacticals. *)
+
+type branch_args = { 
+  ity        : inductive;   (* the type we were eliminating on *)
+  largs      : constr list; (* its arguments *)
+  branchnum  : int;         (* the branch number *)
+  pred       : constr;      (* the predicate we used *)
+  nassums    : int;         (* the number of assumptions to be introduced *)
+  branchsign : bool list;   (* the signature of the branch.
+                               true=recursive argument, false=constant *)
+  branchnames : intro_pattern_expr list}
+
+type branch_assumptions = {
+  ba        : branch_args;     (* the branch args *)
+  assums    : named_context}   (* the list of assumptions introduced *)
+
+(* Useful for "as intro_pattern" modifier *)
+val compute_induction_names : 
+  int -> intro_pattern_expr option -> intro_pattern_expr list array
+
+val elimination_sort_of_goal : goal sigma -> sorts_family
+val elimination_sort_of_hyp  : identifier -> goal sigma -> sorts_family
+
+val general_elim_then_using :
+  constr -> (* isrec: *) bool -> intro_pattern_expr option ->
+    (branch_args -> tactic) -> constr option -> 
+      (arg_bindings * arg_bindings) -> constr -> tactic
+	  
+val elimination_then_using :
+  (branch_args -> tactic) -> constr option -> 
+    (arg_bindings * arg_bindings) -> constr -> tactic
+
+val elimination_then :
+  (branch_args -> tactic) -> 
+    (arg_bindings * arg_bindings) -> constr -> tactic
+
+val case_then_using :
+  intro_pattern_expr option -> (branch_args -> tactic) -> 
+    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+
+val case_nodep_then_using :
+  intro_pattern_expr option -> (branch_args -> tactic) -> 
+    constr option -> (arg_bindings * arg_bindings) -> constr -> tactic
+
+val simple_elimination_then :
+  (branch_args -> tactic) -> constr -> tactic
+
+val elim_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
+val case_on_ba : (branch_assumptions -> tactic) -> branch_args  -> tactic 
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
new file mode 100644
index 00000000..cab4f025
--- /dev/null
+++ b/tactics/tactics.ml
@@ -0,0 +1,1922 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: tactics.ml,v 1.162.2.2 2004/07/16 19:30:55 herbelin Exp $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Sign
+open Term
+open Termops
+open Declarations
+open Inductive
+open Inductiveops
+open Reductionops
+open Environ
+open Libnames
+open Evd
+open Pfedit
+open Tacred
+open Rawterm
+open Tacmach
+open Proof_trees
+open Proof_type
+open Logic
+open Evar_refiner
+open Clenv
+open Refiner
+open Tacticals
+open Hipattern
+open Coqlib
+open Nametab
+open Genarg
+open Tacexpr
+open Decl_kinds
+
+exception Bound
+
+let rec nb_prod x =
+  let rec count n c =
+    match kind_of_term c with
+        Prod(_,_,t) -> count (n+1) t
+      | LetIn(_,a,_,t) -> count n (subst1 a t)
+      | Cast(c,_) -> count n c
+      | _ -> n
+  in count 0 x
+
+(*********************************************)
+(*                 Tactics                   *)
+(*********************************************)
+
+(****************************************)
+(* General functions                    *)
+(****************************************)
+
+(*
+let get_pairs_from_bindings = 
+  let pair_from_binding = function  
+    | [(Bindings binds)] -> binds
+    | _                  -> error "not a binding list!"
+  in 
+  List.map pair_from_binding
+*)
+
+let string_of_inductive c = 
+  try match kind_of_term c with
+  | Ind ind_sp -> 
+      let (mib,mip) = Global.lookup_inductive ind_sp in 
+      string_of_id mip.mind_typename
+  | _ -> raise Bound
+  with Bound -> error "Bound head variable"
+
+let rec head_constr_bound t l =
+  let t = strip_outer_cast(collapse_appl t) in
+  match kind_of_term t with
+    | Prod (_,_,c2)  -> head_constr_bound c2 l 
+    | LetIn (_,_,_,c2) -> head_constr_bound c2 l 
+    | App (f,args)  -> 
+	head_constr_bound f (Array.fold_right (fun a l -> a::l) args l)
+    | Const _        -> t::l
+    | Ind _       -> t::l
+    | Construct _ -> t::l
+    | Var _          -> t::l
+    | _                -> raise Bound
+
+let head_constr c = 
+  try head_constr_bound c [] with Bound -> error "Bound head variable"
+
+(*
+let bad_tactic_args s l =
+  raise (RefinerError (BadTacticArgs (s,l)))
+*)
+
+(******************************************)
+(*           Primitive tactics            *)
+(******************************************)
+
+let introduction    = Tacmach.introduction 
+let intro_replacing = Tacmach.intro_replacing 
+let internal_cut    = Tacmach.internal_cut
+let internal_cut_rev = Tacmach.internal_cut_rev
+let refine          = Tacmach.refine
+let convert_concl   = Tacmach.convert_concl
+let convert_hyp     = Tacmach.convert_hyp
+let thin            = Tacmach.thin 
+let thin_body       = Tacmach.thin_body
+
+(* Moving hypotheses *)
+let move_hyp        = Tacmach.move_hyp 
+
+(* Renaming hypotheses *)
+let rename_hyp      = Tacmach.rename_hyp
+
+(* Refine as a fixpoint *)
+let mutual_fix = Tacmach.mutual_fix
+
+let fix ido n = match ido with
+  | None -> mutual_fix (Pfedit.get_current_proof_name ()) n []
+  | Some id -> mutual_fix id n []
+
+(* Refine as a cofixpoint *)
+let mutual_cofix = Tacmach.mutual_cofix
+
+let cofix = function
+  | None -> mutual_cofix (Pfedit.get_current_proof_name ()) []
+  | Some id -> mutual_cofix id []
+
+(**************************************************************)
+(*          Reduction and conversion tactics                  *)
+(**************************************************************)
+
+type tactic_reduction = env -> evar_map -> constr -> constr
+
+(* The following two tactics apply an arbitrary
+   reduction function either to the conclusion or to a 
+   certain hypothesis *)
+
+let reduct_in_concl redfun gl = 
+  convert_concl_no_check (pf_reduce redfun gl (pf_concl gl)) gl
+
+let reduct_in_hyp redfun (id,_,(where,where')) gl =
+  let (_,c, ty) = pf_get_hyp gl id in
+  let redfun' = (*under_casts*) (pf_reduce redfun gl) in
+  match c with
+  | None -> 
+      if where = InHypValueOnly then
+	errorlabstrm "" (pr_id id ++ str "has no value");
+      if Options.do_translate () then where' := Some where;
+      convert_hyp_no_check (id,None,redfun' ty) gl
+  | Some b ->
+      let where =
+	if !Options.v7 & where = InHyp then InHypValueOnly else where in
+      let b' = if where <> InHypTypeOnly then redfun' b else b in
+      let ty' =	if where <> InHypValueOnly then redfun' ty else ty in
+      if Options.do_translate () then where' := Some where;
+      convert_hyp_no_check (id,Some b',ty') gl
+
+let reduct_option redfun = function
+  | Some id -> reduct_in_hyp   redfun id 
+  | None    -> reduct_in_concl redfun 
+
+(* The following tactic determines whether the reduction
+   function has to be applied to the conclusion or
+   to the hypotheses. *) 
+
+let redin_combinator redfun =
+  onClauses (reduct_option redfun)
+
+(* Now we introduce different instances of the previous tacticals *)
+let change_and_check cv_pb t env sigma c =
+  if is_fconv cv_pb env sigma t c then 
+    t
+  else 
+    errorlabstrm "convert-check-hyp" (str "Not convertible")
+
+(* Use cumulutavity only if changing the conclusion not a subterm *)
+let change_on_subterm cv_pb t = function
+  | None -> change_and_check cv_pb t
+  | Some occl -> contextually false occl (change_and_check CONV t) 
+
+let change_in_concl occl t = reduct_in_concl (change_on_subterm CUMUL t occl) 
+let change_in_hyp occl t   = reduct_in_hyp (change_on_subterm CONV t occl)
+
+let change_option occl t = function
+    Some id -> change_in_hyp occl t id
+  | None -> change_in_concl occl t
+
+let change occl c cls =
+  (match cls, occl with
+      ({onhyps=(Some(_::_::_)|None)}|{onhyps=Some(_::_);onconcl=true}),
+      Some _ ->
+	error "No occurrences expected when changing several hypotheses"
+    | _ -> ());
+  onClauses (change_option occl c) cls
+
+(* Pour usage interne (le niveau User est pris en compte par reduce) *)
+let red_in_concl        = reduct_in_concl red_product
+let red_in_hyp          = reduct_in_hyp   red_product
+let red_option          = reduct_option   red_product
+let hnf_in_concl        = reduct_in_concl hnf_constr
+let hnf_in_hyp          = reduct_in_hyp   hnf_constr
+let hnf_option          = reduct_option   hnf_constr
+let simpl_in_concl      = reduct_in_concl nf
+let simpl_in_hyp        = reduct_in_hyp   nf
+let simpl_option        = reduct_option   nf
+let normalise_in_concl  = reduct_in_concl compute
+let normalise_in_hyp    = reduct_in_hyp   compute
+let normalise_option    = reduct_option   compute
+let unfold_in_concl loccname   = reduct_in_concl (unfoldn loccname) 
+let unfold_in_hyp   loccname   = reduct_in_hyp   (unfoldn loccname) 
+let unfold_option   loccname   = reduct_option   (unfoldn loccname) 
+let pattern_option l = reduct_option (pattern_occs l)
+
+(* A function which reduces accordingly to a reduction expression,
+   as the command Eval does. *)
+
+let reduce redexp cl goal =
+  redin_combinator (reduction_of_redexp redexp) cl goal
+
+(* Unfolding occurrences of a constant *)
+
+let unfold_constr = function 
+  | ConstRef sp -> unfold_in_concl [[],EvalConstRef sp]
+  | VarRef id -> unfold_in_concl [[],EvalVarRef id]
+  | _ -> errorlabstrm "unfold_constr" (str "Cannot unfold a non-constant.")
+
+(*******************************************)
+(*         Introduction tactics            *)
+(*******************************************)
+
+let fresh_id avoid id gl =
+  next_global_ident_away true id (avoid@(pf_ids_of_hyps gl))
+
+let id_of_name_with_default s = function
+  | Anonymous -> id_of_string s
+  | Name id   -> id
+
+let default_id gl = function
+  | (name,None,t) ->
+      (match kind_of_term (pf_whd_betadeltaiota gl (pf_type_of gl t)) with
+	| Sort (Prop _) -> (id_of_name_with_default "H" name)
+	| Sort (Type _) -> (id_of_name_with_default "X" name)
+	| _                   -> anomaly "Wrong sort")
+  | (name,Some b,_) -> id_of_name_using_hdchar (pf_env gl) b name
+
+(* Non primitive introduction tactics are treated by central_intro
+   There is possibly renaming, with possibly names to avoid and 
+   possibly a move to do after the introduction *)
+
+type intro_name_flag =
+  | IntroAvoid of identifier list
+  | IntroBasedOn of identifier * identifier list
+  | IntroMustBe of identifier
+
+let find_name decl gl = function
+  | IntroAvoid idl        -> 
+      let id = fresh_id idl (default_id gl decl) gl in id
+  | IntroBasedOn (id,idl) -> fresh_id idl id gl
+  | IntroMustBe id        -> 
+      let id' = fresh_id [] id gl in
+      if id' <> id then error ((string_of_id id)^" is already used");
+      id'
+
+let build_intro_tac id = function
+  | None      -> introduction id
+  | Some dest -> tclTHEN (introduction id) (move_hyp true id dest)
+
+let rec intro_gen name_flag move_flag force_flag gl =
+  match kind_of_term (pf_concl gl) with
+    | Prod (name,t,_) -> 
+	build_intro_tac (find_name (name,None,t) gl name_flag) move_flag gl
+    | LetIn (name,b,t,_) ->
+	build_intro_tac (find_name (name,Some b,t) gl name_flag) move_flag gl
+    | _ -> 
+	if not force_flag then raise (RefinerError IntroNeedsProduct);
+	try
+	  tclTHEN
+	    (reduce (Red true) onConcl)
+	    (intro_gen name_flag move_flag force_flag) gl
+	with Redelimination ->
+	  errorlabstrm "Intro" (str "No product even after head-reduction")
+
+let intro_mustbe_force id = intro_gen (IntroMustBe id) None true
+let intro_using id = intro_gen (IntroBasedOn (id,[])) None false
+let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag
+let intro = intro_force false
+let introf = intro_force true
+
+let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true
+
+(* For backwards compatibility *)
+let central_intro = intro_gen
+
+(**** Multiple introduction tactics ****)
+
+let rec intros_using = function
+    []      -> tclIDTAC
+   | str::l  -> tclTHEN (intro_using str) (intros_using l)
+
+let intros = tclREPEAT (intro_force false)
+
+let intro_erasing id = tclTHEN (thin [id]) (intro_using id)
+
+let intros_replacing ids gls = 
+  let rec introrec = function
+    | [] -> tclIDTAC
+    | id::tl ->
+	(tclTHEN (tclORELSE (intro_replacing id)
+		    (tclORELSE (intro_erasing id)   (* ?? *)
+                       (intro_using id)))
+           (introrec tl))
+  in 
+  introrec ids gls
+
+(* User-level introduction tactics *)
+
+let intro_move idopt idopt' = match idopt with
+  | None -> intro_gen (IntroAvoid []) idopt' true
+  | Some id -> intro_gen (IntroMustBe id) idopt' true
+
+let pf_lookup_hypothesis_as_renamed env ccl = function
+  | AnonHyp n -> pf_lookup_index_as_renamed env ccl n
+  | NamedHyp id -> pf_lookup_name_as_renamed env ccl id
+
+let pf_lookup_hypothesis_as_renamed_gen red h gl =
+  let env = pf_env gl in
+  let rec aux ccl =
+    match pf_lookup_hypothesis_as_renamed env ccl h with
+      | None when red ->
+          aux (reduction_of_redexp (Red true) env (project gl) ccl)
+      | x -> x
+  in
+  try aux (pf_concl gl)
+  with Redelimination -> None
+
+let is_quantified_hypothesis id g =
+  match pf_lookup_hypothesis_as_renamed_gen true (NamedHyp id) g with
+    | Some _ -> true
+    | None -> false
+
+let msg_quantified_hypothesis = function
+  | NamedHyp id -> 
+      str "hypothesis " ++ pr_id id
+  | AnonHyp n ->
+      int n ++ str (match n with 1 -> "st" | 2 -> "nd" | _ -> "th") ++
+      str " non dependent hypothesis"
+
+let depth_of_quantified_hypothesis red h gl =
+  match pf_lookup_hypothesis_as_renamed_gen red h gl with
+    | Some depth -> depth
+    | None ->
+        errorlabstrm "lookup_quantified_hypothesis" 
+          (str "No " ++ msg_quantified_hypothesis h ++
+	  str " in current goal" ++
+	  if red then str " even after head-reduction" else mt ())
+
+let intros_until_gen red h g =
+  tclDO (depth_of_quantified_hypothesis red h g) intro g
+
+let intros_until_id id = intros_until_gen true (NamedHyp id)
+let intros_until_n_gen red n = intros_until_gen red (AnonHyp n)
+
+let intros_until = intros_until_gen true
+let intros_until_n = intros_until_n_gen true
+let intros_until_n_wored = intros_until_n_gen false
+
+let try_intros_until tac = function
+  | NamedHyp id -> tclTHEN (tclTRY (intros_until_id id)) (tac id)
+  | AnonHyp n -> tclTHEN (intros_until_n n) (onLastHyp tac)
+
+let rec intros_move = function
+  | [] -> tclIDTAC
+  | (hyp,destopt) :: rest ->
+      tclTHEN (intro_gen (IntroMustBe hyp) destopt false)
+	(intros_move rest)
+
+let dependent_in_decl a (_,c,t) =
+  match c with
+    | None -> dependent a t
+    | Some body -> dependent a body || dependent a t
+
+let move_to_rhyp rhyp gl =
+  let rec get_lhyp lastfixed depdecls = function
+    | [] ->
+	(match rhyp with
+	   | None -> lastfixed
+      	   | Some h -> anomaly ("Hypothesis should occur: "^ (string_of_id h)))
+    | (hyp,c,typ) as ht :: rest ->
+	if Some hyp = rhyp then 
+	  lastfixed
+	else if List.exists (occur_var_in_decl (pf_env gl) hyp) depdecls then 
+	  get_lhyp lastfixed (ht::depdecls) rest
+        else
+	  get_lhyp (Some hyp) depdecls rest
+  in
+  let sign = pf_hyps gl in
+  let (hyp,c,typ as decl) = List.hd sign in
+  match get_lhyp None [decl] (List.tl sign) with
+    | None -> tclIDTAC gl
+    | Some hypto -> move_hyp true hyp hypto gl
+
+let rec intros_rmove = function
+  | [] -> tclIDTAC
+  | (hyp,destopt) :: rest ->
+      tclTHENLIST [ introduction hyp;
+ 		    move_to_rhyp destopt;
+		    intros_rmove rest ]
+
+(****************************************************)
+(*            Resolution tactics                    *)
+(****************************************************)
+
+(*  Refinement tactic: unification with the head of the head normal form
+ *  of the type of a term. *)
+
+let apply_type hdcty argl gl =
+  refine (applist (mkCast (mkMeta (new_meta()),hdcty),argl)) gl
+    
+let apply_term hdc argl gl =
+  refine (applist (hdc,argl)) gl
+
+let bring_hyps hyps = 
+  if hyps = [] then Refiner.tclIDTAC
+  else
+    (fun gl ->
+      let newcl = List.fold_right mkNamedProd_or_LetIn hyps (pf_concl gl) in
+      let f = mkCast (mkMeta (new_meta()),newcl) in
+      refine_no_check (mkApp (f, instance_from_named_context hyps)) gl)
+
+(* Resolution with missing arguments *)
+
+let apply_with_bindings (c,lbind) gl = 
+  let apply = 
+    match kind_of_term c with 
+      | Lambda _ -> res_pf_cast 
+      | _ -> res_pf 
+  in 
+  let (wc,kONT) = startWalk gl in
+  (* The actual type of the theorem. It will be matched against the
+  goal. If this fails, then the head constant will be unfolded step by
+  step. *)
+  let thm_ty0 = nf_betaiota (w_type_of wc c) in
+  let rec try_apply thm_ty =
+    try
+      let n = nb_prod thm_ty - nb_prod (pf_concl gl) in
+      if n<0 then error "Apply: theorem has not enough premisses.";
+      let clause = make_clenv_binding_apply wc n (c,thm_ty) lbind in
+      apply kONT clause gl
+    with (RefinerError _|UserError _|Failure _) as exn ->
+      let red_thm =
+        try red_product (w_env wc) (w_Underlying wc) thm_ty
+        with (Redelimination | UserError _) -> raise exn in
+      try_apply red_thm in
+  try try_apply thm_ty0
+  with (RefinerError _|UserError _|Failure _) ->
+    (* Last chance: if the head is a variable, apply may try
+       second order unification *)
+    let clause = make_clenv_binding_apply wc (-1) (c,thm_ty0) lbind in 
+    apply kONT clause gl
+
+let apply c = apply_with_bindings (c,NoBindings)
+
+let apply_list = function 
+  | c::l -> apply_with_bindings (c,ImplicitBindings l)
+  | _ -> assert false
+
+(* Resolution with no reduction on the type *)
+
+let apply_without_reduce c gl = 
+  let (wc,kONT) = startWalk gl in
+  let clause = mk_clenv_type_of wc c in 
+  res_pf kONT clause gl
+
+(* A useful resolution tactic which, if c:A->B, transforms |- C into
+   |- B -> C and |- A
+
+   -------------------
+   Gamma |- c : A -> B      Gamma |- ?2 : A
+   ----------------------------------------
+           Gamma |- B                        Gamma |- ?1 : B -> C
+           -----------------------------------------------------
+                             Gamma |- ? : C
+
+ Ltac lapply c :=
+  let ty := check c in
+  match eval hnf in ty with
+    ?A -> ?B => cut B; [ idtac | apply c ]
+  end.
+*)
+
+let cut_and_apply c gl =
+  let goal_constr = pf_concl gl in 
+  match kind_of_term (pf_hnf_constr gl (pf_type_of gl c)) with
+    | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) ->
+	tclTHENLAST
+	  (apply_type (mkProd (Anonymous,c2,goal_constr)) [mkMeta(new_meta())])
+	  (apply_term c [mkMeta (new_meta())]) gl
+    | _ -> error "Imp_elim needs a non-dependent product"
+
+(**************************)
+(*     Cut tactics        *)
+(**************************)
+
+let assert_tac first na c gl =
+  match kind_of_term (hnf_type_of gl c) with
+    | Sort s -> 
+	let id = match na with
+	  | Anonymous -> 
+              let d = match s with Prop _ -> "H" | Type _ -> "X" in
+              fresh_id [] (id_of_string d) gl
+	  | Name id -> id
+	in
+	(if first then internal_cut else internal_cut_rev) id c gl
+    | _  -> error "Not a proposition or a type"
+
+let true_cut = assert_tac true
+
+let cut c gl =
+  match kind_of_term (hnf_type_of gl c) with
+    | Sort _ ->
+        let id=next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
+        let t = mkProd (Anonymous, c, pf_concl gl) in
+        tclTHENFIRST
+          (internal_cut_rev id c)
+          (tclTHEN (apply_type t [mkVar id]) (thin [id]))
+          gl
+    | _  -> error "Not a proposition or a type"
+
+let cut_intro t = tclTHENFIRST (cut t) intro
+		    
+let cut_replacing id t = 
+  tclTHENFIRST
+    (cut t)
+    (tclORELSE
+      (intro_replacing id) 
+      (tclORELSE (intro_erasing id) 
+        (intro_using id)))
+
+let cut_in_parallel l = 
+  let rec prec = function
+    | [] -> tclIDTAC 
+    | h::t -> tclTHENFIRST (cut h) (prec t)
+  in 
+  prec (List.rev l)
+
+(**************************)
+(*   Generalize tactics   *)
+(**************************)
+
+let generalize_goal gl c cl =
+  let t = pf_type_of gl c in
+  match kind_of_term c with
+    | Var id ->
+	(* The choice of remembering or not a non dependent name has an impact
+	   on the future Intro naming strategy! *)
+	(* if dependent c cl then mkNamedProd id t cl
+	   else mkProd (Anonymous,t,cl) *)
+	mkNamedProd id t cl
+    | _        -> 
+        let cl' = subst_term c cl in
+        if noccurn 1 cl' then 
+	  mkProd (Anonymous,t,cl)
+          (* On ne se casse pas la tete : on prend pour nom de variable
+             la premiere lettre du type, meme si "ci" est une
+             constante et qu'on pourrait prendre directement son nom *)
+        else 
+	  prod_name (Global.env()) (Anonymous, t, cl')
+
+let generalize_dep c gl =
+  let env = pf_env gl in
+  let sign = pf_hyps gl in
+  let init_ids = ids_of_named_context (Global.named_context()) in
+  let rec seek d toquant =
+    if List.exists (fun (id,_,_) -> occur_var_in_decl env id d) toquant
+      or dependent_in_decl c d then 
+      d::toquant
+    else 
+      toquant in
+  let to_quantify = Sign.fold_named_context seek sign ~init:[] in
+  let to_quantify_rev = List.rev to_quantify in
+  let qhyps = List.map (fun (id,_,_) -> id) to_quantify_rev in
+  let tothin = List.filter (fun id -> not (List.mem id init_ids)) qhyps in
+  let tothin' =
+    match kind_of_term c with
+      | Var id when mem_named_context id sign & not (List.mem id init_ids)
+	  -> id::tothin
+      | _ -> tothin
+  in
+  let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
+  let cl'' = generalize_goal gl c cl' in
+  let args = Array.to_list (instance_from_named_context to_quantify_rev) in
+  tclTHEN
+    (apply_type cl'' (c::args))
+    (thin (List.rev tothin'))
+    gl
+    
+let generalize lconstr gl = 
+  let newcl = List.fold_right (generalize_goal gl) lconstr (pf_concl gl) in
+  apply_type newcl lconstr gl
+
+(* Faudra-t-il une version avec plusieurs args de generalize_dep ?
+Cela peut-être troublant de faire "Generalize Dependent H n" dans
+"n:nat; H:n=n |- P(n)" et d'échouer parce que H a disparu après la
+généralisation dépendante par n.
+
+let quantify lconstr =
+ List.fold_right 
+   (fun com tac -> tclTHEN tac (tactic_com generalize_dep c))
+   lconstr
+   tclIDTAC
+*)
+
+(* A dependent cut rule à la sequent calculus
+   ------------------------------------------
+   Sera simplifiable le jour où il y aura un let in primitif dans constr
+
+   [letin_tac b na c (occ_hyp,occ_ccl) gl] transforms
+   [...x1:T1(c),...,x2:T2(c),... |- G(c)] into
+   [...x:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is false or
+   [...x:=c:T;x1:T1(x),...,x2:T2(x),... |- G(x)] if [b] is true
+
+   [occ_hyp,occ_ccl] tells which occurrences of [c] have to be substituted;
+   if [occ_hyp = []] and [occ_ccl = None] then [c] is substituted
+   wherever it occurs, otherwise [c] is substituted only in hyps
+   present in [occ_hyps] at the specified occurrences (everywhere if
+   the list of occurrences is empty), and in the goal at the specified
+   occurrences if [occ_goal] is not [None];
+
+   if name = Anonymous, the name is build from the first letter of the type;
+
+   The tactic first quantify the goal over x1, x2,... then substitute then
+   re-intro x1, x2,... at their initial place ([marks] is internally
+   used to remember the place of x1, x2, ...: it is the list of hypotheses on
+   the left of each x1, ...).
+*)
+
+
+
+let occurrences_of_hyp id cls =
+  let rec hyp_occ = function
+      [] -> None
+    | (id',occs,hl)::_ when id=id' -> Some occs
+    | _::l -> hyp_occ l in
+  match cls.onhyps with
+      None -> Some []
+    | Some l -> hyp_occ l
+
+let occurrences_of_goal cls =
+  if cls.onconcl then Some cls.concl_occs else None
+
+let everywhere cls = (cls=allClauses)
+
+(*
+(* Implementation with generalisation then re-intro: introduces noise *)
+(* in proofs *)
+
+let letin_abstract id c occs gl =
+  let env = pf_env gl in
+  let compute_dependency _ (hyp,_,_ as d) ctxt =
+    let d' =
+      try
+	match occurrences_of_hyp hyp occs with
+	  | None -> raise Not_found
+	  | Some occ ->
+              let newdecl = subst_term_occ_decl occ c d in
+              if d = newdecl then
+		if not (everywhere occs)
+		then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+		else raise Not_found
+              else 
+		(subst1_decl (mkVar id) newdecl, true)
+	with Not_found -> 
+	  (d,List.exists
+	      (fun ((id,_,_),dep) -> dep && occur_var_in_decl env id d) ctxt)
+    in d'::ctxt
+  in 
+  let ctxt' = fold_named_context compute_dependency env ~init:[] in
+  let compute_marks ((depdecls,marks as accu),lhyp) ((hyp,_,_) as d,b) =
+    if b then ((d::depdecls,(hyp,lhyp)::marks), lhyp)
+    else (accu, Some hyp) in
+  let (depdecls,marks),_ = List.fold_left compute_marks (([],[]),None) ctxt' in
+  let ccl = match occurrences_of_goal occs with
+    | None -> pf_concl gl
+    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl))
+  in
+  (depdecls,marks,ccl)
+
+let letin_tac with_eq name c occs gl =
+  let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+  let id =
+    if name = Anonymous then fresh_id [] x gl else
+      if not (mem_named_context x (pf_hyps gl)) then x else
+	error ("The variable "^(string_of_id x)^" is already declared") in
+  let (depdecls,marks,ccl)= letin_abstract id c occs gl in 
+  let t = pf_type_of gl c in
+  let tmpcl = List.fold_right mkNamedProd_or_LetIn depdecls ccl in
+  let args = Array.to_list (instance_from_named_context depdecls) in
+  let newcl = mkNamedLetIn id c t tmpcl in
+  let lastlhyp = if marks=[] then None else snd (List.hd marks) in
+  tclTHENLIST
+    [ apply_type newcl args;
+      thin (List.map (fun (id,_,_) -> id) depdecls);
+      intro_gen (IntroMustBe id) lastlhyp false;
+      if with_eq then tclIDTAC else thin_body [id];
+      intros_move marks ] gl
+*)
+
+(* Implementation without generalisation: abbrev will be lost in hyps in *)
+(* in the extracted proof *)
+
+let letin_abstract id c occs gl =
+  let env = pf_env gl in
+  let compute_dependency _ (hyp,_,_ as d) depdecls =
+    match occurrences_of_hyp hyp occs with
+      | None -> depdecls
+      | Some occ ->
+          let newdecl = subst_term_occ_decl occ c d in
+          if d = newdecl then
+	    if not (everywhere occs)
+	    then raise (RefinerError (DoesNotOccurIn (c,hyp)))
+	    else depdecls
+          else 
+	    (subst1_decl (mkVar id) newdecl)::depdecls in 
+  let depdecls = fold_named_context compute_dependency env ~init:[] in
+  let ccl = match occurrences_of_goal occs with
+    | None -> pf_concl gl
+    | Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in
+  let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in
+  (depdecls,lastlhyp,ccl)
+
+let letin_tac with_eq name c occs gl =
+  let id =
+    let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) name in
+    if name = Anonymous then fresh_id [] x gl else
+      if not (mem_named_context x (pf_hyps gl)) then x else
+	error ("The variable "^(string_of_id x)^" is already declared") in
+  let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in 
+  let t = pf_type_of gl c in
+  let newcl = mkNamedLetIn id c t ccl in
+  tclTHENLIST
+    [ convert_concl_no_check newcl;
+      intro_gen (IntroMustBe id) lastlhyp true;
+      if with_eq then tclIDTAC else thin_body [id];
+      tclMAP convert_hyp_no_check depdecls ] gl
+  
+let check_hypotheses_occurrences_list env (_,occl) =
+  let rec check acc = function
+    | (hyp,_) :: rest -> 
+	if List.mem hyp acc then
+	  error ("Hypothesis "^(string_of_id hyp)^" occurs twice");
+	if not (mem_named_context hyp (named_context env)) then
+	  error ("No such hypothesis: " ^ (string_of_id hyp));
+	check (hyp::acc) rest
+    | [] -> ()
+  in check [] occl
+
+let nowhere = {onhyps=Some[]; onconcl=false; concl_occs=[]}
+
+(* Tactic Assert (b=false) and Pose (b=true):
+   the behaviour of Pose is corrected by the translator.
+   not that of Assert *)
+let forward b na c =
+  let wh =  if !Options.v7 && b then onConcl else nowhere in
+  letin_tac b na c wh
+
+(********************************************************************)
+(*               Exact tactics                                      *)
+(********************************************************************)
+
+let exact_check c gl =
+  let concl = (pf_concl gl) in
+  let ct = pf_type_of gl c in
+  if pf_conv_x_leq gl ct concl then  
+    refine_no_check c gl 
+  else 
+    error "Not an exact proof"
+
+let exact_no_check = refine_no_check
+
+let exact_proof c gl =
+  (* on experimente la synthese d'ise dans exact *)
+  let c = Constrintern.interp_casted_constr (project gl) (pf_env gl) c (pf_concl gl)
+  in refine_no_check c gl 
+
+let (assumption : tactic) = fun gl ->
+  let concl =  pf_concl gl in 
+  let hyps = pf_hyps gl in
+  let rec arec only_eq = function
+    | [] -> 
+        if only_eq then arec false hyps else error "No such assumption"
+    | (id,c,t)::rest -> 
+	if (only_eq & eq_constr t concl) 
+          or (not only_eq & pf_conv_x_leq gl t concl)
+        then refine_no_check (mkVar id) gl
+	else arec only_eq rest
+  in
+  arec true hyps
+
+(*****************************************************************)
+(*          Modification of a local context                      *)
+(*****************************************************************)
+
+(* This tactic enables the user to remove hypotheses from the signature.
+ * Some care is taken to prevent him from removing variables that are 
+ * subsequently used in other hypotheses or in the conclusion of the  
+ * goal. *)                                                               
+
+let clear ids gl = (* avant seul dyn_clear n'echouait pas en [] *)
+  if ids=[] then tclIDTAC gl else with_check (thin ids) gl
+
+let clear_body = thin_body
+
+(*   Takes a list of booleans, and introduces all the variables 
+ *  quantified in the goal which are associated with a value
+ *  true  in the boolean list. *)
+
+let rec intros_clearing = function
+  | []          -> tclIDTAC
+  | (false::tl) -> tclTHEN intro (intros_clearing tl)
+  | (true::tl)  ->
+      tclTHENLIST
+        [ intro; onLastHyp (fun id -> clear [id]); intros_clearing tl]
+
+(* Adding new hypotheses  *)
+
+let new_hyp mopt (c,lbind) g =
+  let (wc,kONT) = startWalk g in
+  let clause  = make_clenv_binding wc (c,w_type_of wc c) lbind in
+  let (thd,tstack) = whd_stack (clenv_instance_template clause) in
+  let nargs = List.length tstack in
+  let cut_pf = 
+    applist(thd, 
+            match mopt with
+	      | Some m -> if m < nargs then list_firstn m tstack else tstack
+	      | None   -> tstack)
+  in 
+  (tclTHENLAST (tclTHEN (kONT clause.hook)
+               (cut (pf_type_of g cut_pf)))
+     ((tclORELSE (apply cut_pf) (exact_no_check cut_pf)))) g
+
+(************************)
+(* Introduction tactics *)
+(************************)
+
+let constructor_tac boundopt i lbind gl =
+  let cl = pf_concl gl in 
+  let (mind,redcl) = pf_reduce_to_quantified_ind gl cl in 
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames
+  and sigma   = project gl in
+  if i=0 then error "The constructors are numbered starting from 1";
+  if i > nconstr then error "Not enough constructors";
+  begin match boundopt with 
+    | Some expctdnum -> 
+        if expctdnum <> nconstr then 
+	  error "Not the expected number of constructors"
+    | None -> ()
+  end;
+  let cons = mkConstruct (ith_constructor_of_inductive mind i) in
+  let apply_tac = apply_with_bindings (cons,lbind) in
+  (tclTHENLIST [convert_concl_no_check redcl; intros; apply_tac]) gl
+
+let one_constructor i = constructor_tac None i
+
+(* Try to apply the constructor of the inductive definition followed by 
+   a tactic t given as an argument.
+   Should be generalize in Constructor (Fun c : I -> tactic)
+ *)
+
+let any_constructor tacopt gl =
+  let t = match tacopt with None -> tclIDTAC | Some t -> t in
+  let mind = fst (pf_reduce_to_quantified_ind gl (pf_concl gl)) in
+  let nconstr =
+    Array.length (snd (Global.lookup_inductive mind)).mind_consnames in
+  if nconstr = 0 then error "The type has no constructors";
+  tclFIRST (List.map (fun i -> tclTHEN (one_constructor i NoBindings) t) 
+              (interval 1 nconstr)) gl
+
+let left           = constructor_tac (Some 2) 1
+let simplest_left  = left NoBindings
+
+let right          = constructor_tac (Some 2) 2
+let simplest_right = right NoBindings
+
+let split          = constructor_tac (Some 1) 1
+let simplest_split = split NoBindings
+
+(********************************************)
+(*       Elimination tactics                *)
+(********************************************)
+
+
+(* kONT : ??
+ * wc : ??
+ * elimclause : ??
+ * inclause : ??
+ * gl : the current goal
+*)
+
+let last_arg c = match kind_of_term c with
+  | App (f,cl) ->  array_last cl
+  | _ -> anomaly "last_arg"
+	
+let elimination_clause_scheme kONT elimclause indclause allow_K gl = 
+  let indmv = 
+    (match kind_of_term (last_arg (clenv_template elimclause).rebus) with
+       | Meta mv -> mv
+       | _  -> errorlabstrm "elimination_clause"
+             (str "The type of elimination clause is not well-formed")) 
+  in
+  let elimclause' = clenv_fchain indmv elimclause indclause in 
+  elim_res_pf kONT elimclause' allow_K gl
+
+(* cast added otherwise tactics Case (n1,n2) generates (?f x y) and 
+ * refine fails *)
+
+let type_clenv_binding wc (c,t) lbind = 
+  clenv_instance_template_type (make_clenv_binding wc (c,t) lbind)
+
+(* 
+ * Elimination tactic with bindings and using an arbitrary 
+ * elimination constant called elimc. This constant should end 
+ * with a clause (x:I)(P .. ), where P is a bound variable.
+ * The term c is of type t, which is a product ending with a type 
+ * matching I, lbindc are the expected terms for c arguments 
+ *)
+
+let general_elim (c,lbindc) (elimc,lbindelimc) ?(allow_K=true) gl = 
+  let (wc,kONT)  = startWalk gl in
+  let ct = pf_type_of gl c in
+  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
+  let indclause  = make_clenv_binding wc (c,t) lbindc  in
+  let elimt      = w_type_of wc elimc in
+  let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in 
+  elimination_clause_scheme kONT elimclause indclause allow_K gl
+
+(* Elimination tactic with bindings but using the default elimination 
+ * constant associated with the type. *)
+
+let find_eliminator c gl =
+  let env = pf_env gl in
+  let (ind,t) = reduce_to_quantified_ind env (project gl) (pf_type_of gl c) in
+  let s = elimination_sort_of_goal gl in
+    Indrec.lookup_eliminator ind s 
+(*  with Not_found -> 
+    let dir, base = repr_path (path_of_inductive env ind) in
+    let id = Indrec.make_elimination_ident base s in
+    errorlabstrm "default_elim"
+      (str "Cannot find the elimination combinator :" ++
+         pr_id id ++ spc () ++
+	 str "The elimination of the inductive definition :" ++
+         pr_id base ++ spc () ++ str "on sort " ++
+         spc () ++ print_sort (new_sort_in_family s) ++
+	 str " is probably not allowed")
+(* lookup_eliminator prints the message *) *)
+let default_elim (c,lbindc) gl = 
+  general_elim (c,lbindc) (find_eliminator c gl,NoBindings) gl
+
+let elim_in_context (c,_ as cx) elim gl =
+  match elim with
+  | Some (elimc,lbindelimc) -> general_elim cx (elimc,lbindelimc) gl
+  | None -> general_elim cx (find_eliminator c gl,NoBindings) gl 
+
+let elim (c,lbindc as cx) elim =
+  match kind_of_term c with
+    | Var id when lbindc = NoBindings ->
+	tclTHEN (tclTRY (intros_until_id id)) (elim_in_context cx elim)
+    | _ -> elim_in_context cx elim
+
+(* The simplest elimination tactic, with no substitutions at all. *)
+
+let simplest_elim c = default_elim (c,NoBindings)
+
+(* Elimination in hypothesis *)
+
+let elimination_in_clause_scheme kONT id elimclause indclause =
+  let (hypmv,indmv) = 
+    match clenv_independent elimclause with
+        [k1;k2] -> (k1,k2)
+      | _  -> errorlabstrm "elimination_clause"
+          (str "The type of elimination clause is not well-formed") in
+  let elimclause'  = clenv_fchain indmv elimclause indclause in 
+  let hyp = mkVar id in
+  let hyp_typ = clenv_type_of elimclause' hyp in
+  let hypclause =
+    mk_clenv_from_n elimclause'.hook (Some 0) (hyp, hyp_typ) in
+  let elimclause'' = clenv_fchain hypmv elimclause' hypclause in  
+  let new_hyp_prf  = clenv_instance_template elimclause'' in
+  let new_hyp_typ  = clenv_instance_template_type elimclause'' in
+  if eq_constr hyp_typ new_hyp_typ then
+    errorlabstrm "general_rewrite_in" 
+      (str "Nothing to rewrite in " ++ pr_id id);
+  tclTHEN
+    (kONT elimclause''.hook)
+    (tclTHENS
+      (cut new_hyp_typ)
+      [ (* Try to insert the new hyp at the same place *)
+        tclORELSE (intro_replacing id)
+          (tclTHEN (clear [id]) (introduction id));
+        refine_no_check new_hyp_prf])
+
+let general_elim_in id (c,lbindc) (elimc,lbindelimc) gl = 
+  let (wc,kONT)  = startWalk gl in
+  let ct = pf_type_of gl c in
+  let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in
+  let indclause  = make_clenv_binding wc (c,t) lbindc  in
+  let elimt      = w_type_of wc elimc in
+  let elimclause = make_clenv_binding wc (elimc,elimt) lbindelimc in 
+  elimination_in_clause_scheme kONT id elimclause indclause gl
+
+(* Case analysis tactics *)
+
+let general_case_analysis_in_context (c,lbindc) gl =
+  let env = pf_env gl in
+  let (mind,_) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
+  let sigma    = project gl in 
+  let sort     = elimination_sort_of_goal gl in
+  let case = if occur_term c (pf_concl gl) then Indrec.make_case_dep
+  else Indrec.make_case_gen in
+  let elim     = case env sigma mind sort in 
+  general_elim (c,lbindc) (elim,NoBindings) gl
+
+let general_case_analysis (c,lbindc as cx) =
+  match kind_of_term c with
+    | Var id when lbindc = NoBindings ->
+	tclTHEN (tclTRY (intros_until_id id))
+	(general_case_analysis_in_context cx)
+    | _ ->
+	general_case_analysis_in_context cx
+
+let simplest_case c = general_case_analysis (c,NoBindings)
+
+(*****************************)
+(* Decomposing introductions *)
+(*****************************)
+
+let clear_last = tclLAST_HYP (fun c -> (clear [destVar c]))
+let case_last  = tclLAST_HYP simplest_case
+
+let rec intro_pattern destopt = function
+  | IntroWildcard ->
+      tclTHEN intro clear_last
+  | IntroIdentifier id ->
+      intro_gen (IntroMustBe id) destopt true
+  | IntroOrAndPattern l ->
+      tclTHEN introf
+        (tclTHENS
+	  (tclTHEN case_last clear_last)
+	  (List.map (intros_pattern destopt) l))
+
+and intros_pattern destopt l = tclMAP (intro_pattern destopt) l
+
+let intro_patterns = function 
+  | [] -> tclREPEAT intro
+  | l  -> intros_pattern None l
+
+(*
+ * A "natural" induction tactic
+ * 
+  - [H0:T0, ..., Hi:Ti, hyp0:P->I(args), Hi+1:Ti+1, ..., Hn:Tn |-G] is the goal
+  - [hyp0] is the induction hypothesis
+  - we extract from [args] the variables which are not rigid parameters
+    of the inductive type, this is [indvars] (other terms are forgotten);
+    [indhyps] are the ones which actually are declared in context
+    (done in [find_atomic_param_of_ind])
+  - we look for all hyps depending of [hyp0] or one of [indvars]:
+    this is [dephyps] of types [deptyps] respectively
+  - [statuslist] tells for each hyps in [dephyps] after which other hyp
+    fixed in the context they must be moved (when induction is done)
+  - [hyp0succ] is the name of the hyp fixed in the context after which to
+    move the subterms of [hyp0succ] in the i-th branch where it is supposed
+    to be the i-th constructor of the inductive type.
+
+  Strategy: (cf in [induction_from_context])
+  - requantify and clear all [dephyps]
+  - apply induction on [hyp0]
+  - clear [indhyps] and [hyp0]
+  - in the i-th subgoal, intro the arguments of the i-th constructor
+    of the inductive type after [hyp0succ] (done in
+    [induct_discharge]) let the induction hypotheses on top of the
+    hyps because they may depend on variables between [hyp0] and the
+    top. A counterpart is that the dep hyps programmed to be intro-ed
+    on top must now be intro-ed after the induction hypotheses
+  - move each of [dephyps] at the right place following the
+    [statuslist]
+
+ *)
+
+let rec str_intro_pattern = function
+  | IntroOrAndPattern pll ->
+      "["^(String.concat "|" 
+	(List.map 
+	  (fun pl -> String.concat " " (List.map str_intro_pattern pl)) pll))
+      ^"]"
+  | IntroWildcard -> "_"
+  | IntroIdentifier id -> string_of_id id
+
+let check_unused_names names =
+  if names <> [] & Options.is_verbose () then
+    let s = if List.tl names = [] then " " else "s " in
+    let names = String.concat " " (List.map str_intro_pattern names) in
+    warning ("Unused introduction pattern"^s^": "^names)
+
+let rec first_name_buggy = function
+  | IntroOrAndPattern [] -> None
+  | IntroOrAndPattern ([]::l) -> first_name_buggy (IntroOrAndPattern l)
+  | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p
+  | IntroWildcard -> None
+  | IntroIdentifier id -> Some id
+
+type elim_arg_kind = RecArg | IndArg | OtherArg
+
+let induct_discharge statuslists destopt avoid' ((avoid7,avoid8),ra) (names,force,rnames) gl =
+  let avoid7 = avoid7 @ avoid' in
+  let avoid8 = avoid8 @ avoid' in
+  let (lstatus,rstatus) = statuslists in
+  let tophyp = ref None in
+  let rec peel_tac ra names gl = match ra with
+    | (RecArg,(recvarname7,recvarname8)) ::
+        (IndArg,(hyprecname7,hyprecname8)) :: ra' ->
+        let recpat,hyprec,names = match names with
+          | [] ->
+              let idrec7 = (fresh_id avoid7 recvarname7 gl) in
+              let idrec8 = (fresh_id avoid8 recvarname8 gl) in
+              let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in
+              let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in
+ 	      if Options.do_translate() &
+                (idrec7 <> idrec8 or idhyp7 <> idhyp8)
+	      then force := true;
+              let idrec = if !Options.v7 then idrec7 else idrec8 in
+              let idhyp = if !Options.v7 then idhyp7 else idhyp8 in
+              (IntroIdentifier idrec, IntroIdentifier idhyp, [])
+          | [IntroIdentifier id as pat] ->
+              let id7 = next_ident_away (add_prefix "IH" id) avoid7 in
+              let id8 = next_ident_away (add_prefix "IH" id) avoid8 in
+ 	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+	      (pat, IntroIdentifier id, [])
+	  | [pat] ->
+              let idhyp7 = (fresh_id avoid7 hyprecname7 gl) in
+              let idhyp8 = (fresh_id avoid8 hyprecname8 gl) in
+ 	      if Options.do_translate() & idhyp7 <> idhyp8 then force := true;
+              let idhyp = if !Options.v7 then idhyp7 else idhyp8 in
+	      (pat, IntroIdentifier idhyp, [])
+          | pat1::pat2::names -> (pat1,pat2,names) in
+	(* This is buggy for intro-or-patterns with different first hypnames *)
+	if !tophyp=None then tophyp := first_name_buggy hyprec;
+	rnames := !rnames @ [recpat; hyprec];
+        tclTHENLIST
+	  [ intros_pattern destopt [recpat];
+	    intros_pattern None [hyprec];
+	    peel_tac ra' names ] gl
+    | (IndArg,(hyprecname7,hyprecname8)) :: ra' ->
+	(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
+        let pat,names = match names with
+          | [] -> IntroIdentifier (fresh_id avoid8 hyprecname8 gl), []
+	  | pat::names -> pat,names in
+	rnames := !rnames @ [pat];
+	tclTHEN (intros_pattern destopt [pat]) (peel_tac ra' names) gl
+    | (RecArg,(recvarname7,recvarname8)) :: ra' ->
+        let introtac,names = match names with
+          | [] -> 
+              let id8 = fresh_id avoid8 recvarname8 gl in
+	      let i =
+                if !Options.v7 then IntroAvoid avoid7 else IntroMustBe id8
+	      in
+	      (* For translator *)
+	      let id7 = fresh_id avoid7 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+	      rnames := !rnames @ [IntroIdentifier id];
+	      intro_gen i destopt false, []
+          | pat::names ->
+	      rnames := !rnames @ [pat];
+	      intros_pattern destopt [pat],names in
+	tclTHEN introtac (peel_tac ra' names) gl
+    | (OtherArg,_) :: ra' ->
+        let introtac,names = match names with
+          | [] -> 
+	      (* For translator *)
+	      let id7 = fresh_id avoid7 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      let id8 = fresh_id avoid8 (default_id gl
+		(match kind_of_term (pf_concl gl) with
+		  | Prod (name,t,_) -> (name,None,t)
+		  | LetIn (name,b,t,_) -> (name,Some b,t) 
+		  | _ -> assert false)) gl in
+	      if Options.do_translate() & id7 <> id8 then force := true;
+              let id = if !Options.v7 then id7 else id8 in
+              let avoid = if !Options.v7 then avoid7 else avoid8 in
+	      rnames := !rnames @ [IntroIdentifier id];
+	      intro_gen (IntroAvoid avoid) destopt false, []
+          | pat::names ->
+	      rnames := !rnames @ [pat];
+	      intros_pattern destopt [pat],names in
+	tclTHEN introtac (peel_tac ra' names) gl
+    | [] ->
+        check_unused_names names;
+        tclIDTAC gl
+  in
+  let intros_move lstatus =
+    let newlstatus = (* if some IH has taken place at the top of hyps *)
+      List.map (function (hyp,None) -> (hyp,!tophyp) | x -> x) lstatus in
+    intros_move newlstatus
+  in 
+  tclTHENLIST [ peel_tac ra names;
+		intros_rmove rstatus;
+		intros_move lstatus ] gl
+
+(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
+     s'embêter à regarder si un letin_tac ne fait pas des
+     substitutions aussi sur l'argument voisin *)
+
+(* Marche pas... faut prendre en compte l'occurrence précise... *)
+
+let atomize_param_of_ind (indref,nparams) hyp0 gl =
+  let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+  let prods, indtyp = decompose_prod typ0 in
+  let argl = snd (decompose_app indtyp) in
+  let params = list_firstn nparams argl in
+  (* le gl est important pour ne pas préévaluer *)
+  let rec atomize_one i avoid gl =
+    if i<>nparams then
+      let tmptyp0 = pf_get_hyp_typ gl hyp0 in
+      (* If argl <> [], we expect typ0 not to be quantified, in order to
+         avoid bound parameters... then we call pf_reduce_to_atomic_ind *)
+      let indtyp = pf_apply reduce_to_atomic_ref gl indref tmptyp0 in
+      let argl = snd (decompose_app indtyp) in
+      let c = List.nth argl (i-1) in
+      match kind_of_term c with
+	| Var id when not (List.exists (occur_var (pf_env gl) id) avoid) ->
+	    atomize_one (i-1) ((mkVar id)::avoid) gl
+	| Var id ->
+	    let x = fresh_id [] id gl in
+	    tclTHEN
+	      (letin_tac true (Name x) (mkVar id) allClauses)
+	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+	| _ ->
+	    let id = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
+		       Anonymous in
+	    let x = fresh_id [] id gl in
+	    tclTHEN
+	      (letin_tac true (Name x) c allClauses)
+	      (atomize_one (i-1) ((mkVar x)::avoid)) gl
+    else 
+      tclIDTAC gl
+  in
+  atomize_one (List.length argl) params gl
+
+let find_atomic_param_of_ind nparams indtyp =
+  let argl = snd (decompose_app indtyp) in
+  let argv = Array.of_list argl in
+  let params = list_firstn nparams argl in
+  let indvars = ref Idset.empty in
+  for i = nparams to (Array.length argv)-1 do
+    match kind_of_term argv.(i) with
+      | Var id
+          when not (List.exists (occur_var (Global.env()) id) params) ->
+	  indvars := Idset.add id !indvars
+      | _ -> ()
+  done;
+  Idset.elements !indvars;
+  
+
+   (* [cook_sign] builds the lists [indhyps] of hyps that must be
+   erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
+   goal together with the places [(lstatus,rstatus)] where to re-intro
+   them after induction. To know where to re-intro the dep hyp, we
+   remember the name of the hypothesis [lhyp] after which (if the dep
+   hyp is more recent than [hyp0]) or [rhyp] before which (if older
+   than [hyp0]) its equivalent must be moved when the induction has
+   been applied. Since computation of dependencies and [rhyp] is from
+   more ancient (on the right) to more recent hyp (on the left) but
+   the computation of [lhyp] progresses from the other way, [cook_hyp]
+   is in two passes (an alternative would have been to write an
+   higher-order algorithm). We strongly use references to reduce
+   the accumulation of arguments.
+
+   To summarize, the situation looks like this
+
+   Goal(n,x) -| H6:(Q n); x:A; H5:True; H4:(le O n); H3:(P n); H2:True; n:nat
+                Left                                                    Right 
+
+   Induction hypothesis is H4 ([hyp0])
+   Variable parameters of (le O n) is the singleton list with "n" ([indvars])
+   Part of [indvars] really in context is the same ([indhyps])
+   The dependent hyps are H3 and H6 ([dephyps])
+   For H3 the memorized places are H5 ([lhyp]) and H2 ([rhyp])
+    because these names are among the hyp which are fixed through the induction
+   For H6 the neighbours are None ([lhyp]) and H5 ([rhyp])
+   For H3, because on the right of H4, we remember rhyp (here H2)
+   For H6, because on the left of H4, we remember lhyp (here None)
+   For H4, we remember lhyp (here H5)
+
+   The right neighbour is then translated into the left neighbour
+   because move_hyp tactic needs the name of the hyp _after_ which we
+   move the hyp to move.
+
+   But, say in the 2nd subgoal of the hypotheses, the goal will be
+
+   (m:nat)((P m)->(Q m)->(Goal m)) -> (P Sm)->   (Q Sm)->   (Goal Sm)
+     ^^^^^^^^^^^^^^^^^^^^^^^^^^^       ^^^^
+         both go where H4 was       goes where  goes where
+                                      H3 was      H6 was
+
+   We have to intro and move m and the recursive hyp first, but then
+   where to move H3 ??? Only the hyp on its right is relevant, but we
+   have to translate it into the name of the hyp on the left
+
+   Note: this case where some hyp(s) in [dephyps] has(have) the same
+   left neighbour as [hyp0] is the only problematic case with right
+   neighbours. For the other cases (e.g. an hyp H1:(R n) between n and H2
+   would have posed no problem. But for uniformity, we decided to use
+   the right hyp for all hyps on the right of H4.
+
+   Others solutions are welcome *)
+
+exception Shunt of identifier option
+
+let cook_sign hyp0 indvars env =
+  (* First phase from L to R: get [indhyps], [decldep] and [statuslist]
+     for the hypotheses before (= more ancient than) hyp0 (see above) *)
+  let allindhyps = hyp0::indvars in
+  let indhyps = ref [] in
+  let decldeps = ref [] in
+  let ldeps = ref [] in
+  let rstatus = ref [] in
+  let lstatus = ref [] in
+  let before = ref true in
+  let seek_deps env (hyp,_,_ as decl) rhyp =
+    if hyp = hyp0 then begin
+      before:=false; 
+      None (* fake value *)
+    end else if List.mem hyp indvars then begin
+      (* warning: hyp can still occur after induction *)
+      (* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
+      indhyps := hyp::!indhyps; 
+      rhyp
+    end else
+      if (List.exists (fun id -> occur_var_in_decl env id decl) allindhyps
+	  or List.exists (fun (id,_,_) -> occur_var_in_decl env id decl)
+        !decldeps)
+      then begin
+	decldeps := decl::!decldeps;
+	if !before then 
+	  rstatus := (hyp,rhyp)::!rstatus
+	else 
+	  ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
+	Some hyp end
+      else
+	Some hyp
+  in
+  let _ = fold_named_context seek_deps env ~init:None in
+  (* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *)
+  let compute_lstatus lhyp (hyp,_,_ as d) =
+    if hyp = hyp0 then raise (Shunt lhyp);
+    if List.mem hyp !ldeps then begin
+      lstatus := (hyp,lhyp)::!lstatus;
+      lhyp
+    end else
+      if List.mem hyp !indhyps then lhyp else (Some hyp) 
+  in
+  try 
+    let _ = fold_named_context_reverse compute_lstatus ~init:None env in
+    anomaly "hyp0 not found"
+  with Shunt lhyp0 ->
+    let statuslists = (!lstatus,List.rev !rstatus) in
+    (statuslists, lhyp0, !indhyps, !decldeps)
+
+let induction_tac varname typ ((elimc,lbindelimc),elimt) gl =
+  let c = mkVar varname in
+  let (wc,kONT)  = startWalk gl                    in
+  let indclause  = make_clenv_binding wc (c,typ) NoBindings  in
+  let elimclause =
+    make_clenv_binding wc (mkCast (elimc,elimt),elimt) lbindelimc in
+  elimination_clause_scheme kONT elimclause indclause true gl
+
+let make_up_names7 n ind (old_style,cname) = 
+  if old_style (* = V6.3 version of Induction on hypotheses *)
+  then
+    let recvarname =
+      if n=1 then 
+        cname
+      else (* To force renumbering if there is only one *)
+        make_ident (string_of_id cname ) (Some 1) in
+    recvarname, add_prefix "Hrec" recvarname, []
+  else
+    let is_hyp = atompart_of_id cname = "H" in
+    let hyprecname =
+      add_prefix "IH" (if is_hyp then Nametab.id_of_global ind else cname) in
+    let avoid =
+      if n=1 (* Only one recursive argument *)
+        or 
+        (* Rem: no recursive argument (especially if Destruct) *)
+        n=0 (* & atompart_of_id cname <> "H" (* for 7.1 compatibility *)*)
+      then []
+      else
+        (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
+        (* in order to get names such as f1, f2, ... *)
+        let avoid =
+          (make_ident (string_of_id cname) (Some 0)) ::(*here for 7.1 cmpat*)
+          (make_ident (string_of_id hyprecname) None) ::
+          (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
+        if atompart_of_id cname <> "H" then
+          (make_ident (string_of_id cname) None) :: avoid
+        else avoid in
+    cname, hyprecname, avoid
+
+let make_base n id =
+  if n=0 or n=1 then id
+  else
+    (* This extends the name to accept new digits if it already ends with *)
+    (* digits *)
+    id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
+
+let make_up_names8 n ind (_,cname) = 
+  let is_hyp = atompart_of_id cname = "H" in
+  let base = string_of_id (make_base n cname) in
+  let hyprecname =
+    add_prefix "IH"
+      (make_base n (if is_hyp then Nametab.id_of_global ind else cname)) in
+  let avoid =
+    if n=1 (* Only one recursive argument *) or n=0 then []
+    else
+      (* Forbid to use cname, cname0, hyprecname and hyprecname0 *)
+      (* in order to get names such as f1, f2, ... *)
+      let avoid =
+        (make_ident (string_of_id hyprecname) None) ::
+        (make_ident (string_of_id hyprecname) (Some 0)) :: [] in
+      if atompart_of_id cname <> "H" then
+        (make_ident base (Some 0)) :: (make_ident base None) :: avoid
+      else avoid in
+  id_of_string base, hyprecname, avoid
+
+let is_indhyp p n t =
+  let l, c = decompose_prod t in
+  let c,_ = decompose_app c in 
+  let p = p + List.length l in
+  match kind_of_term c with
+    | Rel k when p < k & k <= p + n -> true
+    | _ -> false
+
+let chop_context n l = 
+  let rec chop_aux acc = function
+    | n, (_,Some _,_ as h :: t) -> chop_aux (h::acc) (n, t)
+    | 0, l2 -> (List.rev acc, l2)
+    | n, (h::t) -> chop_aux (h::acc) (n-1, t)
+    | _, [] -> anomaly "chop_context"
+  in 
+  chop_aux [] (n,l)
+
+let error_ind_scheme s =
+  let s = if s <> "" then s^" " else s in
+  error ("Cannot recognise "^s^"an induction schema")
+
+(* Check that the elimination scheme has a form similar to the 
+   elimination schemes built by Coq *)
+let compute_elim_signature elimt names_info =
+  let nparams = ref 0 in
+  let hyps,ccl = decompose_prod_assum elimt in
+  let n = List.length hyps in
+  if n = 0 then error_ind_scheme "";
+  let f,l = decompose_app ccl in
+  let _,indbody,ind = List.hd hyps in
+  if indbody <> None then error "Cannot recognise an induction scheme";
+  let nargs = List.length l in
+  let dep = (nargs >= 1 && list_last l = mkRel 1) in
+  let nrealargs = if dep then nargs-1 else nargs in
+  let args = if dep then list_firstn nrealargs l else l in
+  let realargs,hyps1 = chop_context nrealargs (List.tl hyps) in
+  if args <> extended_rel_list 1 realargs then
+    error_ind_scheme "the conclusion of";
+  let indhd,indargs = decompose_app ind in
+  let indt = 
+    try reference_of_constr indhd
+    with _ -> error "Cannot find the inductive type of the inductive schema" in
+  let nparams = List.length indargs - nrealargs in
+  let revparams, revhyps2 = chop_context nparams (List.rev hyps1) in
+  let rec check_elim npred = function
+  | (na,None,t)::l when isSort (snd (decompose_prod_assum t)) ->
+      check_elim (npred+1) l
+  | l ->
+    let is_pred n c = 
+      let hd = fst (decompose_app c) in match kind_of_term hd with
+    | Rel q when n < q & q <= n+npred -> IndArg
+    | _ when hd = indhd -> RecArg
+    | _ -> OtherArg in
+    let rec check_branch p c = match kind_of_term c with
+    | Prod (_,t,c) -> is_pred p t :: check_branch (p+1) c
+    | LetIn (_,_,_,c) -> OtherArg :: check_branch (p+1) c
+(*    | App (f,_) when is_pred p f = IndArg -> []*)
+    | _ when is_pred p c = IndArg -> []
+    | _ -> raise Exit in 
+    let rec find_branches p = function
+    | (_,None,t)::brs ->
+	(match try Some (check_branch p t) with Exit -> None with
+	 | Some l ->
+	     let n7 = List.fold_left
+	       (fun n b -> if b=IndArg then n+1 else n) 0 l in
+	     let n8 = List.fold_left
+	       (fun n b -> if b=RecArg then n+1 else n) 0 l in
+             let recvarname7, hyprecname7, avoid7 = make_up_names7 n7 indt names_info in
+             let recvarname8, hyprecname8, avoid8 = make_up_names8 n8 indt names_info in
+	     let namesign = List.map
+	       (fun b -> (b,if b=IndArg then (hyprecname7,hyprecname8)
+                else (recvarname7,recvarname8))) l in
+	     ((avoid7,avoid8),namesign) :: find_branches (p+1) brs
+	 | None -> error_ind_scheme "the branches of")
+    | (_,Some _,_)::_ -> error_ind_scheme "the branches of"
+    | [] ->
+	(* Check again conclusion *)
+	let ccl_arg_ok = is_pred (p + List.length realargs + 1) f = IndArg in
+	let ind_is_ok = 
+	  list_lastn nrealargs indargs = extended_rel_list 0 realargs in
+	if not (ccl_arg_ok & ind_is_ok) then
+	  error "Cannot recognize the conclusion of an induction schema";
+	[] in
+    find_branches 0 l in
+  nparams, indt, (Array.of_list (check_elim 0 revhyps2))
+
+let find_elim_signature isrec style elim hyp0 gl =
+  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
+  let (elimc,elimt) = match elim with
+    | None ->
+	let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
+	let s = elimination_sort_of_goal gl in
+	let elimc =
+	  if isrec then Indrec.lookup_eliminator mind s
+	  else pf_apply Indrec.make_case_gen gl mind s in
+	let elimt = pf_type_of gl elimc in
+	((elimc, NoBindings), elimt)
+    | Some (elimc,lbind as e) -> 
+	(e, pf_type_of gl elimc) in
+  let name_info = (style,hyp0) in
+  let nparams,indref,indsign = compute_elim_signature elimt name_info in
+  (elimc,elimt,nparams,indref,indsign)
+
+let induction_from_context isrec elim_info hyp0 (names,b_rnames) gl =
+  (*test suivant sans doute inutile car refait par le letin_tac*)
+  if List.mem hyp0 (ids_of_named_context (Global.named_context())) then
+    errorlabstrm "induction" 
+      (str "Cannot generalize a global variable");
+  let elimc,elimt,nparams,indref,indsign = elim_info in
+  let tmptyp0 =	pf_get_hyp_typ gl hyp0 in
+  let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
+  let env = pf_env gl in
+  let indvars = find_atomic_param_of_ind nparams (snd (decompose_prod typ0)) in
+  let (statlists,lhyp0,indhyps,deps) = cook_sign hyp0 indvars env in
+  let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
+  let names = compute_induction_names (Array.length indsign) names in
+  (* For translator *)
+  let names' = Array.map ref (Array.make (Array.length indsign) []) in
+  let b = ref false in
+  b_rnames := (b,Array.to_list names')::!b_rnames;
+  let names = array_map2 (fun n n' -> (n,b,n')) names names' in
+  (* End translator *)
+  let dephyps = List.map (fun (id,_,_) -> id) deps in
+  let args =
+    List.fold_left
+      (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
+
+  (* Magistral effet de bord: si hyp0 a des arguments, ceux d'entre
+     eux qui ouvrent de nouveaux buts arrivent en premier dans la
+     liste des sous-buts du fait qu'ils sont le plus à gauche dans le
+     combinateur engendré par make_case_gen (un "Cases (hyp0 ?) of
+     ...")  et il faut alors appliquer tclTHENLASTn; en revanche,
+     comme lookup_eliminator renvoie un combinateur de la forme
+     "ind_rec ... (hyp0 ?)", les buts correspondant à des arguments de
+     hyp0 sont maintenant à la fin et c'est tclTHENFIRSTn qui marche !!! *)
+  tclTHENLIST
+    [ if deps = [] then tclIDTAC else apply_type tmpcl args;
+      thin dephyps;
+      (if isrec then tclTHENFIRSTn else tclTHENLASTn)
+       	(tclTHENLIST
+	  [ induction_tac hyp0 typ0 (elimc,elimt);
+	    thin [hyp0];
+            tclTRY (thin indhyps) ])
+       	(array_map2
+	   (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
+    ]
+    gl
+
+let induction_with_atomization_of_ind_arg isrec elim names hyp0 gl =
+  let (elimc,elimt,nparams,indref,indsign as elim_info) =
+    find_elim_signature isrec false elim hyp0 gl in
+  tclTHEN
+    (atomize_param_of_ind (indref,nparams) hyp0)
+    (induction_from_context isrec elim_info hyp0 names) gl
+
+(* This is Induction since V7 ("natural" induction both in quantified
+   premisses and introduced ones) *)
+let new_induct_gen isrec elim names c gl =
+  match kind_of_term c with
+    | Var id when not (mem_named_context id (Global.named_context())) ->
+	induction_with_atomization_of_ind_arg isrec elim names id gl
+    | _        ->
+	let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c) 
+		  Anonymous in
+	let id = fresh_id [] x gl in
+	tclTHEN
+	  (letin_tac true (Name id) c allClauses)
+	  (induction_with_atomization_of_ind_arg isrec elim names id) gl
+
+let new_induct_destruct isrec c elim names = match c with
+  | ElimOnConstr c -> new_induct_gen isrec elim names c
+  | ElimOnAnonHyp n ->
+      tclTHEN (intros_until_n n)
+        (tclLAST_HYP (new_induct_gen isrec elim names))
+  (* Identifier apart because id can be quantified in goal and not typable *)
+  | ElimOnIdent (_,id) ->
+      tclTHEN (tclTRY (intros_until_id id))
+        (new_induct_gen isrec elim names (mkVar id))
+
+let new_induct = new_induct_destruct true
+let new_destruct = new_induct_destruct false
+
+(* The registered tactic, which calls the default elimination
+ * if no elimination constant is provided. *)
+	
+(* Induction tactics *)
+
+(* This was Induction before 6.3 (induction only in quantified premisses) *)
+let raw_induct s = tclTHEN (intros_until_id s) (tclLAST_HYP simplest_elim)
+let raw_induct_nodep n = tclTHEN (intros_until_n n) (tclLAST_HYP simplest_elim)
+
+(* This was Induction in 6.3 (hybrid form) *)
+let induction_from_context_old_style hyp b_ids gl =
+  let elim_info = find_elim_signature true true None hyp gl in
+  let x = induction_from_context true elim_info hyp (None,b_ids) gl in
+  (* For translator *) fst (List.hd !b_ids) := true;
+  x
+
+let simple_induct_id hyp b_ids =
+  if !Options.v7 then
+    tclORELSE (raw_induct hyp) (induction_from_context_old_style hyp b_ids)
+  else
+    raw_induct hyp
+let simple_induct_nodep = raw_induct_nodep
+
+let simple_induct = function
+  | NamedHyp id,b_ids -> simple_induct_id id b_ids
+  | AnonHyp n,_ -> simple_induct_nodep n
+
+(* Destruction tactics *)
+
+let simple_destruct_id s    =
+  (tclTHEN (intros_until_id s) (tclLAST_HYP simplest_case))
+let simple_destruct_nodep n =
+  (tclTHEN (intros_until_n n)    (tclLAST_HYP simplest_case))
+
+let simple_destruct = function
+  | NamedHyp id -> simple_destruct_id id
+  | AnonHyp n -> simple_destruct_nodep n
+
+(*
+ *  Eliminations giving the type instead of the proof.
+ * These tactics use the default elimination constant and
+ * no substitutions at all. 
+ * May be they should be integrated into Elim ...
+ *)
+
+let elim_scheme_type elim t gl =
+  let (wc,kONT) = startWalk gl in
+  let clause = mk_clenv_type_of wc elim in 
+  match kind_of_term (last_arg (clenv_template clause).rebus) with
+    | Meta mv ->
+        let clause' =
+	  (* t is inductive, then CUMUL or CONV is irrelevant *)
+	  clenv_unify true CUMUL t (clenv_instance_type clause mv) clause in
+	elim_res_pf kONT clause' true gl
+    | _ -> anomaly "elim_scheme_type"
+
+let elim_type t gl =
+  let (ind,t) = pf_reduce_to_atomic_ind gl t in
+  let elimc = Indrec.lookup_eliminator ind (elimination_sort_of_goal gl) in
+  elim_scheme_type elimc t gl
+
+let case_type t gl =
+  let (ind,t) = pf_reduce_to_atomic_ind gl t in
+  let env = pf_env gl in
+  let elimc = Indrec.make_case_gen env (project gl) ind (elimination_sort_of_goal gl) in 
+  elim_scheme_type elimc t gl
+
+
+(* Some eliminations frequently used *)
+
+(* These elimination tactics are particularly adapted for sequent
+   calculus.  They take a clause as argument, and yield the
+   elimination rule if the clause is of the form (Some id) and a
+   suitable introduction rule otherwise. They do not depend on 
+   the name of the eliminated constant, so they can be also 
+   used on ad-hoc disjunctions and conjunctions introduced by
+   the user. 
+   -- Eduardo Gimenez (11/8/97)
+
+   HH (29/5/99) replaces failures by specific error messages
+ *)
+
+let andE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_conjunction (pf_hnf_constr gl t) then 
+    (tclTHEN (simplest_elim (mkVar id)) (tclDO 2 intro)) gl
+  else 
+    errorlabstrm "andE" 
+      (str("Tactic andE expects "^(string_of_id id)^" is a conjunction."))
+
+let dAnd cls =
+  onClauses
+    (function
+      | None    -> simplest_split
+      | Some (id,_,_) -> andE id)
+    cls
+
+let orE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_disjunction (pf_hnf_constr gl t) then 
+    (tclTHEN (simplest_elim (mkVar id)) intro) gl
+  else 
+    errorlabstrm "orE" 
+      (str("Tactic orE expects "^(string_of_id id)^" is a disjunction."))
+
+let dorE b cls =
+  onClauses
+    (function
+      | (Some (id,_,_)) -> orE id
+      |  None     -> (if b then right else left) NoBindings)
+    cls
+
+let impE id gl =
+  let t = pf_get_hyp_typ gl id in
+  if is_imp_term (pf_hnf_constr gl t) then 
+    let (dom, _, rng) = destProd (pf_hnf_constr gl t) in 
+    tclTHENLAST
+      (cut_intro rng) 
+      (apply_term (mkVar id) [mkMeta (new_meta())]) gl
+  else 
+    errorlabstrm "impE"
+      (str("Tactic impE expects "^(string_of_id id)^
+	      " is a an implication."))
+                        
+let dImp cls =
+  onClauses
+    (function
+      | None    -> intro
+      | Some (id,_,_) -> impE id)
+    cls
+
+(************************************************)
+(*  Tactics related with logic connectives      *)
+(************************************************)
+
+(* Reflexivity tactics *)
+
+let reflexivity gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) ->  one_constructor 1 NoBindings gl
+
+let intros_reflexivity  = (tclTHEN intros reflexivity)
+
+(* Symmetry tactics *)
+
+(* This tactic first tries to apply a constant named sym_eq, where eq
+   is the name of the equality predicate. If this constant is not
+   defined and the conclusion is a=b, it solves the goal doing (Cut
+   b=a;Intro H;Case H;Constructor 1) *)
+
+let symmetry gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) ->
+        let hdcncls = string_of_inductive hdcncl in
+        begin 
+	  try 
+	    (apply (pf_parse_const gl ("sym_"^hdcncls)) gl)
+          with  _ ->
+            let symc = match args with 
+	      | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
+              | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
+              | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
+	      | _ -> assert false 
+	    in 
+	    tclTHENLAST (cut symc)
+              (tclTHENLIST 
+		[ intro;
+		  tclLAST_HYP simplest_case;
+		  one_constructor 1 NoBindings ])
+	      gl
+	end
+
+let symmetry_in id gl = 
+  let ctype = pf_type_of gl (mkVar id) in 
+  let sign,t = decompose_prod_assum ctype in
+  match match_with_equation t with
+    | None -> (* Do not deal with setoids yet *) 
+        error "The term provided does not end with an equation" 
+    | Some (hdcncl,args) -> 
+        let symccl = match args with 
+	  | [t1; c1; t2; c2] -> mkApp (hdcncl, [| t2; c2; t1; c1 |])
+          | [typ;c1;c2] -> mkApp (hdcncl, [| typ; c2; c1 |])
+          | [c1;c2]     -> mkApp (hdcncl, [| c2; c1 |])
+	  | _ -> assert false in
+	tclTHENS (cut (it_mkProd_or_LetIn symccl sign))
+	  [ intro_replacing id;
+            tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ]
+	  gl
+
+let intros_symmetry =
+  onClauses
+    (function
+      | None -> tclTHEN intros symmetry
+      | Some (id,_,_) -> symmetry_in id)
+
+(* Transitivity tactics *)
+
+(* This tactic first tries to apply a constant named trans_eq, where eq
+   is the name of the equality predicate. If this constant is not
+   defined and the conclusion is a=b, it solves the goal doing 
+   Cut x1=x2; 
+       [Cut x2=x3; [Intros e1 e2; Case e2;Assumption 
+                    | Idtac]
+       | Idtac]
+   --Eduardo (19/8/97)
+*)
+
+let transitivity t gl =
+  match match_with_equation (pf_concl gl) with
+    | None -> error "The conclusion is not a substitutive equation" 
+    | Some (hdcncl,args) -> 
+        let hdcncls = string_of_inductive hdcncl in
+        begin
+	  try 
+	    apply_list [(pf_parse_const gl ("trans_"^hdcncls));t] gl 
+          with  _ -> 
+            let eq1, eq2 = match args with 
+	      | [typ1;c1;typ2;c2] -> let typt = pf_type_of gl t in
+                  ( mkApp(hdcncl, [| typ1; c1; typt ;t |]),
+		    mkApp(hdcncl, [| typt; t; typ2; c2 |]) )
+              | [typ;c1;c2] ->
+		  ( mkApp (hdcncl, [| typ; c1; t |]),
+		    mkApp (hdcncl, [| typ; t; c2 |]) )
+	      | [c1;c2]     ->
+		  ( mkApp (hdcncl, [| c1; t|]),
+		    mkApp (hdcncl, [| t; c2 |]) )
+	      | _ -> assert false 
+	    in
+            tclTHENFIRST (cut eq2)
+	      (tclTHENFIRST (cut eq1)
+                (tclTHENLIST
+		  [ tclDO 2 intro;
+		    tclLAST_HYP simplest_case;
+		    assumption ])) gl
+        end 
+	
+let intros_transitivity  n  = tclTHEN intros (transitivity n)
+
+(* tactical to save as name a subproof such that the generalisation of 
+   the current goal, abstracted with respect to the local signature, 
+   is solved by tac *)
+
+let interpretable_as_section_decl d1 d2 = match d1,d2 with
+  | (_,Some _,_), (_,None,_) -> false
+  | (_,Some b1,t1), (_,Some b2,t2) -> eq_constr b1 b2 & eq_constr t1 t2
+  | (_,None,t1), (_,_,t2) -> eq_constr t1 t2
+
+let abstract_subproof name tac gls = 
+  let env = Global.env() in
+  let current_sign = Global.named_context()
+  and global_sign = pf_hyps gls in
+  let sign,secsign = 
+    List.fold_right
+      (fun (id,_,_ as d) (s1,s2) -> 
+	 if mem_named_context id current_sign &
+           interpretable_as_section_decl (Sign.lookup_named id current_sign) d
+         then (s1,add_named_decl d s2)
+	 else (add_named_decl d s1,s2)) 
+      global_sign (empty_named_context,empty_named_context) in
+  let na = next_global_ident_away false name (pf_ids_of_hyps gls) in
+  let concl = it_mkNamedProd_or_LetIn (pf_concl gls) sign in
+  if occur_existential concl then
+    if !Options.v7 then error "Abstract cannot handle existentials"
+    else error "\"abstract\" cannot handle existentials";
+  let lemme =
+    start_proof na (IsGlobal (Proof Lemma)) secsign concl (fun _ _ -> ());
+    let _,(const,kind,_) =
+      try
+	by (tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac)); 
+	let r = cook_proof () in 
+	delete_current_proof (); r
+      with e when catchable_exception e -> 
+	(delete_current_proof(); raise e)
+    in   (* Faudrait un peu fonctionnaliser cela *)
+    let cd = Entries.DefinitionEntry const in
+    let sp = Declare.declare_internal_constant na (cd,IsProof Lemma) in
+    let newenv = Global.env() in
+    constr_of_reference (ConstRef (snd sp))
+  in
+  exact_no_check 
+    (applist (lemme, 
+              List.rev (Array.to_list (instance_from_named_context sign))))
+    gls
+
+let tclABSTRACT name_op tac gls = 
+  let s = match name_op with 
+    | Some s -> s 
+    | None   -> add_suffix (get_current_proof_name ()) "_subproof" 
+  in  
+  abstract_subproof s tac gls
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
new file mode 100644
index 00000000..6e67a9cd
--- /dev/null
+++ b/tactics/tactics.mli
@@ -0,0 +1,245 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: tactics.mli,v 1.59.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+(*i*)
+open Names
+open Term
+open Environ
+open Sign
+open Tacmach
+open Proof_type
+open Reduction
+open Evd
+open Evar_refiner
+open Clenv
+open Tacred
+open Tacticals
+open Libnames
+open Genarg
+open Tacexpr
+open Nametab
+open Rawterm
+
+(* Main tactics. *)
+
+(*s General functions. *)
+
+val type_clenv_binding : named_context sigma ->
+  constr * constr -> constr bindings  -> constr
+
+val string_of_inductive : constr -> string
+val head_constr       : constr -> constr list
+val head_constr_bound : constr -> constr list -> constr list
+val is_quantified_hypothesis : identifier -> goal sigma -> bool
+
+exception Bound
+
+(*s Primitive tactics. *)
+
+val introduction    : identifier -> tactic
+val refine          : constr -> tactic
+val convert_concl   : constr -> tactic
+val convert_hyp     : named_declaration -> tactic
+val thin            : identifier list -> tactic
+val mutual_fix      :
+  identifier -> int -> (identifier * int * constr) list -> tactic
+val fix             : identifier option -> int -> tactic
+val mutual_cofix    : identifier -> (identifier * constr) list -> tactic
+val cofix           : identifier option -> tactic
+
+(*s Introduction tactics. *)
+
+val fresh_id : identifier list -> identifier -> goal sigma -> identifier
+
+val intro                : tactic
+val introf               : tactic
+val intro_force          : bool -> tactic
+val intro_move           : identifier option -> identifier option -> tactic
+
+val intro_replacing      : identifier -> tactic
+val intro_using          : identifier -> tactic
+val intro_mustbe_force   : identifier -> tactic
+val intros_using         : identifier list -> tactic
+val intro_erasing        : identifier -> tactic
+val intros_replacing     : identifier list -> tactic
+
+val intros               : tactic
+
+(* [depth_of_quantified_hypothesis b h g] returns the index of [h] in
+   the conclusion of goal [g], up to head-reduction if [b] is [true] *)
+val depth_of_quantified_hypothesis :
+  bool -> quantified_hypothesis -> goal sigma -> int
+
+val intros_until_n_wored : int -> tactic
+val intros_until         : quantified_hypothesis -> tactic
+
+val intros_clearing      : bool list -> tactic
+
+(* Assuming a tactic [tac] depending on an hypothesis identifier,
+   [try_intros_until tac arg] first assumes that arg denotes a
+   quantified hypothesis (denoted by name or by index) and try to
+   introduce it in context before to apply [tac], otherwise assume the
+   hypothesis is already in context and directly apply [tac] *)
+
+val try_intros_until :
+  (identifier -> tactic) -> quantified_hypothesis -> tactic
+
+(*s Introduction tactics with eliminations. *)
+
+val intro_pattern     : identifier option -> intro_pattern_expr      -> tactic
+val intro_patterns    : intro_pattern_expr list -> tactic
+val intros_pattern    : identifier option -> intro_pattern_expr list -> tactic
+
+(*s Exact tactics. *)
+
+val assumption       : tactic
+val exact_no_check   : constr -> tactic
+val exact_check      : constr -> tactic
+val exact_proof      : Topconstr.constr_expr -> tactic
+
+(*s Reduction tactics. *)
+
+type tactic_reduction = env -> evar_map -> constr -> constr
+
+val reduct_in_hyp     : tactic_reduction -> hyp_location -> tactic
+val reduct_option     : tactic_reduction -> simple_clause -> tactic
+val reduct_in_concl   : tactic_reduction -> tactic
+val change_in_concl   : constr occurrences option -> constr -> tactic
+val change_in_hyp     : constr occurrences option -> constr -> hyp_location ->
+  tactic
+val red_in_concl      : tactic
+val red_in_hyp        : hyp_location        -> tactic
+val red_option        : simple_clause -> tactic
+val hnf_in_concl      : tactic
+val hnf_in_hyp        : hyp_location        -> tactic
+val hnf_option        : simple_clause -> tactic
+val simpl_in_concl    : tactic
+val simpl_in_hyp      : hyp_location        -> tactic
+val simpl_option      : simple_clause -> tactic
+val normalise_in_concl: tactic
+val normalise_in_hyp  : hyp_location        -> tactic
+val normalise_option  : simple_clause -> tactic
+val unfold_in_concl   : (int list * evaluable_global_reference) list -> tactic
+val unfold_in_hyp     : 
+  (int list * evaluable_global_reference) list -> hyp_location -> tactic
+val unfold_option     : 
+  (int list * evaluable_global_reference) list -> simple_clause
+    -> tactic
+val reduce            : red_expr -> clause -> tactic
+val change            :
+  constr occurrences option -> constr -> clause -> tactic
+
+val unfold_constr     : global_reference -> tactic
+val pattern_option  : (int list * constr) list -> simple_clause -> tactic
+
+(*s Modification of the local context. *)
+
+val clear         : identifier list -> tactic
+val clear_body    : identifier list -> tactic
+
+val new_hyp       : int option -> constr with_bindings -> tactic
+
+val move_hyp      : bool -> identifier -> identifier -> tactic
+val rename_hyp    : identifier -> identifier -> tactic
+
+(*s Resolution tactics. *)
+
+val apply_type : constr -> constr list -> tactic
+val apply_term : constr -> constr list -> tactic
+val bring_hyps : named_context -> tactic
+
+val apply                 : constr      -> tactic
+val apply_without_reduce  : constr      -> tactic
+val apply_list            : constr list -> tactic
+val apply_with_bindings   : constr with_bindings -> tactic
+
+val cut_and_apply         : constr -> tactic
+
+(*s Elimination tactics. *)
+
+val general_elim  : constr with_bindings -> constr with_bindings -> 
+  ?allow_K:bool -> tactic
+val default_elim  : constr with_bindings -> tactic
+val simplest_elim : constr -> tactic
+val elim          : constr with_bindings -> constr with_bindings option -> tactic
+val general_elim_in : identifier -> constr * constr bindings ->
+                      constr * constr bindings -> tactic
+
+val simple_induct     : quantified_hypothesis * (bool ref * intro_pattern_expr list ref list) list ref -> tactic
+val general_elim_in : identifier -> constr * constr bindings ->
+                      constr * constr bindings -> tactic
+
+val new_induct : constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+
+(*s Case analysis tactics. *)
+
+val general_case_analysis : constr with_bindings ->  tactic
+val simplest_case         : constr -> tactic
+
+val simple_destruct          : quantified_hypothesis -> tactic
+val new_destruct : constr induction_arg -> constr with_bindings option ->
+  intro_pattern_expr option * (bool ref * intro_pattern_expr list ref list) list ref
+  -> tactic
+
+(*s Eliminations giving the type instead of the proof. *)
+
+val case_type         : constr  -> tactic
+val elim_type         : constr  -> tactic
+
+(*s Some eliminations which are frequently used. *)
+
+val impE : identifier -> tactic
+val andE : identifier -> tactic
+val orE  : identifier -> tactic
+val dImp : clause -> tactic
+val dAnd : clause -> tactic
+val dorE : bool -> clause ->tactic
+
+
+(*s Introduction tactics. *)
+
+val constructor_tac            : int option -> int -> 
+                                 constr bindings  -> tactic
+val one_constructor            : int -> constr bindings  -> tactic
+val any_constructor            : tactic option -> tactic
+val left                       : constr bindings -> tactic
+val simplest_left              : tactic
+val right                      : constr bindings -> tactic
+val simplest_right             : tactic
+val split                      : constr bindings -> tactic
+val simplest_split             : tactic
+
+(*s Logical connective tactics. *)
+
+val reflexivity                 : tactic
+val intros_reflexivity          : tactic
+
+val symmetry                    : tactic
+val symmetry_in                 : identifier -> tactic
+val intros_symmetry             : clause -> tactic
+
+val transitivity                : constr -> tactic
+val intros_transitivity         : constr -> tactic
+
+val cut                         : constr -> tactic
+val cut_intro                   : constr -> tactic
+val cut_replacing               : identifier -> constr -> tactic
+val cut_in_parallel             : constr list -> tactic
+
+val assert_tac                  : bool -> name -> constr -> tactic
+val true_cut                    : name -> constr -> tactic
+val letin_tac                   : bool -> name -> constr -> clause -> tactic
+val forward                     : bool -> name -> constr -> tactic
+val generalize                  : constr list -> tactic
+val generalize_dep              : constr  -> tactic
+
+val tclABSTRACT : identifier option -> tactic -> tactic
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
new file mode 100644
index 00000000..553acc91
--- /dev/null
+++ b/tactics/tauto.ml4
@@ -0,0 +1,209 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i camlp4deps: "parsing/grammar.cma" i*)
+
+(*i $Id: tauto.ml4,v 1.62.2.1 2004/07/16 19:30:55 herbelin Exp $ i*)
+
+open Ast
+open Coqast
+open Hipattern
+open Names
+open Libnames
+open Pp
+open Proof_type
+open Tacticals
+open Tacinterp
+open Tactics
+open Util
+
+let assoc_last ist =
+  match List.assoc (Names.id_of_string "X1") ist.lfun with
+    | VConstr c -> c
+    | _ -> failwith "Tauto: anomaly"
+
+let is_empty ist =
+  if is_empty_type (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+
+let is_unit ist =
+  if is_unit_type (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+    
+let is_conj ist =
+  let ind = assoc_last ist in
+    if (is_conjunction ind) && (is_nodep_ind ind) then
+      <:tactic<idtac>>
+    else
+      <:tactic<fail>>
+
+let is_disj ist =
+  if is_disjunction (assoc_last ist) then
+    <:tactic<idtac>>
+  else
+    <:tactic<fail>>
+
+let not_dep_intros ist =
+  <:tactic<
+  repeat match goal with
+  | |- (?X1 -> ?X2) => intro
+  | |- (Coq.Init.Logic.iff _ _) => unfold Coq.Init.Logic.iff
+  | |- (Coq.Init.Logic.not _)   => unfold Coq.Init.Logic.not
+  | H:(Coq.Init.Logic.iff _ _)|- _ => unfold Coq.Init.Logic.iff in H
+  | H:(Coq.Init.Logic.not _)|-_    => unfold Coq.Init.Logic.not in H
+  | H:(Coq.Init.Logic.iff _ _)->_|- _ => unfold Coq.Init.Logic.iff in H
+  | H:(Coq.Init.Logic.not _)->_|-_    => unfold Coq.Init.Logic.not in H
+  end >>
+				      
+let axioms ist =
+  let t_is_unit = tacticIn is_unit
+  and t_is_empty = tacticIn is_empty in
+    <:tactic<
+    match reverse goal with
+      | |- ?X1 => $t_is_unit; constructor 1
+      | _:?X1 |- _ => $t_is_empty; elimtype X1; assumption
+      | _:?X1 |- ?X1 => assumption
+    end >>
+
+
+let simplif ist =
+  let t_is_unit = tacticIn is_unit
+  and t_is_conj = tacticIn is_conj
+  and t_is_disj = tacticIn is_disj
+  and t_not_dep_intros = tacticIn not_dep_intros in
+  <:tactic<
+    $t_not_dep_intros;
+    repeat
+       (match reverse goal with
+        | id: (?X1 _ _) |- _ =>
+            $t_is_conj; elim id; do 2 intro; clear id
+        | id: (?X1 _ _) |- _ => $t_is_disj; elim id; intro; clear id
+        | id0: ?X1-> ?X2, id1: ?X1|- _ =>
+	    (* generalize (id0 id1); intro; clear id0 does not work
+	       (see Marco Maggiesi's bug PR#301)
+	    so we instead use Assert and exact. *)
+	    assert X2; [exact (id0 id1) | clear id0]
+        | id: ?X1 -> ?X2|- _ =>
+          $t_is_unit; cut X2;
+	    [ intro; clear id
+	    | (* id : ?X1 -> ?X2 |- ?X2 *)
+	      cut X1; [exact id| constructor 1; fail]
+	    ]
+        | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
+          $t_is_conj; cut (X2-> X3-> X4);
+	    [ intro; clear id
+	    | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X3 -> ?X4 *)
+	      intro; intro; cut (X1 X2 X3); [exact id| split; assumption]
+	    ]
+        | id: (?X1 ?X2 ?X3) -> ?X4|- _ =>
+          $t_is_disj;
+	    cut (X3-> X4);
+	      [cut (X2-> X4);
+	        [intro; intro; clear id
+		| (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X2 -> ?X4 *)
+		  intro; cut (X1 X2 X3); [exact id| left; assumption]
+		]
+	      | (* id: (?X1 ?X2 ?X3) -> ?X4 |- ?X3 -> ?X4 *)
+		intro; cut (X1 X2 X3); [exact id| right; assumption]
+	      ]
+        | |- (?X1 _ _) => $t_is_conj; split
+        end;
+        $t_not_dep_intros) >>
+
+let rec tauto_intuit t_reduce solver ist =
+  let t_axioms = tacticIn axioms
+  and t_simplif = tacticIn simplif
+  and t_is_disj = tacticIn is_disj
+  and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in
+  let t_solver = Tacexpr.TacArg (valueIn (VTactic (dummy_loc,solver))) in
+  <:tactic<
+   ($t_simplif;$t_axioms
+   || match reverse goal with
+      | id:(?X1-> ?X2)-> ?X3|- _ =>
+	  cut X3;
+	    [ intro; clear id; $t_tauto_intuit 
+	    | cut (X1 -> X2);
+		[ exact id
+		| generalize (fun y:X2 => id (fun x:X1 => y)); intro; clear id;
+		  solve [ $t_tauto_intuit ]]]
+      | |- (?X1 _ _) =>
+          $t_is_disj; solve [left;$t_tauto_intuit | right;$t_tauto_intuit]
+      end
+    ||
+    (* NB: [|- _ -> _] matches any product *)
+    match goal with | |- _ -> _ => intro; $t_tauto_intuit
+    |  |- _  => $t_reduce;$t_solver
+    end
+    ||
+    $t_solver
+   ) >>
+    
+let reduction_not_iff=interp
+ <:tactic<repeat 
+  match goal with 
+  | |- _     => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff 
+  | H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H
+  end >>
+
+
+let t_reduction_not_iff =
+  Tacexpr.TacArg (valueIn (VTactic (dummy_loc,reduction_not_iff)))
+
+let intuition_gen tac =
+  interp (tacticIn (tauto_intuit t_reduction_not_iff tac))
+
+let simplif_gen = interp (tacticIn simplif)
+
+let tauto g =
+  try intuition_gen (interp <:tactic<fail>>) g
+  with
+    Refiner.FailError _ | UserError _ ->
+      errorlabstrm "tauto" [< str "Tauto failed" >]
+
+let default_intuition_tac = interp <:tactic< auto with * >>
+
+let q_elim tac=
+  <:tactic<
+  match goal with 
+    x : ?X1, H : ?X1 -> _ |- _ => generalize (H x); clear H; $tac
+  end >>
+
+let rec lfo n gl=
+  if n=0 then (tclFAIL 0 "LinearIntuition failed" gl) else
+    let p=if n<0 then n else (n-1) in
+    let lfo_rec=q_elim (Tacexpr.TacArg (valueIn (VTactic(dummy_loc,lfo p)))) in
+      intuition_gen (interp lfo_rec) gl
+
+let lfo_wrap n gl= 
+  try lfo n gl
+  with
+    Refiner.FailError _ | UserError _ ->
+      errorlabstrm "LinearIntuition" [< str "LinearIntuition failed." >]
+
+TACTIC EXTEND Tauto
+| [ "Tauto" ] -> [ tauto ]
+END
+(* Obsolete sinve V8.0
+TACTIC EXTEND TSimplif
+| [ "Simplif" ] -> [ simplif_gen ]
+END
+*)
+TACTIC EXTEND Intuition
+| [ "Intuition" ] -> [ intuition_gen default_intuition_tac ]
+| [ "Intuition" tactic(t) ] -> [ intuition_gen (snd t) ]
+END
+(* Obsolete since V8.0
+TACTIC EXTEND LinearIntuition
+| [ "LinearIntuition" ] -> [ lfo_wrap (-1)]
+| [ "LinearIntuition" integer(n)] -> [ lfo_wrap n]
+END
+*)
diff --git a/tactics/termdn.ml b/tactics/termdn.ml
new file mode 100644
index 00000000..9e77ddbd
--- /dev/null
+++ b/tactics/termdn.ml
@@ -0,0 +1,84 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(* $Id: termdn.ml,v 1.15.8.1 2004/07/16 19:30:56 herbelin Exp $ *)
+
+open Util
+open Names
+open Nameops
+open Term
+open Pattern
+open Rawterm
+open Libnames
+open Nametab
+
+(* Discrimination nets of terms.
+   See the module dn.ml for further explanations.
+   Eduardo (5/8/97) *)
+
+type 'a t = (constr_label,constr_pattern,'a) Dn.t
+
+(*If we have: f a b c ..., decomp gives: (f,[a;b;c;...])*)
+
+let decomp = 
+  let rec decrec acc c = match kind_of_term c with
+    | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f
+    | Cast (c1,_) -> decrec acc c1
+    | _ -> (c,acc)
+  in 
+  decrec []
+
+let decomp_pat = 
+  let rec decrec acc = function
+    | PApp (f,args) -> decrec (Array.to_list args @ acc) f
+    | c -> (c,acc)
+  in 
+  decrec []   
+
+let constr_pat_discr t =
+  if not (occur_meta_pattern t) then 
+    None
+  else
+    match decomp_pat t with
+      | PRef (IndRef sp), args -> Some(IndNode sp,args)
+      | PRef (ConstructRef sp), args -> Some(CstrNode sp,args)
+      | PRef (VarRef id), args -> Some(VarNode id,args)
+      | _ -> None
+
+let constr_val_discr t =
+  let c, l = decomp t in
+  match kind_of_term c with
+    (* Const _,_) -> Some(TERM c,l) *)
+    | Ind ind_sp -> Some(IndNode ind_sp,l)
+    | Construct cstr_sp -> Some(CstrNode cstr_sp,l)
+    (* Ici, comment distinguer SectionVarNode de VarNode ?? *)
+    | Var id -> Some(VarNode id,l)
+    | _ -> None
+
+(* Les deux fonctions suivantes ecrasaient les precedentes, 
+   ajout d'un suffixe _nil CP 16/08 *) 
+
+let constr_pat_discr_nil t =
+  match constr_pat_discr t with
+    | None -> None
+    | Some (c,_) -> Some(c,[])
+
+let constr_val_discr_nil t =
+  match constr_val_discr t with
+    | None -> None
+    | Some (c,_) -> Some(c,[])
+
+let create = Dn.create 
+
+let add dn = Dn.add dn constr_pat_discr
+
+let rmv dn = Dn.rmv dn constr_pat_discr
+
+let lookup dn t = Dn.lookup dn constr_val_discr t
+
+let app f dn = Dn.app f dn
diff --git a/tactics/termdn.mli b/tactics/termdn.mli
new file mode 100644
index 00000000..e3caf6d9
--- /dev/null
+++ b/tactics/termdn.mli
@@ -0,0 +1,51 @@
+(************************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(*   \VV/  **************************************************************)
+(*    //   *      This file is distributed under the terms of the       *)
+(*         *       GNU Lesser General Public License Version 2.1        *)
+(************************************************************************)
+
+(*i $Id: termdn.mli,v 1.9.16.1 2004/07/16 19:30:56 herbelin Exp $ i*)
+
+(*i*)
+open Term
+open Pattern
+(*i*)
+  
+(* Discrimination nets of terms. *)
+
+(* This module registers actions (typically tactics) mapped to patterns *)
+
+(* Patterns are stocked linearly as the list of its node in prefix
+order in such a way patterns having the same prefix have this common
+prefix shared and the seek for the action associated to the patterns
+that a term matches are found in time proportional to the maximal
+number of nodes of the patterns matching the term *)
+
+type 'a t
+
+val create : unit -> 'a t
+
+(* [add t (c,a)] adds to table [t] pattern [c] associated to action [act] *)
+
+val add : 'a t -> (constr_pattern * 'a) -> 'a t
+
+val rmv : 'a t -> (constr_pattern * 'a) -> 'a t
+
+(* [lookup t c] looks for patterns (with their action) matching term [c] *)
+
+val lookup : 'a t -> constr -> (constr_pattern * 'a) list
+
+val app : ((constr_pattern * 'a) -> unit) -> 'a t -> unit
+
+
+(*i*)
+(* These are for Nbtermdn *)
+
+val constr_pat_discr : 
+  constr_pattern -> (constr_label * constr_pattern list) option
+val constr_val_discr :
+  constr -> (constr_label * constr list) option
+
+(*i*)